Page MenuHomeIsabelle/Phabricator
Files F1580613

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
diff --git a/thys/Bicategory/Bicategory.thy b/thys/Bicategory/Bicategory.thy
--- a/thys/Bicategory/Bicategory.thy
+++ b/thys/Bicategory/Bicategory.thy
@@ -1,2498 +1,2498 @@
(* Title: Bicategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
theory Bicategory
imports Prebicategory Category3.Subcategory Category3.DiscreteCategory
MonoidalCategory.MonoidalCategory
begin
section "Bicategories"
text \<open>
A \emph{bicategory} is a (vertical) category that has been equipped with
a horizontal composition, an associativity natural isomorphism,
and for each object a ``unit isomorphism'', such that horizontal
composition on the left by target and on the right by source are
fully faithful endofunctors of the vertical category, and such that
the usual pentagon coherence condition holds for the associativity.
\<close>
locale bicategory =
horizontal_composition V H src trg +
VxVxV: product_category V VxV.comp +
VVV: subcategory VxVxV.comp \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close> +
HoHV: "functor" VVV.comp V HoHV +
HoVH: "functor" VVV.comp V HoVH +
\<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
L: fully_faithful_functor V V L +
R: fully_faithful_functor V V R
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a" +
assumes unit_in_vhom: "obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
and iso_unit: "obj a \<Longrightarrow> iso \<i>[a]"
and pentagon: "\<lbrakk> ide f; ide g; ide h; ide k; src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
(f \<star> \<a> g h k) \<cdot> \<a> f (g \<star> h) k \<cdot> (\<a> f g h \<star> k) = \<a> f g (h \<star> k) \<cdot> \<a> (f \<star> g) h k"
begin
(*
* TODO: the mapping \<i> is not currently assumed to be extensional.
* It might be best in the long run if it were.
*)
definition \<alpha>
where "\<alpha> \<mu>\<nu>\<tau> \<equiv> \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
lemma assoc_in_hom':
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "in_hhom \<a>[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
and "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<tau>\<guillemotright>"
proof -
show "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<tau>\<guillemotright>"
proof -
have 1: "VVV.in_hom (\<mu>, \<nu>, \<tau>) (dom \<mu>, dom \<nu>, dom \<tau>) (cod \<mu>, cod \<nu>, cod \<tau>)"
using assms VVV.in_hom_char VVV.arr_char VV.arr_char by auto
have "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : HoHV (dom \<mu>, dom \<nu>, dom \<tau>) \<Rightarrow> HoVH (cod \<mu>, cod \<nu>, cod \<tau>)\<guillemotright>"
using 1 \<alpha>.preserves_hom by auto
moreover have "HoHV (dom \<mu>, dom \<nu>, dom \<tau>) = (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau>"
using 1 HoHV_def by (simp add: VVV.in_hom_char)
moreover have "HoVH (cod \<mu>, cod \<nu>, cod \<tau>) = cod \<mu> \<star> cod \<nu> \<star> cod \<tau>"
using 1 HoVH_def by (simp add: VVV.in_hom_char)
ultimately show ?thesis by simp
qed
thus "in_hhom \<a>[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
using assms src_cod trg_cod vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
qed
lemma assoc_is_natural_1:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "\<a>[\<mu>, \<nu>, \<tau>] = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
using assms \<alpha>.is_natural_1 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char VVV.dom_char
HoVH_def src_dom trg_dom
by simp
lemma assoc_is_natural_2:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "\<a>[\<mu>, \<nu>, \<tau>] = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
using assms \<alpha>.is_natural_2 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char VVV.cod_char
HoHV_def src_dom trg_dom
by simp
lemma assoc_naturality:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "\<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>) = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
using assms \<alpha>.naturality VVV.arr_char VV.arr_char HoVH_def HoHV_def
VVV.dom_char VVV.cod_char
by auto
lemma assoc_in_hom [intro]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "in_hhom \<a>[f, g, h] (src h) (trg f)"
and "\<guillemotleft>\<a>[f, g, h] : (dom f \<star> dom g) \<star> dom h \<Rightarrow> cod f \<star> cod g \<star> cod h\<guillemotright>"
using assms assoc_in_hom' apply auto[1]
using assms assoc_in_hom' ideD(1) by metis
lemma assoc_simps [simp]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "arr \<a>[f, g, h]"
and "src \<a>[f, g, h] = src h" and "trg \<a>[f, g, h] = trg f"
and "dom \<a>[f, g, h] = (dom f \<star> dom g) \<star> dom h"
and "cod \<a>[f, g, h] = cod f \<star> cod g \<star> cod h"
using assms assoc_in_hom apply auto
using assoc_in_hom(1) by auto
lemma iso_assoc [intro, simp]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "iso \<a>[f, g, h]"
using assms \<alpha>.components_are_iso [of "(f, g, h)"] VVV.ide_char VVV.arr_char VV.arr_char
by simp
end
subsection "Categories Induce Bicategories"
text \<open>
In this section we show that a category becomes a bicategory if we take the vertical
composition to be discrete, we take the composition of the category as the
horizontal composition, and we take the vertical domain and codomain as \<open>src\<close> and \<open>trg\<close>.
\<close>
(*
* It is helpful to make a few local definitions here, but I don't want them to
* clutter the category locale. Using a context and private definitions does not
* work as expected. So we have to define a new locale just for the present purpose.
*)
locale category_as_bicategory = category
begin
interpretation V: discrete_category \<open>Collect arr\<close> null
using not_arr_null by (unfold_locales, blast)
abbreviation V
where "V \<equiv> V.comp"
interpretation src: "functor" V V dom
using V.null_char
by (unfold_locales, simp add: has_domain_iff_arr dom_def, auto)
interpretation trg: "functor" V V cod
using V.null_char
by (unfold_locales, simp add: has_codomain_iff_arr cod_def, auto)
interpretation H: horizontal_homs V dom cod
by (unfold_locales, auto)
interpretation VxV: product_category V V ..
interpretation VV: subcategory VxV.comp
\<open>\<lambda>\<mu>\<nu>. V.arr (fst \<mu>\<nu>) \<and> V.arr (snd \<mu>\<nu>) \<and> dom (fst \<mu>\<nu>) = cod (snd \<mu>\<nu>)\<close>
using H.subcategory_VV by auto
interpretation VxVxV: product_category V VxV.comp ..
interpretation VVV: subcategory VxVxV.comp \<open>\<lambda>\<tau>\<mu>\<nu>. V.arr (fst \<tau>\<mu>\<nu>) \<and>
VV.arr (snd \<tau>\<mu>\<nu>) \<and> dom (fst \<tau>\<mu>\<nu>) = cod (fst (snd \<tau>\<mu>\<nu>))\<close>
using H.subcategory_VVV by auto
interpretation H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<cdot> snd \<mu>\<nu>\<close>
apply (unfold_locales)
using VV.arr_char V.null_char ext
apply force
using VV.arr_char V.null_char VV.dom_char VV.cod_char
apply auto[3]
proof -
show "\<And>g f. VV.seq g f \<Longrightarrow>
fst (VV.comp g f) \<cdot> snd (VV.comp g f) = V (fst g \<cdot> snd g) (fst f \<cdot> snd f)"
proof -
have 0: "\<And>f. VV.arr f \<Longrightarrow> V.arr (fst f \<cdot> snd f)"
using VV.arr_char by auto
have 1: "\<And>f g. V.seq g f \<Longrightarrow> V.ide f \<and> g = f"
using V.arr_char V.dom_char V.cod_char V.not_arr_null by force
have 2: "\<And>f g. VxV.seq g f \<Longrightarrow> VxV.ide f \<and> g = f"
using 1 VxV.seq_char by (metis VxV.dom_eqI VxV.ide_Ide)
fix f g
assume fg: "VV.seq g f"
have 3: "VV.ide f \<and> f = g"
using fg 2 VV.seq_char VV.ide_char by blast
show "fst (VV.comp g f) \<cdot> snd (VV.comp g f) = V (fst g \<cdot> snd g) (fst f \<cdot> snd f)"
using fg 0 1 3 VV.comp_char VV.arr_char VV.ide_char V.arr_char V.comp_char
VV.comp_arr_ide
by (metis (no_types, lifting))
qed
qed
interpretation H: horizontal_composition V C dom cod
by (unfold_locales, auto)
interpretation H.HoHV: "functor" VVV.comp V H.HoHV
using H.functor_HoHV by blast
interpretation H.HoVH: "functor" VVV.comp V H.HoVH
using H.functor_HoVH by blast
abbreviation \<a>
where "\<a> f g h \<equiv> f \<cdot> g \<cdot> h"
interpretation \<alpha>: natural_isomorphism VVV.comp V H.HoHV H.HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close>
apply unfold_locales
using V.null_char ext
apply fastforce
using H.HoHV_def H.HoVH_def VVV.arr_char VV.arr_char VVV.dom_char VV.dom_char
VVV.cod_char VV.cod_char VVV.ide_char comp_assoc
by auto
interpretation endofunctor V H.L
using H.endofunctor_L by auto
interpretation endofunctor V H.R
using H.endofunctor_R by auto
interpretation fully_faithful_functor V V H.R
using comp_arr_dom by (unfold_locales, auto)
interpretation fully_faithful_functor V V H.L
using comp_cod_arr by (unfold_locales, auto)
abbreviation \<i>
where "\<i> \<equiv> \<lambda>x. x"
proposition induces_bicategory:
shows "bicategory V C \<a> \<i> dom cod"
apply (unfold_locales, auto simp add: comp_assoc)
using comp_arr_dom by fastforce
end
subsection "Monoidal Categories induce Bicategories"
text \<open>
In this section we show that our definition of bicategory directly generalizes our
definition of monoidal category:
a monoidal category becomes a bicategory when equipped with the constant-\<open>\<I>\<close> functors
as src and trg and \<open>\<iota>\<close> as the unit isomorphism from \<open>\<I> \<otimes> \<I>\<close> to \<open>\<I>\<close>.
There is a slight mismatch because the bicategory locale assumes that the associator
is given in curried form, whereas for monoidal categories it is given in tupled form.
Ultimately, the monoidal category locale should be revised to also use curried form,
which ends up being more convenient in most situations.
\<close>
context monoidal_category
begin
interpretation I: constant_functor C C \<I>
using \<iota>_in_hom by unfold_locales auto
interpretation HH: horizontal_homs C I.map I.map
by unfold_locales auto
interpretation CC': subcategory CC.comp \<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and>
I.map (fst \<mu>\<nu>) = I.map (snd \<mu>\<nu>)\<close>
using HH.subcategory_VV by auto
interpretation CCC': subcategory CCC.comp \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> CC'.arr (snd \<tau>\<mu>\<nu>) \<and>
I.map (fst \<tau>\<mu>\<nu>) = I.map (fst (snd \<tau>\<mu>\<nu>))\<close>
using HH.subcategory_VVV by simp
lemma CC'_eq_CC:
shows "CC.comp = CC'.comp"
proof -
have "\<And>g f. CC.comp g f = CC'.comp g f"
proof -
fix f g
show "CC.comp g f = CC'.comp g f"
proof -
have "CC.seq g f \<Longrightarrow> CC.comp g f = CC'.comp g f"
using CC'.comp_char CC'.arr_char CC.seq_char
by (elim CC.seqE seqE, simp)
moreover have "\<not> CC.seq g f \<Longrightarrow> CC.comp g f = CC'.comp g f"
using CC'.seq_char CC'.ext CC'.null_char CC.ext
by (metis (no_types, lifting))
ultimately show ?thesis by blast
qed
qed
thus ?thesis by blast
qed
lemma CCC'_eq_CCC:
shows "CCC.comp = CCC'.comp"
proof -
have "\<And>g f. CCC.comp g f = CCC'.comp g f"
proof -
fix f g
show "CCC.comp g f = CCC'.comp g f"
proof -
have "CCC.seq g f \<Longrightarrow> CCC.comp g f = CCC'.comp g f"
using CCC'.comp_char CCC'.arr_char CCC.seq_char CC'.arr_char
by (elim CCC.seqE CC.seqE seqE, simp)
moreover have "\<not> CCC.seq g f \<Longrightarrow> CCC.comp g f = CCC'.comp g f"
using CCC'.seq_char CCC'.ext CCC'.null_char CCC.ext
by (metis (no_types, lifting))
ultimately show ?thesis by blast
qed
qed
thus ?thesis by blast
qed
interpretation H: "functor" CC'.comp C \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<otimes> snd \<mu>\<nu>\<close>
using CC'_eq_CC T.functor_axioms by simp
interpretation H: horizontal_composition C tensor I.map I.map
by (unfold_locales, simp_all)
lemma HoHV_eq_ToTC:
shows "H.HoHV = T.ToTC"
using H.HoHV_def T.ToTC_def CCC'_eq_CCC by presburger
interpretation HoHV: "functor" CCC'.comp C H.HoHV
using T.functor_ToTC HoHV_eq_ToTC CCC'_eq_CCC by argo
lemma HoVH_eq_ToCT:
shows "H.HoVH = T.ToCT"
using H.HoVH_def T.ToCT_def CCC'_eq_CCC by presburger
interpretation HoVH: "functor" CCC'.comp C H.HoVH
using T.functor_ToCT HoVH_eq_ToCT CCC'_eq_CCC by argo
interpretation \<alpha>: natural_isomorphism CCC'.comp C H.HoHV H.HoVH \<alpha>
using \<alpha>.natural_isomorphism_axioms CCC'_eq_CCC HoHV_eq_ToTC HoVH_eq_ToCT
by simp
lemma R'_eq_R:
shows "H.R = R"
using H.is_extensional CC'_eq_CC CC.arr_char by force
lemma L'_eq_L:
shows "H.L = L"
using H.is_extensional CC'_eq_CC CC.arr_char by force
interpretation R': fully_faithful_functor C C H.R
using R'_eq_R R.fully_faithful_functor_axioms unity_def by auto
interpretation L': fully_faithful_functor C C H.L
using L'_eq_L L.fully_faithful_functor_axioms unity_def by auto
lemma obj_char:
shows "HH.obj a \<longleftrightarrow> a = \<I>"
using HH.obj_def \<iota>_in_hom by fastforce
proposition induces_bicategory:
shows "bicategory C tensor (\<lambda>\<mu> \<nu> \<tau>. \<alpha> (\<mu>, \<nu>, \<tau>)) (\<lambda>_. \<iota>) I.map I.map"
using obj_char \<iota>_in_hom \<iota>_is_iso pentagon \<alpha>.is_extensional \<alpha>.is_natural_1 \<alpha>.is_natural_2
by (unfold_locales, simp_all)
end
subsection "Prebicategories Extend to Bicategories"
text \<open>
In this section, we show that a prebicategory with homs and units extends to a bicategory.
The main work is to show that the endofunctors \<open>L\<close> and \<open>R\<close> are fully faithful.
We take the left and right unitor isomorphisms, which were obtained via local
constructions in the left and right hom-subcategories defined by a specified
weak unit, and show that in the presence of the chosen sources and targets they
are the components of a global natural isomorphisms \<open>\<ll>\<close> and \<open>\<rr>\<close> from the endofunctors
\<open>L\<close> and \<open>R\<close> to the identity functor. A consequence is that functors \<open>L\<close> and \<open>R\<close> are
endo-equivalences, hence fully faithful.
\<close>
context prebicategory_with_homs
begin
text \<open>
Once it is equipped with a particular choice of source and target for each arrow,
a prebicategory determines a horizontal composition.
\<close>
lemma induces_horizontal_composition:
shows "horizontal_composition V H src trg"
proof -
interpret VxV: product_category V V ..
interpret VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and>
src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
using subcategory_VV by argo
interpret VxVxV: product_category V VxV.comp ..
interpret VVV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using subcategory_VVV by blast
interpret H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
proof -
have "VV.comp = VoV.comp"
using composable_char\<^sub>P\<^sub>B\<^sub>H by meson
thus "functor VV.comp V (\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>)"
using functor_axioms by argo
qed
show "horizontal_composition V H src trg"
using src_hcomp trg_hcomp composable_char\<^sub>P\<^sub>B\<^sub>H not_arr_null
by (unfold_locales; metis)
qed
end
sublocale prebicategory_with_homs \<subseteq> horizontal_composition V H src trg
using induces_horizontal_composition by auto
locale prebicategory_with_homs_and_units =
prebicategory_with_units +
prebicategory_with_homs
begin
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
text \<open>
The next definitions extend the left and right unitors that were defined locally with
respect to a particular weak unit, to globally defined versions using the chosen
source and target for each arrow.
\<close>
definition lunit ("\<l>[_]")
where "lunit f \<equiv> left_hom_with_unit.lunit V H \<a> \<i>[trg f] (trg f) f"
definition runit ("\<r>[_]")
where "runit f \<equiv> right_hom_with_unit.runit V H \<a> \<i>[src f] (src f) f"
lemma lunit_in_hom:
assumes "ide f"
shows "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
proof -
interpret Left: subcategory V \<open>left (trg f)\<close>
using assms left_hom_is_subcategory by simp
interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[trg f]\<close> \<open>trg f\<close>
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
have 0: "Left.ide f"
using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
show 1: "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
unfolding lunit_def
using assms 0 Left.lunit_char(1) Left.hom_char H\<^sub>L_def by auto
show "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
using 1 src_cod trg_cod src_in_sources trg_in_targets
by (metis arrI vconn_implies_hpar)
qed
lemma runit_in_hom:
assumes "ide f"
shows "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
proof -
interpret Right: subcategory V \<open>right (src f)\<close>
using assms right_hom_is_subcategory weak_unit_self_composable by force
interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[src f]\<close> \<open>src f\<close>
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
have 0: "Right.ide f"
using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
show 1: "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
unfolding runit_def
using assms 0 Right.runit_char(1) Right.hom_char H\<^sub>R_def by auto
show "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
using 1 src_cod trg_cod src_in_sources trg_in_targets
by (metis arrI vconn_implies_hpar)
qed
text \<open>
The characterization of the locally defined unitors yields a corresponding characterization
of the globally defined versions, by plugging in the chosen source or target for each
arrow for the unspecified weak unit in the the local versions.
\<close>
lemma lunit_char:
assumes "ide f"
shows "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
and "trg f \<star> \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and> trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
proof -
let ?a = "src f" and ?b = "trg f"
interpret Left: subcategory V \<open>left ?b\<close>
using assms left_hom_is_subcategory weak_unit_self_composable by force
interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
have 0: "Left.ide f"
using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
show "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
using assms lunit_in_hom by simp
show A: "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
using assms lunit_in_hom by simp
show B: "?b \<star> \<l>[f] = (\<i>[?b] \<star> f) \<cdot> inv \<a>[?b, ?b, f]"
unfolding lunit_def using 0 Left.lunit_char(2) H\<^sub>L_def
by (metis Left.comp_simp Left.characteristic_iso(1-2) Left.seqI')
show "\<exists>!\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and> trg f \<star> \<mu> = (\<i>[?b] \<star> f) \<cdot> inv \<a>[?b, ?b, f]"
proof -
have 1: "hom (trg f \<star> f) f = Left.hom (Left.L f) f"
proof
have 1: "Left.L f = ?b \<star> f"
using 0 H\<^sub>L_def by simp
show "Left.hom (Left.L f) f \<subseteq> hom (?b \<star> f) f"
using assms Left.hom_char [of "?b \<star> f" f] H\<^sub>L_def by simp
show "hom (?b \<star> f) f \<subseteq> Left.hom (Left.L f) f"
using assms 1 ide_in_hom composable_char\<^sub>P\<^sub>B\<^sub>H hom_connected left_def
Left.hom_char
by auto
qed
let ?P = "\<lambda>\<mu>. Left.in_hom \<mu> (Left.L f) f"
let ?P' = "\<lambda>\<mu>. \<guillemotleft>\<mu> : ?b \<star> f \<Rightarrow> f\<guillemotright>"
let ?Q = "\<lambda>\<mu>. Left.L \<mu> = (\<i>[?b] \<star> f) \<cdot> (inv \<a>[?b, ?b, f])"
let ?R = "\<lambda>\<mu>. ?b \<star> \<mu> = (\<i>[?b] \<star> f) \<cdot> (inv \<a>[?b, ?b, f])"
have 2: "?P = ?P'"
using 0 1 H\<^sub>L_def Left.hom_char by blast
moreover have "\<forall>\<mu>. ?P \<mu> \<longrightarrow> (?Q \<mu> \<longleftrightarrow> ?R \<mu>)"
using 2 Left.lunit_eqI H\<^sub>L_def by presburger
moreover have "(\<exists>!\<mu>. ?P \<mu> \<and> ?Q \<mu>)"
using 0 2 A B Left.lunit_char(3) Left.ide_char Left.arr_char
by (metis (no_types, lifting) Left.lunit_char(2) calculation(2) lunit_def)
ultimately show ?thesis by metis
qed
qed
lemma runit_char:
assumes "ide f"
shows "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
and "\<r>[f] \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and> \<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
proof -
let ?a = "src f" and ?b = "trg f"
interpret Right: subcategory V \<open>right ?a\<close>
using assms right_hom_is_subcategory weak_unit_self_composable by force
interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
have 0: "Right.ide f"
using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
show "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
using assms runit_in_hom by simp
show A: "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
using assms runit_in_hom by simp
show B: "\<r>[f] \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
unfolding runit_def using 0 Right.runit_char(2) H\<^sub>R_def
using Right.comp_simp Right.characteristic_iso(4) Right.iso_is_arr by auto
show "\<exists>!\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and> \<mu> \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
proof -
have 1: "hom (f \<star> ?a) f = Right.hom (Right.R f) f"
proof
have 1: "Right.R f = f \<star> ?a"
using 0 H\<^sub>R_def by simp
show "Right.hom (Right.R f) f \<subseteq> hom (f \<star> ?a) f"
using assms Right.hom_char [of "f \<star> ?a" f] H\<^sub>R_def by simp
show "hom (f \<star> ?a) f \<subseteq> Right.hom (Right.R f) f"
using assms 1 ide_in_hom composable_char\<^sub>P\<^sub>B\<^sub>H hom_connected right_def
Right.hom_char
by auto
qed
let ?P = "\<lambda>\<mu>. Right.in_hom \<mu> (Right.R f) f"
let ?P' = "\<lambda>\<mu>. \<guillemotleft>\<mu> : f \<star> ?a \<Rightarrow> f\<guillemotright>"
let ?Q = "\<lambda>\<mu>. Right.R \<mu> = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
let ?R = "\<lambda>\<mu>. \<mu> \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
have 2: "?P = ?P'"
using 0 1 H\<^sub>R_def Right.hom_char by blast
moreover have "\<forall>\<mu>. ?P \<mu> \<longrightarrow> (?Q \<mu> \<longleftrightarrow> ?R \<mu>)"
using 2 Right.runit_eqI H\<^sub>R_def by presburger
moreover have "(\<exists>!\<mu>. ?P \<mu> \<and> ?Q \<mu>)"
using 0 2 A B Right.runit_char(3) Right.ide_char Right.arr_char
by (metis (no_types, lifting) Right.runit_char(2) calculation(2) runit_def)
ultimately show ?thesis by metis
qed
qed
lemma lunit_eqI:
assumes "ide f" and "\<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
and "trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> (inv \<a>[trg f, trg f, f])"
shows "\<mu> = \<l>[f]"
using assms lunit_char(2-4) by blast
lemma runit_eqI:
assumes "ide f" and "\<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
and "\<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
shows "\<mu> = \<r>[f]"
using assms runit_char(2-4) by blast
lemma iso_lunit:
assumes "ide f"
shows "iso \<l>[f]"
proof -
let ?b = "trg f"
interpret Left: subcategory V \<open>left ?b\<close>
using assms left_hom_is_subcategory weak_unit_self_composable by force
interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
show ?thesis
proof -
have 0: "Left.ide f"
using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
thus ?thesis
unfolding lunit_def using Left.iso_lunit Left.iso_char by blast
qed
qed
lemma iso_runit:
assumes "ide f"
shows "iso \<r>[f]"
proof -
let ?a = "src f"
interpret Right: subcategory V \<open>right ?a\<close>
using assms right_hom_is_subcategory weak_unit_self_composable by force
interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
show ?thesis
proof -
have 0: "Right.ide f"
using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
thus ?thesis
unfolding runit_def using Right.iso_runit Right.iso_char by blast
qed
qed
lemma lunit_naturality:
assumes "arr \<mu>"
shows "\<mu> \<cdot> \<l>[dom \<mu>] = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
proof -
let ?a = "src \<mu>" and ?b = "trg \<mu>"
interpret Left: subcategory V \<open>left ?b\<close>
using assms obj_trg left_hom_is_subcategory weak_unit_self_composable by force
interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
interpret Left.L: endofunctor \<open>Left ?b\<close> Left.L
using assms endofunctor_H\<^sub>L [of ?b] weak_unit_self_composable obj_trg obj_is_weak_unit
by blast
have 1: "Left.in_hom \<mu> (dom \<mu>) (cod \<mu>)"
using assms Left.hom_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H obj_trg by auto
have 2: "Left.in_hom \<l>[Left.dom \<mu>] (?b \<star> dom \<mu>) (dom \<mu>)"
unfolding lunit_def
using assms 1 Left.in_hom_char trg_dom Left.lunit_char(1) H\<^sub>L_def
Left.arr_char Left.dom_char Left.ide_dom
by force
have 3: "Left.in_hom \<l>[Left.cod \<mu>] (?b \<star> cod \<mu>) (cod \<mu>)"
unfolding lunit_def
using assms 1 Left.in_hom_char trg_cod Left.lunit_char(1) H\<^sub>L_def
Left.cod_char Left.ide_cod
by force
have 4: "Left.in_hom (Left.L \<mu>) (?b \<star> dom \<mu>) (?b \<star> cod \<mu>)"
using 1 Left.L.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] H\<^sub>L_def by auto
show ?thesis
proof -
have "\<mu> \<cdot> \<l>[dom \<mu>] = Left.comp \<mu> \<l>[Left.dom \<mu>]"
using 1 2 Left.comp_simp by fastforce
also have "... = Left.comp \<mu> (Left.lunit (Left.dom \<mu>))"
using assms 1 lunit_def by auto
also have "... = Left.comp (Left.lunit (Left.cod \<mu>)) (Left.L \<mu>)"
using 1 Left.lunit_naturality by auto
also have "... = Left.comp (lunit (Left.cod \<mu>)) (Left.L \<mu>)"
using assms 1 lunit_def by auto
also have "... = \<l>[cod \<mu>] \<cdot> Left.L \<mu>"
using 1 3 4 Left.comp_char Left.cod_char Left.in_hom_char by auto
also have "... = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
using 1 by (simp add: H\<^sub>L_def)
finally show ?thesis by simp
qed
qed
lemma runit_naturality:
assumes "arr \<mu>"
shows "\<mu> \<cdot> \<r>[dom \<mu>] = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> src \<mu>)"
proof -
let ?a = "src \<mu>" and ?b = "trg \<mu>"
interpret Right: subcategory V \<open>right ?a\<close>
using assms right_hom_is_subcategory weak_unit_self_composable by force
interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
interpret Right.R: endofunctor \<open>Right ?a\<close> Right.R
using assms endofunctor_H\<^sub>R [of ?a] weak_unit_self_composable obj_src obj_is_weak_unit
by blast
have 1: "Right.in_hom \<mu> (dom \<mu>) (cod \<mu>)"
using assms Right.hom_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
have 2: "Right.in_hom \<r>[Right.dom \<mu>] (dom \<mu> \<star> ?a) (dom \<mu>)"
unfolding runit_def
using 1 Right.in_hom_char trg_dom Right.runit_char(1) [of "Right.dom \<mu>"] H\<^sub>R_def
Right.arr_char Right.dom_char Right.ide_dom assms
by force
have 3: "\<r>[Right.cod \<mu>] \<in> Right.hom (cod \<mu> \<star> ?a) (cod \<mu>)"
unfolding runit_def
using 1 Right.in_hom_char trg_cod Right.runit_char(1) [of "Right.cod \<mu>"] H\<^sub>R_def
Right.cod_char Right.ide_cod assms
by force
have 4: "Right.R \<mu> \<in> Right.hom (dom \<mu> \<star> ?a) (cod \<mu> \<star> ?a)"
using 1 Right.R.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] H\<^sub>R_def by auto
show ?thesis
proof -
have "\<mu> \<cdot> \<r>[dom \<mu>] = Right.comp \<mu> \<r>[Right.dom \<mu>]"
by (metis 1 2 Right.comp_char Right.in_homE Right.seqI' Right.seq_char)
also have "... = Right.comp \<mu> (Right.runit (Right.dom \<mu>))"
using assms 1 src_dom trg_dom Right.hom_char runit_def by auto
also have "... = Right.comp (Right.runit (Right.cod \<mu>)) (Right.R \<mu>)"
using 1 Right.runit_naturality by auto
also have "... = Right.comp (runit (Right.cod \<mu>)) (Right.R \<mu>)"
using assms 1 runit_def by auto
also have "... = \<r>[cod \<mu>] \<cdot> Right.R \<mu>"
using 1 3 4 Right.comp_char Right.cod_char Right.in_hom_char by auto
also have "... = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> ?a)"
using 1 by (simp add: H\<^sub>R_def)
finally show ?thesis by simp
qed
qed
interpretation L: endofunctor V L
using endofunctor_L by auto
interpretation \<ll>: transformation_by_components V V L map lunit
using lunit_in_hom lunit_naturality by unfold_locales auto
interpretation \<ll>: natural_isomorphism V V L map \<ll>.map
using iso_lunit by unfold_locales auto
lemma natural_isomorphism_\<ll>:
shows "natural_isomorphism V V L map \<ll>.map"
..
interpretation L: equivalence_functor V V L
using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
lemma equivalence_functor_L:
shows "equivalence_functor V V L"
..
lemma lunit_commutes_with_L:
assumes "ide f"
shows "\<l>[L f] = L \<l>[f]"
proof -
have "seq \<l>[f] (L \<l>[f])"
using assms lunit_char(2) L.preserves_hom by fastforce
moreover have "seq \<l>[f] \<l>[L f]"
using assms lunit_char(2) lunit_char(2) [of "L f"] L.preserves_ide by auto
ultimately show ?thesis
using assms lunit_char(2) [of f] lunit_naturality [of "\<l>[f]"] iso_lunit
iso_is_section section_is_mono monoE [of "\<l>[f]" "L \<l>[f]" "\<l>[L f]"]
by auto
qed
interpretation R: endofunctor V R
using endofunctor_R by auto
interpretation \<rr>: transformation_by_components V V R map runit
using runit_in_hom runit_naturality by unfold_locales auto
interpretation \<rr>: natural_isomorphism V V R map \<rr>.map
using iso_runit by unfold_locales auto
lemma natural_isomorphism_\<rr>:
shows "natural_isomorphism V V R map \<rr>.map"
..
interpretation R: equivalence_functor V V R
using R.isomorphic_to_identity_is_equivalence \<rr>.natural_isomorphism_axioms by simp
lemma equivalence_functor_R:
shows "equivalence_functor V V R"
..
lemma runit_commutes_with_R:
assumes "ide f"
shows "\<r>[R f] = R \<r>[f]"
proof -
have "seq \<r>[f] (R \<r>[f])"
using assms runit_char(2) R.preserves_hom by fastforce
moreover have "seq \<r>[f] \<r>[R f]"
using assms runit_char(2) runit_char(2) [of "R f"] R.preserves_ide by auto
ultimately show ?thesis
using assms runit_char(2) [of f] runit_naturality [of "\<r>[f]"] iso_runit
iso_is_section section_is_mono monoE [of "\<r>[f]" "R \<r>[f]" "\<r>[R f]"]
by auto
qed
interpretation VxVxV: product_category V VxV.comp ..
interpretation VVV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using subcategory_VVV by blast
interpretation HoHV: "functor" VVV.comp V HoHV
using functor_HoHV by blast
interpretation HoVH: "functor" VVV.comp V HoVH
using functor_HoVH by blast
definition \<alpha>
where "\<alpha> \<mu> \<nu> \<tau> \<equiv> if VVV.arr (\<mu>, \<nu>, \<tau>) then
(\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]
else null"
lemma \<alpha>_ide_simp [simp]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "\<alpha> f g h = \<a>[f, g, h]"
proof -
have "\<alpha> f g h = (f \<star> g \<star> h) \<cdot> \<a>[dom f, dom g, dom h]"
using assms \<alpha>_def VVV.arr_char [of "(f, g, h)"] by auto
also have "... = (f \<star> g \<star> h) \<cdot> \<a>[f, g, h]"
using assms by simp
also have "... = \<a>[f, g, h]"
using assms \<alpha>_def assoc_in_hom\<^sub>A\<^sub>W\<^sub>C hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H VVV.arr_char VoV.arr_char
comp_cod_arr composable_char\<^sub>P\<^sub>B\<^sub>H
by auto
finally show ?thesis by simp
qed
(* TODO: Figure out how this got reinstated. *)
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
lemma natural_isomorphism_\<alpha>:
shows "natural_isomorphism VVV.comp V HoHV HoVH
(\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)))"
proof -
interpret \<alpha>: transformation_by_components VVV.comp V HoHV HoVH
\<open>\<lambda>f. \<a>[fst f, fst (snd f), snd (snd f)]\<close>
proof
show 1: "\<And>x. VVV.ide x \<Longrightarrow> \<guillemotleft>\<a>[fst x, fst (snd x), snd (snd x)] : HoHV x \<Rightarrow> HoVH x\<guillemotright>"
proof -
fix x
assume x: "VVV.ide x"
show "\<guillemotleft>\<a>[fst x, fst (snd x), snd (snd x)] : HoHV x \<Rightarrow> HoVH x\<guillemotright>"
proof -
have "ide (fst x) \<and> ide (fst (snd x)) \<and> ide (snd (snd x)) \<and>
fst x \<star> fst (snd x) \<noteq> null \<and> fst (snd x) \<star> snd (snd x) \<noteq> null"
using x VVV.ide_char VVV.arr_char VV.arr_char composable_char\<^sub>P\<^sub>B\<^sub>H by simp
hence "\<a>[fst x, fst (snd x), snd (snd x)]
\<in> hom ((fst x \<star> fst (snd x)) \<star> snd (snd x))
(fst x \<star> fst (snd x) \<star> snd (snd x))"
using x assoc_in_hom\<^sub>A\<^sub>W\<^sub>C by simp
thus ?thesis
unfolding HoHV_def HoVH_def
using x VVV.ideD(1) by simp
qed
qed
show "\<And>f. VVV.arr f \<Longrightarrow>
\<a>[fst (VVV.cod f), fst (snd (VVV.cod f)), snd (snd (VVV.cod f))] \<cdot> HoHV f =
HoVH f \<cdot> \<a>[fst (VVV.dom f), fst (snd (VVV.dom f)), snd (snd (VVV.dom f))]"
unfolding HoHV_def HoVH_def
using assoc_naturality\<^sub>A\<^sub>W\<^sub>C VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char
composable_char\<^sub>P\<^sub>B\<^sub>H
by simp
qed
interpret \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH \<alpha>.map
proof
fix f
assume f: "VVV.ide f"
show "iso (\<alpha>.map f)"
proof -
have "fst f \<star> fst (snd f) \<noteq> null \<and> fst (snd f) \<star> snd (snd f) \<noteq> null"
using f VVV.ideD(1) VVV.arr_char [of f] VV.arr_char composable_char\<^sub>P\<^sub>B\<^sub>H by auto
thus ?thesis
using f \<alpha>.map_simp_ide iso_assoc\<^sub>A\<^sub>W\<^sub>C VVV.ide_char VVV.arr_char by simp
qed
qed
have "(\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))) = \<alpha>.map"
proof
fix \<mu>\<nu>\<tau>
have "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>"
using \<alpha>_def \<alpha>.map_def by simp
moreover have "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow>
\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>"
proof -
assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
have "\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) =
(fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>) \<star> snd (snd \<mu>\<nu>\<tau>)) \<cdot>
\<a>[dom (fst \<mu>\<nu>\<tau>), dom (fst (snd \<mu>\<nu>\<tau>)), dom (snd (snd \<mu>\<nu>\<tau>))]"
using \<mu>\<nu>\<tau> \<alpha>_def by simp
also have "... = \<a>[cod (fst \<mu>\<nu>\<tau>), cod (fst (snd \<mu>\<nu>\<tau>)), cod (snd (snd \<mu>\<nu>\<tau>))] \<cdot>
((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> HoHV_def HoVH_def VVV.arr_char VV.arr_char assoc_naturality\<^sub>A\<^sub>W\<^sub>C
composable_char\<^sub>P\<^sub>B\<^sub>H
by simp
also have "... =
\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> VVV.arr_char VVV.cod_char VV.arr_char by simp
also have "... = \<alpha>.map \<mu>\<nu>\<tau>"
using \<mu>\<nu>\<tau> \<alpha>.map_def HoHV_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
finally show ?thesis by blast
qed
ultimately show "\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>" by blast
qed
thus ?thesis using \<alpha>.natural_isomorphism_axioms by simp
qed
proposition induces_bicategory:
shows "bicategory V H \<alpha> \<i> src trg"
proof -
interpret VxVxV: product_category V VxV.comp ..
interpret VoVoV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using subcategory_VVV by blast
interpret HoHV: "functor" VVV.comp V HoHV
using functor_HoHV by blast
interpret HoVH: "functor" VVV.comp V HoVH
using functor_HoVH by blast
interpret \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close>
using natural_isomorphism_\<alpha> by blast
interpret L: equivalence_functor V V L
using equivalence_functor_L by blast
interpret R: equivalence_functor V V R
using equivalence_functor_R by blast
show "bicategory V H \<alpha> \<i> src trg"
proof
show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
using obj_is_weak_unit unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by blast
show "\<And>a. obj a \<Longrightarrow> iso \<i>[a]"
using obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by blast
show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k;
src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
(f \<star> \<alpha> g h k) \<cdot> \<alpha> f (g \<star> h) k \<cdot> (\<alpha> f g h \<star> k) =
\<alpha> f g (h \<star> k) \<cdot> \<alpha> (f \<star> g) h k"
proof -
fix f g h k
assume f: "ide f" and g: "ide g" and h: "ide h" and k: "ide k"
and fg: "src f = trg g" and gh: "src g = trg h" and hk: "src h = trg k"
have "sources f \<inter> targets g \<noteq> {}"
using f g fg src_in_sources [of f] trg_in_targets ideD(1) by auto
moreover have "sources g \<inter> targets h \<noteq> {}"
using g h gh src_in_sources [of g] trg_in_targets ideD(1) by auto
moreover have "sources h \<inter> targets k \<noteq> {}"
using h k hk src_in_sources [of h] trg_in_targets ideD(1) by auto
moreover have "\<alpha> f g h = \<a>[f, g, h] \<and> \<alpha> g h k = \<a>[g, h, k]"
using f g h k fg gh hk \<alpha>_ide_simp by simp
moreover have "\<alpha> f (g \<star> h) k = \<a>[f, g \<star> h, k] \<and> \<alpha> f g (h \<star> k) = \<a>[f, g, h \<star> k] \<and>
\<alpha> (f \<star> g) h k = \<a>[f \<star> g, h, k]"
using f g h k fg gh hk \<alpha>_ide_simp preserves_ide hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H(1) by simp
ultimately show "(f \<star> \<alpha> g h k) \<cdot> \<alpha> f (g \<star> h) k \<cdot> (\<alpha> f g h \<star> k) =
\<alpha> f g (h \<star> k) \<cdot> \<alpha> (f \<star> g) h k"
using f g h k fg gh hk pentagon\<^sub>A\<^sub>W\<^sub>C [of f g h k] \<alpha>_ide_simp by presburger
qed
qed
qed
end
text \<open>
The following is the main result of this development:
Every prebicategory extends to a bicategory, by making an arbitrary choice of
representatives of each isomorphism class of weak units and using that to
define the source and target mappings, and then choosing an arbitrary isomorphism
in \<open>hom (a \<star> a) a\<close> for each weak unit \<open>a\<close>.
\<close>
context prebicategory
begin
interpretation prebicategory_with_homs V H \<a> some_src some_trg
using extends_to_prebicategory_with_homs by auto
interpretation prebicategory_with_units V H \<a> some_unit
using extends_to_prebicategory_with_units by auto
interpretation prebicategory_with_homs_and_units V H \<a> some_unit some_src some_trg ..
theorem extends_to_bicategory:
shows "bicategory V H \<alpha> some_unit some_src some_trg"
using induces_bicategory by simp
end
section "Bicategories as Prebicategories"
subsection "Bicategories are Prebicategories"
text \<open>
In this section we show that a bicategory determines a prebicategory with homs,
whose weak units are exactly those arrows that are isomorphic to their chosen source,
or equivalently, to their chosen target.
Moreover, the notion of horizontal composability, which in a bicategory is determined
by the coincidence of chosen sources and targets, agrees with the version defined
for the induced weak composition in terms of nonempty intersections of source and
target sets, which is not dependent on any arbitrary choices.
\<close>
context bicategory
begin
(* TODO: Why does this get re-introduced? *)
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
interpretation \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> ..
abbreviation \<alpha>'
where "\<alpha>' \<equiv> \<alpha>'.map"
definition \<a>' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
where "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] \<equiv> \<alpha>'.map (\<mu>, \<nu>, \<tau>)"
lemma assoc'_in_hom':
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "in_hhom \<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
and "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : dom \<mu> \<star> dom \<nu> \<star> dom \<tau> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>\<guillemotright>"
proof -
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : dom \<mu> \<star> dom \<nu> \<star> dom \<tau> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>\<guillemotright>"
proof -
have 1: "VVV.in_hom (\<mu>, \<nu>, \<tau>) (dom \<mu>, dom \<nu>, dom \<tau>) (cod \<mu>, cod \<nu>, cod \<tau>)"
using assms VVV.in_hom_char VVV.arr_char VV.arr_char by auto
have "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : HoVH (dom \<mu>, dom \<nu>, dom \<tau>) \<Rightarrow> HoHV (cod \<mu>, cod \<nu>, cod \<tau>)\<guillemotright>"
using 1 \<a>'_def \<alpha>'.preserves_hom by auto
moreover have "HoVH (dom \<mu>, dom \<nu>, dom \<tau>) = dom \<mu> \<star> dom \<nu> \<star> dom \<tau>"
using 1 HoVH_def by (simp add: VVV.in_hom_char)
moreover have "HoHV (cod \<mu>, cod \<nu>, cod \<tau>) = (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>"
using 1 HoHV_def by (simp add: VVV.in_hom_char)
ultimately show ?thesis by simp
qed
thus "in_hhom \<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
using assms vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
qed
lemma assoc'_is_natural_1:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] = ((\<mu> \<star> \<nu>) \<star> \<tau>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<mu>, dom \<nu>, dom \<tau>]"
using assms \<alpha>'.is_natural_1 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char
VVV.dom_char HoHV_def src_dom trg_dom \<a>'_def
by simp
lemma assoc'_is_natural_2:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] = \<a>\<^sup>-\<^sup>1[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> (\<mu> \<star> \<nu> \<star> \<tau>)"
using assms \<alpha>'.is_natural_2 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char
VVV.cod_char HoVH_def src_dom trg_dom \<a>'_def
by simp
lemma assoc'_naturality:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "\<a>\<^sup>-\<^sup>1[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> (\<mu> \<star> \<nu> \<star> \<tau>) = ((\<mu> \<star> \<nu>) \<star> \<tau>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<mu>, dom \<nu>, dom \<tau>]"
using assms assoc'_is_natural_1 assoc'_is_natural_2 by metis
lemma assoc'_in_hom [intro]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "in_hhom \<a>\<^sup>-\<^sup>1[f, g, h] (src h) (trg f)"
and "\<guillemotleft>\<a>\<^sup>-\<^sup>1[f, g, h] : dom f \<star> dom g \<star> dom h \<Rightarrow> (cod f \<star> cod g) \<star> cod h\<guillemotright>"
using assms assoc'_in_hom'(1-2) ideD(1) by meson+
lemma assoc'_simps [simp]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "arr \<a>\<^sup>-\<^sup>1[f, g, h]"
and "src \<a>\<^sup>-\<^sup>1[f, g, h] = src h" and "trg \<a>\<^sup>-\<^sup>1[f, g, h] = trg f"
and "dom \<a>\<^sup>-\<^sup>1[f, g, h] = dom f \<star> dom g \<star> dom h"
and "cod \<a>\<^sup>-\<^sup>1[f, g, h] = (cod f \<star> cod g) \<star> cod h"
using assms assoc'_in_hom by blast+
lemma assoc'_eq_inv_assoc [simp]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "\<a>\<^sup>-\<^sup>1[f, g, h] = inv \<a>[f, g, h]"
using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char \<alpha>'.map_ide_simp
\<a>'_def
by auto
lemma inverse_assoc_assoc' [intro]:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "inverse_arrows \<a>[f, g, h] \<a>\<^sup>-\<^sup>1[f, g, h]"
using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char \<alpha>'.map_ide_simp
\<alpha>'.inverts_components \<a>'_def
by auto
lemma iso_assoc' [intro, simp]:
assumes "ide f" and "ide g" and "ide h"
and "src f = trg g" and "src g = trg h"
shows "iso \<a>\<^sup>-\<^sup>1[f, g, h]"
using assms iso_inv_iso by simp
lemma comp_assoc_assoc' [simp]:
assumes "ide f" and "ide g" and "ide h"
and "src f = trg g" and "src g = trg h"
shows "\<a>[f, g, h] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h] = f \<star> g \<star> h"
and "\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> \<a>[f, g, h] = (f \<star> g) \<star> h"
using assms comp_arr_inv' comp_inv_arr' by auto
lemma unit_in_hom [intro, simp]:
assumes "obj a"
shows "\<guillemotleft>\<i>[a] : a \<rightarrow> a\<guillemotright>" and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
proof -
show "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
using assms unit_in_vhom by simp
thus "\<guillemotleft>\<i>[a] : a \<rightarrow> a\<guillemotright>"
using assms src_cod trg_cod by fastforce
qed
interpretation weak_composition V H
using is_weak_composition by auto
lemma seq_if_composable:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "src \<nu> = trg \<mu>"
using assms H.is_extensional [of "(\<nu>, \<mu>)"] VV.arr_char by auto
lemma obj_self_composable:
assumes "obj a"
shows "a \<star> a \<noteq> null"
and "isomorphic (a \<star> a) a"
proof -
show 1: "isomorphic (a \<star> a) a"
using assms unit_in_hom iso_unit isomorphic_def by blast
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright>"
using 1 isomorphic_def by blast
have "ide (a \<star> a)" using 1 \<phi> ide_dom [of \<phi>] by fastforce
thus "a \<star> a \<noteq> null" using ideD(1) not_arr_null by metis
qed
lemma obj_is_weak_unit:
assumes "obj a"
shows "weak_unit a"
proof -
interpret Left_a: subcategory V \<open>left a\<close>
using assms left_hom_is_subcategory by force
interpret Right_a: subcategory V \<open>right a\<close>
using assms right_hom_is_subcategory by force
text \<open>
We know that \<open>H\<^sub>L a\<close> is fully faithful as a global endofunctor,
but the definition of weak unit involves its restriction to a
subcategory. So we have to verify that the restriction
is also a fully faithful functor.
\<close>
interpret La: endofunctor \<open>Left a\<close> \<open>H\<^sub>L a\<close>
using assms obj_self_composable endofunctor_H\<^sub>L [of a] by force
interpret La: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
proof
show "\<And>f f'. Left_a.par f f' \<Longrightarrow> H\<^sub>L a f = H\<^sub>L a f' \<Longrightarrow> f = f'"
proof -
fix \<mu> \<mu>'
assume par: "Left_a.par \<mu> \<mu>'"
assume eq: "H\<^sub>L a \<mu> = H\<^sub>L a \<mu>'"
have 1: "par \<mu> \<mu>'"
using par Left_a.arr_char Left_a.dom_char Left_a.cod_char left_def
composable_implies_arr null_agreement
by metis
moreover have "L \<mu> = L \<mu>'"
using par eq H\<^sub>L_def Left_a.arr_char left_def preserves_arr
assms 1 seq_if_composable [of a \<mu>] not_arr_null seq_if_composable [of a \<mu>']
by auto
ultimately show "\<mu> = \<mu>'"
using L.is_faithful by blast
qed
show "\<And>f g \<mu>. \<lbrakk> Left_a.ide f; Left_a.ide g; Left_a.in_hom \<mu> (H\<^sub>L a f) (H\<^sub>L a g) \<rbrakk> \<Longrightarrow>
\<exists>\<nu>. Left_a.in_hom \<nu> f g \<and> H\<^sub>L a \<nu> = \<mu>"
proof -
fix f g \<mu>
assume f: "Left_a.ide f" and g: "Left_a.ide g"
and \<mu>: "Left_a.in_hom \<mu> (H\<^sub>L a f) (H\<^sub>L a g)"
have 1: "a = trg f \<and> a = trg g"
using assms f g Left_a.ide_char Left_a.arr_char left_def seq_if_composable [of a f]
seq_if_composable [of a g]
by auto
show "\<exists>\<nu>. Left_a.in_hom \<nu> f g \<and> H\<^sub>L a \<nu> = \<mu>"
proof -
have 2: "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> L \<nu> = \<mu>"
using f g \<mu> 1 Left_a.ide_char H\<^sub>L_def L.preserves_reflects_arr Left_a.arr_char
Left_a.in_hom_char L.is_full
by force
obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> L \<nu> = \<mu>"
using 2 by blast
have "Left_a.arr \<nu>"
using \<nu> 1 trg_dom Left_a.arr_char left_def hseq_char' by fastforce
moreover have "H\<^sub>L a \<nu> = \<mu>"
using \<nu> 1 trg_dom H\<^sub>L_def by auto
ultimately show ?thesis
using \<nu> by force
qed
qed
qed
interpret Ra: endofunctor \<open>Right a\<close> \<open>H\<^sub>R a\<close>
using assms obj_self_composable endofunctor_H\<^sub>R [of a] by force
interpret Ra: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
proof
show "\<And>f f'. Right_a.par f f' \<Longrightarrow> H\<^sub>R a f = H\<^sub>R a f' \<Longrightarrow> f = f'"
proof -
fix \<mu> \<mu>'
assume par: "Right_a.par \<mu> \<mu>'"
assume eq: "H\<^sub>R a \<mu> = H\<^sub>R a \<mu>'"
have 1: "par \<mu> \<mu>'"
using par Right_a.arr_char Right_a.dom_char Right_a.cod_char right_def
composable_implies_arr null_agreement
by metis
moreover have "R \<mu> = R \<mu>'"
using par eq H\<^sub>R_def Right_a.arr_char right_def preserves_arr
assms 1 seq_if_composable [of \<mu> a] not_arr_null seq_if_composable [of \<mu>' a]
by auto
ultimately show "\<mu> = \<mu>'"
using R.is_faithful by blast
qed
show "\<And>f g \<mu>. \<lbrakk> Right_a.ide f; Right_a.ide g; Right_a.in_hom \<mu> (H\<^sub>R a f) (H\<^sub>R a g) \<rbrakk> \<Longrightarrow>
\<exists>\<nu>. Right_a.in_hom \<nu> f g \<and> H\<^sub>R a \<nu> = \<mu>"
proof -
fix f g \<mu>
assume f: "Right_a.ide f" and g: "Right_a.ide g"
and \<mu>: "Right_a.in_hom \<mu> (H\<^sub>R a f) (H\<^sub>R a g)"
have 1: "a = src f \<and> a = src g"
using assms f g Right_a.ide_char Right_a.arr_char right_def seq_if_composable
by auto
show "\<exists>\<nu>. Right_a.in_hom \<nu> f g \<and> H\<^sub>R a \<nu> = \<mu>"
proof -
have 2: "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> R \<nu> = \<mu>"
using f g \<mu> 1 Right_a.ide_char H\<^sub>R_def R.preserves_reflects_arr Right_a.arr_char
Right_a.in_hom_char R.is_full
by force
obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> R \<nu> = \<mu>"
using 2 by blast
have "Right_a.arr \<nu>"
using \<nu> 1 src_dom Right_a.arr_char right_def hseq_char' by fastforce
moreover have "H\<^sub>R a \<nu> = \<mu>"
using \<nu> 1 src_dom H\<^sub>R_def by auto
ultimately show ?thesis
using \<nu> by force
qed
qed
qed
have "isomorphic (a \<star> a) a \<and> a \<star> a \<noteq> null"
using assms obj_self_composable unit_in_hom iso_unit isomorphic_def by blast
thus ?thesis
using La.fully_faithful_functor_axioms Ra.fully_faithful_functor_axioms weak_unit_def
by blast
qed
lemma src_in_sources:
assumes "arr \<mu>"
shows "src \<mu> \<in> sources \<mu>"
using assms obj_is_weak_unit R.preserves_arr hseq_char' by auto
lemma trg_in_targets:
assumes "arr \<mu>"
shows "trg \<mu> \<in> targets \<mu>"
using assms obj_is_weak_unit L.preserves_arr hseq_char' by auto
lemma weak_unit_cancel_left:
assumes "weak_unit a" and "ide f" and "ide g"
and "a \<star> f \<cong> a \<star> g"
shows "f \<cong> g"
proof -
have 0: "ide a"
using assms weak_unit_def by force
interpret Left_a: subcategory V \<open>left a\<close>
using 0 left_hom_is_subcategory by simp
interpret Left_a: left_hom V H a
using assms by unfold_locales auto
interpret La: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
using assms weak_unit_def by fast
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> f \<Rightarrow> a \<star> g\<guillemotright>"
using assms by blast
have 1: "Left_a.iso \<phi> \<and> Left_a.in_hom \<phi> (a \<star> f) (a \<star> g)"
proof
have "a \<star> \<phi> \<noteq> null"
proof -
have "a \<star> dom \<phi> \<noteq> null"
using assms \<phi> weak_unit_self_composable
by (metis arr_dom_iff_arr hseq_char' in_homE match_4)
thus ?thesis
using hom_connected by simp
qed
thus "Left_a.in_hom \<phi> (a \<star> f) (a \<star> g)"
using \<phi> Left_a.hom_char left_def by auto
thus "Left_a.iso \<phi>"
using \<phi> Left_a.iso_char by auto
qed
hence 2: "Left_a.ide (a \<star> f) \<and> Left_a.ide (a \<star> g)"
using Left_a.ide_dom [of \<phi>] Left_a.ide_cod [of \<phi>] by auto
hence 3: "Left_a.ide f \<and> Left_a.ide g"
by (metis Left_a.ideI Left_a.ide_def Left_a.null_char assms(2) assms(3) left_def)
obtain \<psi> where \<psi>: "\<psi> \<in> Left_a.hom f g \<and> a \<star> \<psi> = \<phi>"
using assms 1 2 3 La.is_full [of g f \<phi>] H\<^sub>L_def by auto
have "Left_a.iso \<psi>"
using \<psi> 1 H\<^sub>L_def La.reflects_iso by auto
hence "iso \<psi> \<and> \<guillemotleft>\<psi> : f \<Rightarrow> g\<guillemotright>"
using \<psi> Left_a.iso_char Left_a.in_hom_char by auto
thus ?thesis by auto
qed
lemma weak_unit_cancel_right:
assumes "weak_unit a" and "ide f" and "ide g"
and "f \<star> a \<cong> g \<star> a"
shows "f \<cong> g"
proof -
have 0: "ide a"
using assms weak_unit_def by force
interpret Right_a: subcategory V \<open>right a\<close>
using 0 right_hom_is_subcategory by simp
interpret Right_a: right_hom V H a
using assms by unfold_locales auto
interpret R: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
using assms weak_unit_def by fast
obtain \<phi> where \<phi>: "iso \<phi> \<and> in_hom \<phi> (f \<star> a) (g \<star> a)"
using assms by blast
have 1: "Right_a.iso \<phi> \<and> \<phi> \<in> Right_a.hom (f \<star> a) (g \<star> a)"
proof
have "\<phi> \<star> a \<noteq> null"
proof -
have "dom \<phi> \<star> a \<noteq> null"
using assms \<phi> weak_unit_self_composable
by (metis arr_dom_iff_arr hseq_char' in_homE match_3)
thus ?thesis
using hom_connected by simp
qed
thus "\<phi> \<in> Right_a.hom (f \<star> a) (g \<star> a)"
using \<phi> Right_a.hom_char right_def by simp
thus "Right_a.iso \<phi>"
using \<phi> Right_a.iso_char by auto
qed
hence 2: "Right_a.ide (f \<star> a) \<and> Right_a.ide (g \<star> a)"
using Right_a.ide_dom [of \<phi>] Right_a.ide_cod [of \<phi>] by auto
hence 3: "Right_a.ide f \<and> Right_a.ide g"
using assms Right_a.ide_char Right_a.arr_char right_def Right_a.ide_def Right_a.null_char
by metis
obtain \<psi> where \<psi>: "\<psi> \<in> Right_a.hom f g \<and> \<psi> \<star> a = \<phi>"
using assms 1 2 3 R.is_full [of g f \<phi>] H\<^sub>R_def by auto
have "Right_a.iso \<psi>"
using \<psi> 1 H\<^sub>R_def R.reflects_iso by auto
hence "iso \<psi> \<and> \<guillemotleft>\<psi> : f \<Rightarrow> g\<guillemotright>"
using \<psi> Right_a.iso_char Right_a.in_hom_char by auto
thus ?thesis by auto
qed
text \<open>
All sources of an arrow ({\em i.e.}~weak units composable on the right with that arrow)
are isomorphic to the chosen source, and similarly for targets. That these statements
hold was somewhat surprising to me.
\<close>
lemma source_iso_src:
assumes "arr \<mu>" and "a \<in> sources \<mu>"
shows "a \<cong> src \<mu>"
proof -
have 0: "ide a"
using assms weak_unit_def by force
have 1: "src a = trg a"
using assms ide_dom sources_def weak_unit_iff_self_target seq_if_composable
by simp
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright>"
using assms weak_unit_def by blast
have "a \<star> src a \<cong> src a \<star> src a"
proof -
have "src a \<cong> src a \<star> src a"
using 0 obj_is_weak_unit weak_unit_def isomorphic_symmetric by auto
moreover have "a \<star> src a \<cong> src a"
proof -
have "a \<star> a \<star> src a \<cong> a \<star> src a"
proof -
have "iso (\<phi> \<star> src a) \<and> \<guillemotleft>\<phi> \<star> src a : (a \<star> a) \<star> src a \<Rightarrow> a \<star> src a\<guillemotright>"
using 0 1 \<phi> ide_in_hom(2) by auto
moreover have "iso \<a>\<^sup>-\<^sup>1[a, a, src a] \<and>
\<guillemotleft>\<a>\<^sup>-\<^sup>1[a, a, src a] : a \<star> a \<star> src a \<Rightarrow> (a \<star> a) \<star> src a\<guillemotright>"
using 0 1 iso_assoc' by force
ultimately show ?thesis
using isos_compose isomorphic_def by auto
qed
thus ?thesis
using assms 0 weak_unit_cancel_left by auto
qed
ultimately show ?thesis
using isomorphic_transitive by meson
qed
hence "a \<cong> src a"
using 0 weak_unit_cancel_right [of "src a" a "src a"] obj_is_weak_unit by auto
thus ?thesis using assms seq_if_composable 1 by auto
qed
lemma target_iso_trg:
assumes "arr \<mu>" and "b \<in> targets \<mu>"
shows "b \<cong> trg \<mu>"
proof -
have 0: "ide b"
using assms weak_unit_def by force
have 1: "trg \<mu> = src b"
using assms seq_if_composable by auto
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : b \<star> b \<Rightarrow> b\<guillemotright>"
using assms weak_unit_def by blast
have "trg b \<star> b \<cong> trg b \<star> trg b"
proof -
have "trg b \<cong> trg b \<star> trg b"
using 0 obj_is_weak_unit weak_unit_def isomorphic_symmetric by auto
moreover have "trg b \<star> b \<cong> trg b"
proof -
have "(trg b \<star> b) \<star> b \<cong> trg b \<star> b"
proof -
have "iso (trg b \<star> \<phi>) \<and> \<guillemotleft>trg b \<star> \<phi> : trg b \<star> b \<star> b \<Rightarrow> trg b \<star> b\<guillemotright>"
using assms 0 1 \<phi> ide_in_hom(2) targetsD(1) hseqI' by auto
moreover have "iso \<a>[trg b, b, b] \<and>
\<guillemotleft>\<a>[trg b, b, b] : (trg b \<star> b) \<star> b \<Rightarrow> trg b \<star> b \<star> b\<guillemotright>"
using assms(2) 0 1 seq_if_composable targetsD(1-2) by auto
ultimately show ?thesis
using isos_compose isomorphic_def by auto
qed
thus ?thesis
using assms 0 weak_unit_cancel_right by auto
qed
ultimately show ?thesis
using isomorphic_transitive by meson
qed
hence "b \<cong> trg b"
using 0 weak_unit_cancel_left [of "trg b" b "trg b"] obj_is_weak_unit by simp
thus ?thesis
using assms 0 1 seq_if_composable weak_unit_iff_self_source targetsD(1-2) source_iso_src
by simp
qed
lemma is_weak_composition_with_homs:
shows "weak_composition_with_homs V H src trg"
using src_in_sources trg_in_targets seq_if_composable composable_implies_arr
by (unfold_locales, simp_all)
interpretation weak_composition_with_homs V H src trg
using is_weak_composition_with_homs by auto
text \<open>
In a bicategory, the notion of composability defined in terms of
the chosen sources and targets coincides with the version defined
for a weak composition, which does not involve particular choices.
\<close>
lemma connected_iff_seq:
assumes "arr \<mu>" and "arr \<nu>"
shows "sources \<nu> \<inter> targets \<mu> \<noteq> {} \<longleftrightarrow> src \<nu> = trg \<mu>"
proof
show "src \<nu> = trg \<mu> \<Longrightarrow> sources \<nu> \<inter> targets \<mu> \<noteq> {}"
using assms src_in_sources [of \<nu>] trg_in_targets [of \<mu>] by auto
show "sources \<nu> \<inter> targets \<mu> \<noteq> {} \<Longrightarrow> src \<nu> = trg \<mu>"
proof -
assume 1: "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
obtain a where a: "a \<in> sources \<nu> \<inter> targets \<mu>"
using assms 1 by blast
have \<mu>: "arr \<mu>"
using a composable_implies_arr by auto
have \<nu>: "arr \<nu>"
using a composable_implies_arr by auto
have 1: "\<And>a'. a' \<in> sources \<nu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
proof
fix a'
assume a': "a' \<in> sources \<nu>"
have 1: "a' \<cong> a"
using a a' \<nu> src_dom sources_dom source_iso_src isomorphic_transitive
isomorphic_symmetric
by (meson IntD1)
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<phi> \<in> hom a' a"
using 1 by auto
show "src a' = src a"
using \<phi> src_dom src_cod by auto
show "trg a' = trg a"
using \<phi> trg_dom trg_cod by auto
qed
have 2: "\<And>a'. a' \<in> targets \<mu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
proof
fix a'
assume a': "a' \<in> targets \<mu>"
have 1: "a' \<cong> a"
using a a' \<mu> trg_dom targets_dom target_iso_trg isomorphic_transitive
isomorphic_symmetric
by (meson IntD2)
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<phi> \<in> hom a' a"
using 1 by auto
show "src a' = src a"
using \<phi> src_dom src_cod by auto
show "trg a' = trg a"
using \<phi> trg_dom trg_cod by auto
qed
have "src \<nu> = src (src \<nu>)" using \<nu> by simp
also have "... = src (trg \<mu>)"
using \<nu> 1 [of "src \<nu>"] src_in_sources a weak_unit_self_composable seq_if_composable
by auto
also have "... = trg (trg \<mu>)" using \<mu> by simp
also have "... = trg \<mu>" using \<mu> by simp
finally show "src \<nu> = trg \<mu>" by blast
qed
qed
lemma is_associative_weak_composition:
shows "associative_weak_composition V H \<a>"
proof -
have 1: "\<And>\<nu> \<mu>. \<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
using H.is_extensional VV.arr_char by force
show "associative_weak_composition V H \<a>"
proof
show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
using 1 by auto
show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
iso \<a>[f, g, h]"
using 1 iso_assoc by presburger
show "\<And>\<tau> \<mu> \<nu>. \<tau> \<star> \<mu> \<noteq> null \<Longrightarrow> \<mu> \<star> \<nu> \<noteq> null \<Longrightarrow>
\<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
using 1 assoc_naturality hseq_char hseq_char' by metis
show "\<And>f g h k. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> ide k \<Longrightarrow>
sources f \<inter> targets g \<noteq> {} \<Longrightarrow>
sources g \<inter> targets h \<noteq> {} \<Longrightarrow>
sources h \<inter> targets k \<noteq> {} \<Longrightarrow>
(f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) =
\<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
using 1 connected_iff_seq pentagon ideD(1) by auto
qed
qed
interpretation associative_weak_composition V H \<a>
using is_associative_weak_composition by auto
theorem is_prebicategory:
shows "prebicategory V H \<a>"
using src_in_sources trg_in_targets by (unfold_locales, auto)
interpretation prebicategory V H \<a>
using is_prebicategory by auto
corollary is_prebicategory_with_homs:
shows "prebicategory_with_homs V H \<a> src trg"
..
interpretation prebicategory_with_homs V H \<a> src trg
using is_prebicategory_with_homs by auto
text \<open>
In a bicategory, an arrow is a weak unit if and only if it is
isomorphic to its chosen source (or to its chosen target).
\<close>
lemma weak_unit_char:
shows "weak_unit a \<longleftrightarrow> a \<cong> src a"
and "weak_unit a \<longleftrightarrow> a \<cong> trg a"
proof -
show "weak_unit a \<longleftrightarrow> a \<cong> src a"
using isomorphism_respects_weak_units isomorphic_symmetric
by (meson ideD(1) isomorphic_implies_ide(2) obj_is_weak_unit obj_src source_iso_src
weak_unit_iff_self_source weak_unit_self_composable(1))
show "weak_unit a \<longleftrightarrow> a \<cong> trg a"
using isomorphism_respects_weak_units isomorphic_symmetric
by (metis \<open>weak_unit a = isomorphic a (src a)\<close> ideD(1) isomorphic_implies_hpar(3)
isomorphic_implies_ide(1) src_trg target_iso_trg weak_unit_iff_self_target)
qed
interpretation H: partial_magma H
using is_partial_magma by auto
text \<open>
Every arrow with respect to horizontal composition is also an arrow with respect
to vertical composition. The converse is not necessarily true.
\<close>
lemma harr_is_varr:
assumes "H.arr \<mu>"
shows "arr \<mu>"
proof -
have "H.domains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
proof -
assume 1: "H.domains \<mu> \<noteq> {}"
obtain a where a: "H.ide a \<and> \<mu> \<star> a \<noteq> null"
using 1 H.domains_def by auto
show "arr \<mu>"
using a hseq_char' H.ide_def by blast
qed
moreover have "H.codomains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
proof -
assume 1: "H.codomains \<mu> \<noteq> {}"
obtain a where a: "H.ide a \<and> a \<star> \<mu> \<noteq> null"
using 1 H.codomains_def by auto
show "arr \<mu>"
using a hseq_char' ide_def by blast
qed
ultimately show ?thesis using assms H.arr_def by auto
qed
text \<open>
An identity for horizontal composition is also an identity for vertical composition.
\<close>
lemma horizontal_identity_is_ide:
assumes "H.ide \<mu>"
shows "ide \<mu>"
proof -
have \<mu>: "arr \<mu>"
using assms H.ide_def composable_implies_arr(2) by auto
hence 1: "\<mu> \<star> dom \<mu> \<noteq> null"
using assms hom_connected H.ide_def by auto
have "\<mu> \<star> dom \<mu> = dom \<mu>"
using assms 1 H.ide_def by simp
moreover have "\<mu> \<star> dom \<mu> = \<mu>"
using assms 1 H.ide_def [of \<mu>] null_agreement
by (metis \<mu> cod_cod cod_dom hcomp_simps\<^sub>W\<^sub>C(3) ideD(2) ide_char' paste_1)
ultimately have "dom \<mu> = \<mu>"
by simp
thus ?thesis
using \<mu> by (metis ide_dom)
qed
text \<open>
Every identity for horizontal composition is a weak unit.
\<close>
lemma horizontal_identity_is_weak_unit:
assumes "H.ide \<mu>"
shows "weak_unit \<mu>"
using assms weak_unit_char
by (metis H.ide_def comp_target_ide horizontal_identity_is_ide ideD(1)
isomorphism_respects_weak_units null_agreement targetsD(2-3) trg_in_targets)
end
subsection "Vertically Discrete Bicategories are Categories"
text \<open>
In this section we show that if a bicategory is discrete with respect to vertical
composition, then it is a category with respect to horizontal composition.
To obtain this result, we need to establish that the set of arrows for the horizontal
composition coincides with the set of arrows for the vertical composition.
This is not true for a general bicategory, and even with the assumption that the
vertical category is discrete it is not immediately obvious from the definitions.
The issue is that the notion ``arrow'' for the horizontal composition is defined
in terms of the existence of ``domains'' and ``codomains'' with respect to that
composition, whereas the axioms for a bicategory only relate the notion ``arrow''
for the vertical category to the existence of sources and targets with respect
to the horizontal composition.
So we have to establish that, under the assumption of vertical discreteness,
sources coincide with domains and targets coincide with codomains.
We also need the fact that horizontal identities are weak units, which previously
required some effort to show.
\<close>
locale vertically_discrete_bicategory =
bicategory +
assumes vertically_discrete: "ide = arr"
begin
interpretation prebicategory_with_homs V H \<a> src trg
using is_prebicategory_with_homs by auto
interpretation H: partial_magma H
using is_partial_magma(1) by auto
lemma weak_unit_is_horizontal_identity:
assumes "weak_unit a"
shows "H.ide a"
proof -
have "a \<star> a \<noteq> H.null"
using assms by simp
moreover have "\<And>f. f \<star> a \<noteq> H.null \<Longrightarrow> f \<star> a = f"
proof -
fix f
assume "f \<star> a \<noteq> H.null"
hence "f \<star> a \<cong> f"
using assms comp_ide_source composable_implies_arr(2) sourcesI vertically_discrete
by auto
thus "f \<star> a = f"
using vertically_discrete isomorphic_def by auto
qed
moreover have "\<And>f. a \<star> f \<noteq> H.null \<Longrightarrow> a \<star> f = f"
proof -
fix f
assume "a \<star> f \<noteq> H.null"
hence "a \<star> f \<cong> f"
using assms comp_target_ide composable_implies_arr(1) targetsI vertically_discrete
by auto
thus "a \<star> f = f"
using vertically_discrete isomorphic_def by auto
qed
ultimately show "H.ide a"
using H.ide_def by simp
qed
lemma sources_eq_domains:
shows "sources \<mu> = H.domains \<mu>"
using weak_unit_is_horizontal_identity H.domains_def sources_def
horizontal_identity_is_weak_unit
by auto
lemma targets_eq_codomains:
shows "targets \<mu> = H.codomains \<mu>"
using weak_unit_is_horizontal_identity H.codomains_def targets_def
horizontal_identity_is_weak_unit
by auto
lemma arr_agreement:
shows "arr = H.arr"
using arr_def H.arr_def arr_iff_has_src arr_iff_has_trg
sources_eq_domains targets_eq_codomains
by auto
interpretation H: category H
proof
show "\<And>g f. g \<star> f \<noteq> H.null \<Longrightarrow> H.seq g f"
using arr_agreement hcomp_simps\<^sub>W\<^sub>C(1) by auto
show "\<And>f. (H.domains f \<noteq> {}) = (H.codomains f \<noteq> {})"
using sources_eq_domains targets_eq_codomains arr_iff_has_src arr_iff_has_trg
by simp
fix f g h
show "H.seq h g \<Longrightarrow> H.seq (h \<star> g) f \<Longrightarrow> H.seq g f"
using null_agreement arr_agreement H.not_arr_null preserves_arr VoV.arr_char
by (metis hseq_char' match_1)
show "H.seq h (g \<star> f) \<Longrightarrow> H.seq g f \<Longrightarrow> H.seq h g"
using null_agreement arr_agreement H.not_arr_null preserves_arr VoV.arr_char
by (metis hseq_char' match_2)
show "H.seq g f \<Longrightarrow> H.seq h g \<Longrightarrow> H.seq (h \<star> g) f"
using arr_agreement match_3 hseq_char(1) by auto
show "H.seq g f \<Longrightarrow> H.seq h g \<Longrightarrow> (h \<star> g) \<star> f = h \<star> g \<star> f"
proof -
assume hg: "H.seq h g"
assume gf: "H.seq g f"
have "iso \<a>[h, g, f] \<and> \<guillemotleft>\<a>[h, g, f] : (h \<star> g) \<star> f \<Rightarrow> h \<star> g \<star> f\<guillemotright>"
using hg gf vertically_discrete arr_agreement hseq_char assoc_in_hom iso_assoc
by auto
thus ?thesis
using arr_agreement vertically_discrete by auto
qed
qed
proposition is_category:
shows "category H"
..
end
subsection "Obtaining the Unitors"
text \<open>
We now want to exploit the construction of unitors in a prebicategory with units,
to obtain left and right unitors in a bicategory. However, a bicategory is not
\emph{a priori} a prebicategory with units, because a bicategory only assigns unit
isomorphisms to each \emph{object}, not to each weak unit. In order to apply the results
about prebicategories with units to a bicategory, we first need to extend the bicategory to
a prebicategory with units, by extending the mapping \<open>\<iota>\<close>, which provides a unit isomorphism
for each object, to a mapping that assigns a unit isomorphism to all weak units.
This extension can be made in an arbitrary way, as the values chosen for
non-objects ultimately do not affect the components of the unitors at objects.
\<close>
context bicategory
begin
interpretation prebicategory V H \<a>
using is_prebicategory by auto
definition \<i>'
where "\<i>' a \<equiv> SOME \<phi>. iso \<phi> \<and> \<phi> \<in> hom (a \<star> a) a \<and> (obj a \<longrightarrow> \<phi> = \<i>[a])"
lemma \<i>'_extends_\<i>:
assumes "weak_unit a"
shows "iso (\<i>' a)" and "\<guillemotleft>\<i>' a : a \<star> a \<Rightarrow> a\<guillemotright>" and "obj a \<Longrightarrow> \<i>' a = \<i>[a]"
proof -
let ?P = "\<lambda>a \<phi>. iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright> \<and> (obj a \<longrightarrow> \<phi> = \<i>[a])"
have "\<exists>\<phi>. ?P a \<phi>"
using assms unit_in_hom iso_unit weak_unit_def isomorphic_def by blast
hence 1: "?P a (\<i>' a)"
using \<i>'_def someI_ex [of "?P a"] by simp
show "iso (\<i>' a)" using 1 by simp
show "\<guillemotleft>\<i>' a : a \<star> a \<Rightarrow> a\<guillemotright>" using 1 by simp
show "obj a \<Longrightarrow> \<i>' a = \<i>[a]" using 1 by simp
qed
proposition extends_to_prebicategory_with_units:
shows "prebicategory_with_units V H \<a> \<i>'"
using \<i>'_extends_\<i> by unfold_locales auto
interpretation PB: prebicategory_with_units V H \<a> \<i>'
using extends_to_prebicategory_with_units by auto
interpretation PB: prebicategory_with_homs V H \<a> src trg
using is_prebicategory_with_homs by auto
interpretation PB: prebicategory_with_homs_and_units V H \<a> \<i>' src trg ..
proposition extends_to_prebicategory_with_homs_and_units:
shows "prebicategory_with_homs_and_units V H \<a> \<i>' src trg"
..
definition lunit ("\<l>[_]")
where "\<l>[a] \<equiv> PB.lunit a"
definition runit ("\<r>[_]")
where "\<r>[a] \<equiv> PB.runit a"
abbreviation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
where "\<l>\<^sup>-\<^sup>1[a] \<equiv> inv \<l>[a]"
abbreviation runit' ("\<r>\<^sup>-\<^sup>1[_]")
where "\<r>\<^sup>-\<^sup>1[a] \<equiv> inv \<r>[a]"
text \<open>
\sloppypar
The characterizations of the left and right unitors that we obtain from locale
@{locale prebicategory_with_homs_and_units} mention the arbitarily chosen extension \<open>\<i>'\<close>,
rather than the given \<open>\<i>\<close>. We want ``native versions'' for the present context.
\<close>
lemma lunit_char:
assumes "ide f"
shows "\<guillemotleft>\<l>[f] : L f \<Rightarrow> f\<guillemotright>" and "L \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
proof -
have 1: "trg (PB.lunit f) = trg f"
using assms PB.lunit_char [of f] vconn_implies_hpar(2) vconn_implies_hpar(4)
by metis
show "\<guillemotleft>\<l>[f] : L f \<Rightarrow> f\<guillemotright>"
unfolding lunit_def
using assms PB.lunit_char by simp
show "L \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
unfolding lunit_def
using assms 1 PB.lunit_char obj_is_weak_unit \<i>'_extends_\<i> by simp
let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
have "?P = (\<lambda>\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and>
trg f \<star> \<mu> = (\<i>' (trg f) \<star> f) \<cdot> inv \<a>[trg f, trg f, f])"
proof -
have "\<And>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<longleftrightarrow> \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
using assms by simp
moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<Longrightarrow>
L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f] \<longleftrightarrow>
trg f \<star> \<mu> = (\<i>' (trg f) \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
using calculation obj_is_weak_unit \<i>'_extends_\<i> by auto
ultimately show ?thesis by blast
qed
thus "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
using assms PB.lunit_char by simp
qed
lemma lunit_in_hom [intro]:
assumes "ide f"
shows "\<guillemotleft>\<l>[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
proof -
show "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
using assms lunit_char by auto
thus "\<guillemotleft>\<l>[f] : src f \<rightarrow> trg f\<guillemotright>"
using src_cod trg_cod by fastforce
qed
lemma lunit_in_vhom [simp]:
assumes "ide f" and "trg f = b"
shows "\<guillemotleft>\<l>[f] : b \<star> f \<Rightarrow> f\<guillemotright>"
using assms by auto
lemma lunit_simps [simp]:
assumes "ide f"
shows "arr \<l>[f]" and "src \<l>[f] = src f" and "trg \<l>[f] = trg f"
and "dom \<l>[f] = trg f \<star> f" and "cod \<l>[f] = f"
using assms lunit_in_hom
apply auto
using assms lunit_in_hom
apply blast
using assms lunit_in_hom
by blast
lemma runit_char:
assumes "ide f"
shows "\<guillemotleft>\<r>[f] : R f \<Rightarrow> f\<guillemotright>" and "R \<r>[f] = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
proof -
have 1: "src (PB.runit f) = src f"
using assms PB.runit_char [of f] vconn_implies_hpar(1) vconn_implies_hpar(3)
by metis
show "\<guillemotleft>\<r>[f] : R f \<Rightarrow> f\<guillemotright>"
unfolding runit_def
using assms PB.runit_char by simp
show "R \<r>[f] = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
unfolding runit_def
using assms 1 PB.runit_char obj_is_weak_unit \<i>'_extends_\<i> by simp
let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
have "?P = (\<lambda>\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and>
\<mu> \<star> src f = (f \<star> \<i>' (src f)) \<cdot> \<a>[f, src f, src f])"
proof -
have "\<And>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<longleftrightarrow> \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
using assms by simp
moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<Longrightarrow>
R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f] \<longleftrightarrow>
\<mu> \<star> src f = (f \<star> \<i>' (src f)) \<cdot> \<a>[f, src f, src f]"
using calculation obj_is_weak_unit \<i>'_extends_\<i> by auto
ultimately show ?thesis by blast
qed
thus "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
using assms PB.runit_char by simp
qed
lemma runit_in_hom [intro]:
assumes "ide f"
shows "\<guillemotleft>\<r>[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
proof -
show "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
using assms runit_char by auto
thus "\<guillemotleft>\<r>[f] : src f \<rightarrow> trg f\<guillemotright>"
using src_cod trg_cod by fastforce
qed
lemma runit_in_vhom [simp]:
assumes "ide f" and "src f = a"
shows "\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>"
using assms by auto
lemma runit_simps [simp]:
assumes "ide f"
shows "arr \<r>[f]" and "src \<r>[f] = src f" and "trg \<r>[f] = trg f"
and "dom \<r>[f] = f \<star> src f" and "cod \<r>[f] = f"
using assms runit_in_hom
apply auto
using assms runit_in_hom
apply blast
using assms runit_in_hom
by blast
lemma lunit_eqI:
assumes "ide f" and "\<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
and "trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
shows "\<mu> = \<l>[f]"
unfolding lunit_def
using assms PB.lunit_eqI \<i>'_extends_\<i> trg.preserves_ide obj_is_weak_unit by simp
lemma runit_eqI:
assumes "ide f" and "\<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
and "\<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
shows "\<mu> = \<r>[f]"
unfolding runit_def
using assms PB.runit_eqI \<i>'_extends_\<i> src.preserves_ide obj_is_weak_unit by simp
lemma lunit_naturality:
assumes "arr \<mu>"
shows "\<mu> \<cdot> \<l>[dom \<mu>] = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
unfolding lunit_def
using assms PB.lunit_naturality by auto
lemma runit_naturality:
assumes "arr \<mu>"
shows "\<mu> \<cdot> \<r>[dom \<mu>] = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> src \<mu>)"
unfolding runit_def
using assms PB.runit_naturality by auto
lemma iso_lunit [simp]:
assumes "ide f"
shows "iso \<l>[f]"
unfolding lunit_def
using assms PB.iso_lunit by blast
lemma iso_runit [simp]:
assumes "ide f"
shows "iso \<r>[f]"
unfolding runit_def
using assms PB.iso_runit by blast
lemma iso_lunit' [simp]:
assumes "ide f"
shows "iso \<l>\<^sup>-\<^sup>1[f]"
using assms iso_lunit iso_inv_iso by blast
lemma iso_runit' [simp]:
assumes "ide f"
shows "iso \<r>\<^sup>-\<^sup>1[f]"
using assms iso_runit iso_inv_iso by blast
lemma lunit'_in_hom [intro]:
assumes "ide f"
shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> trg f \<star> f\<guillemotright>"
proof -
show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> trg f \<star> f\<guillemotright>"
using assms lunit_char iso_lunit by simp
thus "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>"
using assms src_dom trg_dom by simp
qed
lemma lunit'_in_vhom [simp]:
assumes "ide f" and "trg f = b"
shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> b \<star> f\<guillemotright>"
using assms by auto
lemma lunit'_simps [simp]:
assumes "ide f"
shows "arr \<l>\<^sup>-\<^sup>1[f]" and "src \<l>\<^sup>-\<^sup>1[f] = src f" and "trg \<l>\<^sup>-\<^sup>1[f] = trg f"
and "dom \<l>\<^sup>-\<^sup>1[f] = f" and "cod \<l>\<^sup>-\<^sup>1[f] = trg f \<star> f"
using assms lunit'_in_hom by auto
lemma runit'_in_hom [intro]:
assumes "ide f"
shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> src f\<guillemotright>"
proof -
show "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> src f\<guillemotright>"
using assms runit_char iso_runit by simp
thus "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>"
using src_dom trg_dom
by (simp add: assms)
qed
lemma runit'_in_vhom [simp]:
assumes "ide f" and "src f = a"
shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> a\<guillemotright>"
using assms by auto
lemma runit'_simps [simp]:
assumes "ide f"
shows "arr \<r>\<^sup>-\<^sup>1[f]" and "src \<r>\<^sup>-\<^sup>1[f] = src f" and "trg \<r>\<^sup>-\<^sup>1[f] = trg f"
and "dom \<r>\<^sup>-\<^sup>1[f] = f" and "cod \<r>\<^sup>-\<^sup>1[f] = f \<star> src f"
using assms runit'_in_hom by auto
interpretation L: endofunctor V L ..
interpretation \<ll>: transformation_by_components V V L map lunit
using lunit_in_hom lunit_naturality by unfold_locales auto
interpretation \<ll>: natural_isomorphism V V L map \<ll>.map
using iso_lunit by (unfold_locales, auto)
lemma natural_isomorphism_\<ll>:
shows "natural_isomorphism V V L map \<ll>.map"
..
abbreviation \<ll>
where "\<ll> \<equiv> \<ll>.map"
lemma \<ll>_ide_simp:
assumes "ide f"
shows "\<ll> f = \<l>[f]"
using assms by simp
interpretation L: equivalence_functor V V L
using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
lemma equivalence_functor_L:
shows "equivalence_functor V V L"
..
lemma lunit_commutes_with_L:
assumes "ide f"
shows "\<l>[L f] = L \<l>[f]"
unfolding lunit_def
using assms PB.lunit_commutes_with_L by blast
interpretation R: endofunctor V R ..
interpretation \<rr>: transformation_by_components V V R map runit
using runit_in_hom runit_naturality by unfold_locales auto
interpretation \<rr>: natural_isomorphism V V R map \<rr>.map
using iso_runit by (unfold_locales, auto)
lemma natural_isomorphism_\<rr>:
shows "natural_isomorphism V V R map \<rr>.map"
..
abbreviation \<rr>
where "\<rr> \<equiv> \<rr>.map"
lemma \<rr>_ide_simp:
assumes "ide f"
shows "\<rr> f = \<r>[f]"
using assms by simp
interpretation R: equivalence_functor V V R
using R.isomorphic_to_identity_is_equivalence \<rr>.natural_isomorphism_axioms by simp
lemma equivalence_functor_R:
shows "equivalence_functor V V R"
..
lemma runit_commutes_with_R:
assumes "ide f"
shows "\<r>[R f] = R \<r>[f]"
unfolding runit_def
using assms PB.runit_commutes_with_R by blast
lemma lunit'_naturality:
assumes "arr \<mu>"
shows "(trg \<mu> \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
using assms iso_lunit lunit_naturality invert_opposite_sides_of_square L.preserves_arr
L.preserves_cod arr_cod ide_cod ide_dom lunit_simps(1) lunit_simps(4) seqI
by presburger
lemma runit'_naturality:
assumes "arr \<mu>"
shows "(\<mu> \<star> src \<mu>) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
using assms iso_runit runit_naturality invert_opposite_sides_of_square R.preserves_arr
R.preserves_cod arr_cod ide_cod ide_dom runit_simps(1) runit_simps(4) seqI
by presburger
end
subsection "Further Properties of Bicategories"
text \<open>
Here we derive further properties of bicategories, now that we
have the unitors at our disposal. This section generalizes the corresponding
development in theory @{theory MonoidalCategory.MonoidalCategory},
which has some diagrams to illustrate the longer calculations.
The present section also includes some additional facts that are now nontrivial
due to the partiality of horizontal composition.
\<close>
context bicategory
begin
lemma unit_simps [simp]:
assumes "obj a"
shows "arr \<i>[a]" and "src \<i>[a] = a" and "trg \<i>[a] = a"
and "dom \<i>[a] = a \<star> a" and "cod \<i>[a] = a"
using assms unit_in_hom by blast+
lemma triangle:
assumes "ide f" and "ide g" and "src g = trg f"
shows "(g \<star> \<l>[f]) \<cdot> \<a>[g, src g, f] = \<r>[g] \<star> f"
proof -
let ?b = "src g"
have *: "(g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] = \<r>[g] \<star> ?b \<star> f"
proof -
have 1: "((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> \<a>[g \<star> ?b, ?b, f]
= (\<r>[g] \<star> ?b \<star> f) \<cdot> \<a>[g \<star> ?b, ?b, f]"
proof -
have "((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> \<a>[g \<star> ?b, ?b, f]
= (g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> \<a>[g \<star> ?b, ?b, f]"
using HoVH_def HoHV_def comp_assoc by auto
also have
"... = (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> \<a>[?b, ?b, f]) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms pentagon by force
also have
"... = ((g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> \<a>[?b, ?b, f])) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms assoc_in_hom HoVH_def HoHV_def comp_assoc by auto
also have
"... = ((g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> \<a>[?b, ?b, f])) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms lunit_commutes_with_L lunit_in_hom by force
also have "... = ((g \<star> (\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]) \<cdot> (g \<star> \<a>[?b, ?b, f]))
\<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms lunit_char(2) by force
also have "... = (g \<star> ((\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]) \<cdot> \<a>[?b, ?b, f])
\<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms interchange [of g g "(\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]" "\<a>[?b, ?b, f]"] hseqI'
by auto
also have "... = ((g \<star> \<i>[?b] \<star> f) \<cdot> \<a>[g, ?b \<star> ?b, f]) \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms comp_arr_dom comp_assoc_assoc' hseqI' comp_assoc by auto
also have "... = (\<a>[g, ?b, f] \<cdot> ((g \<star> \<i>[?b]) \<star> f)) \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
using assms assoc_naturality [of g "\<i>[?b]" f] by simp
also have "... = \<a>[g, ?b, f] \<cdot> ((g \<star> \<i>[?b]) \<cdot> \<a>[g, ?b, ?b] \<star> f)"
using assms interchange [of "g \<star> \<i>[?b]" "\<a>[g, ?b, ?b]" f f] comp_assoc hseqI' by simp
also have "... = \<a>[g, ?b, f] \<cdot> ((\<r>[g] \<star> ?b) \<star> f)"
using assms runit_char(2) by force
also have "... = (\<r>[g] \<star> ?b \<star> f) \<cdot> \<a>[g \<star> ?b, ?b, f]"
using assms assoc_naturality [of "\<r>[g]" ?b f] by auto
finally show ?thesis by blast
qed
show "(g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] = \<r>[g] \<star> ?b \<star> f"
proof -
have "epi \<a>[g \<star> ?b, ?b, f]"
using assms preserves_ide iso_assoc iso_is_retraction retraction_is_epi by force
thus ?thesis
using assms 1 hseqI' by auto
qed
qed
have "(g \<star> \<l>[f]) \<cdot> \<a>[g, ?b, f] = ((g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot>
(g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
proof -
have "\<a>[g, ?b, f] = (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
proof -
have "\<a>[g, ?b, f] = (g \<star> ?b \<star> f) \<cdot> \<a>[g, ?b, f]"
using assms comp_cod_arr hseqI' by simp
have "\<a>[g, ?b, f] = ((g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot> \<a>[g, ?b, f]"
using assms comp_cod_arr comp_arr_inv' whisker_left [of g]
whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] hseqI'
by simp
also have "... = (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
using assms iso_lunit assoc_naturality [of g ?b "\<l>\<^sup>-\<^sup>1[f]"] comp_assoc by force
finally show ?thesis by blast
qed
moreover have "g \<star> \<l>[f] = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])"
proof -
have "(g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) = g \<star> ?b \<star> f"
proof -
have "(g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) = (g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])"
using assms lunit_in_hom lunit_commutes_with_L by simp
also have "... = g \<star> ?b \<star> f"
using assms comp_arr_inv' whisker_left [of g] whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"]
hseqI'
by simp
finally show ?thesis by blast
qed
thus ?thesis
using assms comp_arr_dom hseqI' by auto
qed
ultimately show ?thesis by simp
qed
also have "... = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> ((g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) \<cdot> (g \<star> ?b \<star> \<l>[f])) \<cdot>
\<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
using comp_assoc by simp
also have "... = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> ((g \<star> ?b \<star> (?b \<star> f)) \<cdot>
\<a>[g, ?b, ?b \<star> f]) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
using assms iso_lunit comp_inv_arr' interchange [of g g "?b \<star> \<l>\<^sup>-\<^sup>1[f]" "?b \<star> \<l>[f]"]
interchange [of ?b ?b "\<l>\<^sup>-\<^sup>1[f]" "\<l>[f]"] hseqI' comp_assoc
by auto
also have "... = (g \<star> \<l>[f]) \<cdot> ((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
using assms comp_cod_arr comp_assoc by auto
also have "... = \<r>[g] \<star> f"
proof -
have "\<r>[g] \<star> f = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> ?b \<star> f) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
proof -
have "(g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> ?b \<star> f) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])
= (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<cdot> (g \<star> ?b) \<star> (?b \<star> f) \<cdot> \<l>\<^sup>-\<^sup>1[f])"
using assms iso_lunit interchange [of "\<r>[g]" "g \<star> ?b" "?b \<star> f" "\<l>\<^sup>-\<^sup>1[f]"]
by force
also have "... = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> \<l>\<^sup>-\<^sup>1[f])"
using assms comp_arr_dom comp_cod_arr by simp
also have "... = \<r>[g] \<star> \<l>[f] \<cdot> \<l>\<^sup>-\<^sup>1[f]"
using assms interchange [of g "\<r>[g]" "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] comp_cod_arr
by simp
also have "... = \<r>[g] \<star> f"
using assms iso_lunit comp_arr_inv' by simp
finally show ?thesis by argo
qed
thus ?thesis using assms * by argo
qed
finally show ?thesis by blast
qed
lemma lunit_hcomp_gen:
assumes "ide f" and "ide g" and "ide h"
and "src f = trg g" and "src g = trg h"
shows "(f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h]) = f \<star> \<l>[g] \<star> h"
proof -
have "((f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])) \<cdot> \<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h) =
(f \<star> (\<l>[g] \<star> h)) \<cdot> \<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)"
proof -
have "((f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])) \<cdot> (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)) =
((f \<star> \<l>[g \<star> h]) \<cdot> \<a>[f, trg g, g \<star> h]) \<cdot> \<a>[f \<star> trg g, g, h]"
using assms pentagon comp_assoc by simp
also have "... = (\<r>[f] \<star> (g \<star> h)) \<cdot> \<a>[f \<star> trg g, g, h]"
using assms triangle [of "g \<star> h" f] by auto
also have "... = \<a>[f, g, h] \<cdot> ((\<r>[f] \<star> g) \<star> h)"
using assms assoc_naturality [of "\<r>[f]" g h] by simp
also have "... = (\<a>[f, g, h] \<cdot> ((f \<star> \<l>[g]) \<star> h)) \<cdot> (\<a>[f, trg g, g] \<star> h)"
using assms triangle interchange [of "f \<star> \<l>[g]" "\<a>[f, trg g, g]" h h] comp_assoc hseqI'
by auto
also have "... = (f \<star> (\<l>[g] \<star> h)) \<cdot> (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h))"
using assms assoc_naturality [of f "\<l>[g]" h] comp_assoc by simp
finally show ?thesis by blast
qed
moreover have "iso (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h))"
using assms iso_assoc isos_compose hseqI' by simp
ultimately show ?thesis
using assms iso_is_retraction retraction_is_epi hseqI'
epiE [of "\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)"
"(f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])" "f \<star> \<l>[g] \<star> h"]
by auto
qed
lemma lunit_hcomp:
assumes "ide f" and "ide g" and "src f = trg g"
shows "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g] = \<l>[f] \<star> g"
and "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = \<l>\<^sup>-\<^sup>1[f] \<star> g"
and "\<l>[f \<star> g] = (\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g]"
and "\<l>\<^sup>-\<^sup>1[f \<star> g] = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
proof -
show 1: "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g] = \<l>[f] \<star> g"
proof -
have "L (\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]) = L (\<l>[f] \<star> g)"
using assms interchange [of "trg f" "trg f" "\<l>[f \<star> g]" "\<a>[trg f, f, g]"] lunit_hcomp_gen
by fastforce
thus ?thesis
using assms L.is_faithful [of "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]" "\<l>[f] \<star> g"] hseqI' by force
qed
show "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = \<l>\<^sup>-\<^sup>1[f] \<star> g"
proof -
have "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = inv (\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g])"
using assms by (simp add: inv_comp)
also have "... = inv (\<l>[f] \<star> g)"
using 1 by simp
also have "... = \<l>\<^sup>-\<^sup>1[f] \<star> g"
using assms by simp
finally show ?thesis by simp
qed
show 2: "\<l>[f \<star> g] = (\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g]"
using assms 1 invert_side_of_triangle(2) [of "\<l>[f] \<star> g" "\<l>[f \<star> g]" "\<a>[trg f, f, g]"]
hseqI'
by auto
show "\<l>\<^sup>-\<^sup>1[f \<star> g] = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
proof -
have "\<l>\<^sup>-\<^sup>1[f \<star> g] = inv ((\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g])"
using 2 by simp
also have "... = \<a>[trg f, f, g] \<cdot> inv (\<l>[f] \<star> g)"
using assms inv_comp iso_inv_iso
by (simp add: hseqI')
also have "... = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
using assms by simp
finally show ?thesis by simp
qed
qed
lemma runit_hcomp_gen:
assumes "ide f" and "ide g" and "ide h"
and "src f = trg g" and "src g = trg h"
shows "\<r>[f \<star> g] \<star> h = ((f \<star> \<r>[g]) \<star> h) \<cdot> (\<a>[f, g, src g] \<star> h)"
proof -
have "\<r>[f \<star> g] \<star> h = ((f \<star> g) \<star> \<l>[h]) \<cdot> \<a>[f \<star> g, src g, h]"
using assms triangle by simp
also have "... = (\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> g \<star> \<l>[h]) \<cdot> \<a>[f, g, src g \<star> h]) \<cdot> \<a>[f \<star> g, src g, h]"
using assms assoc_naturality [of f g "\<l>[h]"] invert_side_of_triangle(1) hseqI'
by simp
also have "... = \<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> g \<star> \<l>[h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
using comp_assoc by simp
also have "... = (\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> (\<r>[g] \<star> h))) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot>
\<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
using assms interchange [of f f] triangle comp_assoc hseqI'
invert_side_of_triangle(2) [of "\<r>[g] \<star> h" "g \<star> \<l>[h]" "\<a>[g, src g, h]"]
by simp
also have "... = ((f \<star> \<r>[g]) \<star> h) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> src g, h] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot>
\<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
using assms assoc'_naturality [of f "\<r>[g]" h] comp_assoc by simp
also have "... = ((f \<star> \<r>[g]) \<star> h) \<cdot> (\<a>[f, g, src g] \<star> h)"
- using assms pentagon [of f g "src g" h] iso_assoc inv_hcomp
- invert_side_of_triangle(1)
- [of "\<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]" "f \<star> \<a>[g, src g, h]"
- "\<a>[f, g \<star> src g, h] \<cdot> (\<a>[f, g, src g] \<star> h)"]
- invert_side_of_triangle(1)
- [of "(f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
- "\<a>[f, g \<star> src g, h]" "\<a>[f, g, src g] \<star> h"]
+ using assms pentagon [of f g "src g" h] iso_assoc inv_hcomp
+ invert_side_of_triangle(1)
+ [of "\<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]" "f \<star> \<a>[g, src g, h]"
+ "\<a>[f, g \<star> src g, h] \<cdot> (\<a>[f, g, src g] \<star> h)"]
+ invert_side_of_triangle(1)
+ [of "(f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
+ "\<a>[f, g \<star> src g, h]" "\<a>[f, g, src g] \<star> h"]
by auto
finally show ?thesis by blast
qed
lemma runit_hcomp:
assumes "ide f" and "ide g" and "src f = trg g"
shows "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
and "\<r>\<^sup>-\<^sup>1[f \<star> g] = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
and "\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g] = f \<star> \<r>[g]"
and "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = f \<star> \<r>\<^sup>-\<^sup>1[g]"
proof -
show 1: "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
using assms interchange [of "f \<star> \<r>[g]" "\<a>[f, g, src g]" "src g" "src g"] hseqI'
runit_hcomp_gen [of f g "src g"]
R.is_faithful [of "(f \<star> \<r>[g]) \<cdot> (\<a>[f, g, src g])" "\<r>[f \<star> g]"]
by simp
show "\<r>\<^sup>-\<^sup>1[f \<star> g] = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
proof -
have "\<r>\<^sup>-\<^sup>1[f \<star> g] = inv ((f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g])"
using 1 by simp
also have "... = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
proof -
have "src f = trg \<r>[g]"
using assms by simp
thus ?thesis
using assms 1 inv_comp inv_hcomp hseqI' by simp
qed
finally show ?thesis
using assms by simp
qed
show 2: "\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g] = f \<star> \<r>[g]"
proof -
have "f \<star> \<r>[g] = ((f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g]"
using assms comp_arr_dom comp_cod_arr comp_assoc hseqI' comp_assoc_assoc' by simp
also have "... = \<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g]"
using assms 1 by auto
finally show ?thesis by auto
qed
show "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = f \<star> \<r>\<^sup>-\<^sup>1[g]"
proof -
have "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = inv (\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g])"
using assms inv_comp iso_inv_iso hseqI' by simp
also have "... = inv (f \<star> \<r>[g])"
using 2 by simp
also have "... = f \<star> \<r>\<^sup>-\<^sup>1[g]"
using assms inv_hcomp [of f "\<r>[g]"] by simp
finally show ?thesis by simp
qed
qed
lemma unitor_coincidence:
assumes "obj a"
shows "\<l>[a] = \<i>[a]" and "\<r>[a] = \<i>[a]"
proof -
have "R \<l>[a] = R \<i>[a] \<and> R \<r>[a] = R \<i>[a]"
proof -
have "R \<l>[a] = (a \<star> \<l>[a]) \<cdot> \<a>[a, a, a]"
using assms lunit_hcomp [of a a] lunit_commutes_with_L [of a] by auto
moreover have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = R \<r>[a]"
using assms triangle [of a a] by auto
moreover have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = R \<i>[a]"
proof -
have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = ((\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a]) \<cdot> \<a>[a, a, a]"
using assms lunit_char(2) by force
also have "... = R \<i>[a]"
using assms comp_arr_dom comp_assoc hseqI' comp_assoc_assoc'
apply (elim objE)
by (simp add: assms)
finally show ?thesis by blast
qed
ultimately show ?thesis by argo
qed
moreover have "par \<l>[a] \<i>[a] \<and> par \<r>[a] \<i>[a]"
using assms by auto
ultimately have 1: "\<l>[a] = \<i>[a] \<and> \<r>[a] = \<i>[a]"
using R.is_faithful by blast
show "\<l>[a] = \<i>[a]" using 1 by auto
show "\<r>[a] = \<i>[a]" using 1 by auto
qed
lemma unit_triangle:
assumes "obj a"
shows "\<i>[a] \<star> a = (a \<star> \<i>[a]) \<cdot> \<a>[a, a, a]"
and "(\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] = a \<star> \<i>[a]"
proof -
show 1: "\<i>[a] \<star> a = (a \<star> \<i>[a]) \<cdot> \<a>[a, a, a]"
using assms triangle [of a a] unitor_coincidence by auto
show "(\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] = a \<star> \<i>[a]"
using assms 1 invert_side_of_triangle(2) [of "\<i>[a] \<star> a" "a \<star> \<i>[a]" "\<a>[a, a, a]"]
assoc'_eq_inv_assoc
by (metis hseqI' iso_assoc objE obj_def' unit_simps(1) unit_simps(2))
qed
lemma hcomp_arr_obj:
assumes "arr \<mu>" and "obj a" and "src \<mu> = a"
shows "\<mu> \<star> a = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<r>[dom \<mu>]"
and "\<r>[cod \<mu>] \<cdot> (\<mu> \<star> a) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
proof -
show "\<mu> \<star> a = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<r>[dom \<mu>]"
using assms iso_runit runit_naturality comp_cod_arr
by (metis ide_cod ide_dom invert_side_of_triangle(1) runit_simps(1) runit_simps(5) seqI)
show "\<r>[cod \<mu>] \<cdot> (\<mu> \<star> a) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
using assms iso_runit runit_naturality [of \<mu>] comp_cod_arr
by (metis ide_dom invert_side_of_triangle(2) comp_assoc runit_simps(1)
runit_simps(5) seqI)
qed
lemma hcomp_obj_arr:
assumes "arr \<mu>" and "obj b" and "b = trg \<mu>"
shows "b \<star> \<mu> = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<l>[dom \<mu>]"
and "\<l>[cod \<mu>] \<cdot> (b \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
proof -
show "b \<star> \<mu> = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<l>[dom \<mu>]"
using assms iso_lunit lunit_naturality comp_cod_arr
by (metis ide_cod ide_dom invert_side_of_triangle(1) lunit_simps(1) lunit_simps(5) seqI)
show "\<l>[cod \<mu>] \<cdot> (b \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
using assms iso_lunit lunit_naturality [of \<mu>] comp_cod_arr
by (metis ide_dom invert_side_of_triangle(2) comp_assoc lunit_simps(1)
lunit_simps(5) seqI)
qed
lemma hcomp_reassoc:
assumes "arr \<tau>" and "arr \<mu>" and "arr \<nu>"
and "src \<tau> = trg \<mu>" and "src \<mu> = trg \<nu>"
shows "(\<tau> \<star> \<mu>) \<star> \<nu> = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
and "\<tau> \<star> \<mu> \<star> \<nu> = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
proof -
show "(\<tau> \<star> \<mu>) \<star> \<nu> = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
proof -
have "(\<tau> \<star> \<mu>) \<star> \<nu> = (\<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>]) \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
using assms comp_assoc_assoc'(2) comp_cod_arr hseqI' by simp
also have "... = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
using comp_assoc by simp
also have "... = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
using assms assoc_naturality by simp
finally show ?thesis by simp
qed
show "\<tau> \<star> \<mu> \<star> \<nu> = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
proof -
have "\<tau> \<star> \<mu> \<star> \<nu> = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>] \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
using assms comp_assoc_assoc'(1) comp_arr_dom hseqI' by simp
also have "... = ((\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
using comp_assoc by simp
also have "... = (\<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
using assms assoc_naturality by simp
also have "... = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
using comp_assoc by simp
finally show ?thesis by simp
qed
qed
lemma triangle':
assumes "ide f" and "ide g" and "src f = trg g"
shows "(f \<star> \<l>[g]) = (\<r>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g]"
proof -
have "(\<r>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g] = ((f \<star> \<l>[g]) \<cdot> \<a>[f, src f, g]) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g]"
using assms triangle by auto
also have "... = (f \<star> \<l>[g])"
using assms comp_arr_dom comp_assoc hseqI' comp_assoc_assoc' by auto
finally show ?thesis by auto
qed
lemma pentagon':
assumes "ide f" and "ide g" and "ide h" and "ide k"
and "src f = trg g" and "src g = trg h" and "src h = trg k"
shows "((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])
= \<a>\<^sup>-\<^sup>1[f \<star> g, h, k] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h \<star> k]"
proof -
have "((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])
= inv ((f \<star> \<a>[g, h, k]) \<cdot> (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)))"
proof -
have "inv ((f \<star> \<a>[g, h, k]) \<cdot> (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))) =
inv (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)) \<cdot> inv (f \<star> \<a>[g, h, k])"
proof -
have "iso (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))"
using assms isos_compose hseqI' by simp
moreover have "iso (f \<star> \<a>[g, h, k])"
using assms by simp
moreover have "seq (f \<star> \<a>[g, h, k]) (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))"
using assms hseqI' by simp
ultimately show ?thesis
using inv_comp [of "\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)" "f \<star> \<a>[g, h, k]"]
by simp
qed
also have "... = (inv (\<a>[f, g, h] \<star> k) \<cdot> inv \<a>[f, g \<star> h, k]) \<cdot> inv (f \<star> \<a>[g, h, k])"
using assms iso_assoc inv_comp hseqI' by simp
also have "... = ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])"
using assms inv_hcomp by simp
finally show ?thesis by simp
qed
also have "... = inv (\<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k])"
using assms pentagon by simp
also have "... = \<a>\<^sup>-\<^sup>1[f \<star> g, h, k] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h \<star> k]"
using assms inv_comp by simp
finally show ?thesis by auto
qed
end
text \<open>
The following convenience locale extends @{locale bicategory} by pre-interpreting
the various functors and natural transformations.
\<close>
locale extended_bicategory =
bicategory +
L: equivalence_functor V V L +
R: equivalence_functor V V R +
\<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
\<alpha>': inverse_transformation VVV.comp V HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
\<ll>: natural_isomorphism V V L map \<ll> +
\<ll>': inverse_transformation V V L map \<ll> +
\<rr>: natural_isomorphism V V R map \<rr> +
\<rr>': inverse_transformation V V R map \<rr>
sublocale bicategory \<subseteq> extended_bicategory V H \<a> \<i> src trg
proof -
interpret L: equivalence_functor V V L using equivalence_functor_L by auto
interpret R: equivalence_functor V V R using equivalence_functor_R by auto
interpret \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> ..
interpret \<ll>: natural_isomorphism V V L map \<ll> using natural_isomorphism_\<ll> by auto
interpret \<ll>': inverse_transformation V V L map \<ll> ..
interpret \<rr>: natural_isomorphism V V R map \<rr> using natural_isomorphism_\<rr> by auto
interpret \<rr>': inverse_transformation V V R map \<rr> ..
interpret extended_bicategory V H \<a> \<i> src trg ..
show "extended_bicategory V H \<a> \<i> src trg" ..
qed
end
diff --git a/thys/Bicategory/BicategoryOfSpans.thy b/thys/Bicategory/BicategoryOfSpans.thy
--- a/thys/Bicategory/BicategoryOfSpans.thy
+++ b/thys/Bicategory/BicategoryOfSpans.thy
@@ -1,14800 +1,14776 @@
(* Title: BicategoryOfSpans
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Bicategories of Spans"
theory BicategoryOfSpans
-imports CanonicalIsos SpanBicategory ConcreteCategory IsomorphismClass Tabulation
+imports CanonicalIsos SpanBicategory Category3.ConcreteCategory IsomorphismClass Tabulation
begin
text \<open>
In this section, we prove CKS Theorem 4, which characterizes up to equivalence the
bicategories of spans in a category with pullbacks.
The characterization consists of three conditions:
BS1: ``Every 1-cell is isomorphic to a composition \<open>g \<star> f\<^sup>*\<close>, where f and g are maps'';
BS2: ``For every span of maps \<open>(f, g)\<close> there is a 2-cell \<open>\<rho>\<close> such that \<open>(f, \<rho>, g)\<close>
is a tabulation''; and
BS3: ``Any two 2-cells between the same pair of maps are equal and invertible.''
One direction of the proof, which is the easier direction once it is established that
BS1 and BS3 are respected by equivalence of bicategories, shows that if a bicategory \<open>B\<close>
is biequivalent to the bicategory of spans in some category \<open>C\<close> with pullbacks,
then it satisfies BS1 -- BS3.
The other direction, which is harder, shows that a bicategory \<open>B\<close> satisfying BS1 -- BS3 is
biequivalent to the bicategory of spans in a certain category with pullbacks that
is constructed from the sub-bicategory of maps of \<open>B\<close>.
\<close>
subsection "Definition"
text \<open>
We define a \emph{bicategory of spans} to be a bicategory that satisfies the conditions
\<open>BS1\<close> -- \<open>BS3\<close> stated informally above.
\<close>
locale bicategory_of_spans =
bicategory + chosen_right_adjoints +
assumes BS1: "\<And>r. ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> isomorphic r (g \<star> f\<^sup>*)"
and BS2: "\<And>f g. \<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk>
\<Longrightarrow> \<exists>r \<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
and BS3: "\<And>f f' \<mu> \<mu>'. \<lbrakk> is_left_adjoint f; is_left_adjoint f'; \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright> \<rbrakk>
\<Longrightarrow> iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
text \<open>
Using the already-established fact \<open>equivalence_pseudofunctor.reflects_tabulation\<close>
that tabulations are reflected by equivalence pseudofunctors, it is not difficult to prove
that the notion `bicategory of spans' respects equivalence of bicategories.
\<close>
lemma bicategory_of_spans_respects_equivalence:
assumes "equivalent_bicategories V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
and "bicategory_of_spans V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C"
shows "bicategory_of_spans V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
proof -
interpret C: bicategory_of_spans V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
using assms by simp
interpret C: chosen_right_adjoints V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C ..
interpret D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
using assms equivalent_bicategories_def equivalence_pseudofunctor.axioms(1)
pseudofunctor.axioms(2)
by fast
interpret D: chosen_right_adjoints V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
obtain F \<Phi> where F: "equivalence_pseudofunctor
V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>"
using assms equivalent_bicategories_def by blast
interpret F: equivalence_pseudofunctor
V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>
using F by simp
interpret G: converse_equivalence_pseudofunctor
V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>
..
write V\<^sub>C (infixr "\<cdot>\<^sub>C" 55)
write V\<^sub>D (infixr "\<cdot>\<^sub>D" 55)
write H\<^sub>C (infixr "\<star>\<^sub>C" 53)
write H\<^sub>D (infixr "\<star>\<^sub>D" 53)
write \<a>\<^sub>C ("\<a>\<^sub>C[_, _, _]")
write \<a>\<^sub>D ("\<a>\<^sub>D[_, _, _]")
write C.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
write C.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>C _\<guillemotright>")
write D.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
write D.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>D _\<guillemotright>")
write C.isomorphic (infix "\<cong>\<^sub>C" 50)
write D.isomorphic (infix "\<cong>\<^sub>D" 50)
write C.some_right_adjoint ("_\<^sup>*\<^sup>C" [1000] 1000)
write D.some_right_adjoint ("_\<^sup>*\<^sup>D" [1000] 1000)
show "bicategory_of_spans V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
proof
show "\<And>r'. D.ide r' \<Longrightarrow>
\<exists>f' g'. D.is_left_adjoint f' \<and> D.is_left_adjoint g' \<and> r' \<cong>\<^sub>D g' \<star>\<^sub>D (f')\<^sup>*\<^sup>D"
proof -
fix r'
assume r': "D.ide r'"
obtain f g where fg: "C.is_left_adjoint f \<and> C.is_left_adjoint g \<and> G.G r' \<cong>\<^sub>C g \<star>\<^sub>C f\<^sup>*\<^sup>C"
using r' C.BS1 G.G\<^sub>1_props(1) G.G_ide by presburger
have trg_g: "trg\<^sub>C g = G.G\<^sub>0 (trg\<^sub>D r')"
using fg r' C.isomorphic_def C.hcomp_simps(2)
by (metis C.ideD(1) C.in_hhomE C.isomorphic_implies_hpar(4)
C.isomorphic_implies_ide(2) D.ideD(1) G.G_props(1))
have trg_f: "trg\<^sub>C f = G.G\<^sub>0 (src\<^sub>D r')"
using fg r' C.isomorphic_def C.hcomp_simps(1)
by (metis C.ideD(1) C.in_hhomE C.isomorphic_implies_hpar(3) C.isomorphic_implies_ide(2)
C.right_adjoint_simps(2) D.ideD(1) G.G_props(1))
interpret e_src: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>G.e (src\<^sub>D r')\<close> \<open>G.d (src\<^sub>D r')\<close> \<open>G.\<eta> (src\<^sub>D r')\<close> \<open>G.\<epsilon> (src\<^sub>D r')\<close>
using r' G.G\<^sub>0_props [of "src\<^sub>D r'"] by simp
interpret e_trg: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>G.e (trg\<^sub>D r')\<close> \<open>G.d (trg\<^sub>D r')\<close> \<open>G.\<eta> (trg\<^sub>D r')\<close> \<open>G.\<epsilon> (trg\<^sub>D r')\<close>
using r' G.G\<^sub>0_props [of "trg\<^sub>D r'"] by simp
interpret e: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>G.e (src\<^sub>D r')\<close> \<open>G.d (src\<^sub>D r')\<close> \<open>G.\<eta> (src\<^sub>D r')\<close> \<open>G.\<epsilon> (src\<^sub>D r')\<close>
\<open>G.e (trg\<^sub>D r')\<close> \<open>G.d (trg\<^sub>D r')\<close> \<open>G.\<eta> (trg\<^sub>D r')\<close> \<open>G.\<epsilon> (trg\<^sub>D r')\<close>
..
interpret hom: subcategory V\<^sub>D
\<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : src\<^sub>D (G.e (src\<^sub>D r')) \<rightarrow>\<^sub>D src\<^sub>D (G.e (trg\<^sub>D r'))\<guillemotright>\<close>
using D.hhom_is_subcategory by simp
interpret hom': subcategory V\<^sub>D
\<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : trg\<^sub>D (G.e (src\<^sub>D r')) \<rightarrow>\<^sub>D trg\<^sub>D (G.e (trg\<^sub>D r'))\<guillemotright>\<close>
using D.hhom_is_subcategory by simp
interpret e: equivalence_of_categories hom'.comp hom.comp e.F e.G e.\<phi> e.\<psi>
using e.induces_equivalence_of_hom_categories by simp
define g'
where "g' = G.d (trg\<^sub>D r') \<star>\<^sub>D F g"
have g': "D.is_left_adjoint g'"
proof -
have "D.equivalence_map (G.d (trg\<^sub>D r'))"
using D.equivalence_map_def e_trg.dual_equivalence by blast
hence "D.is_left_adjoint (G.d (trg\<^sub>D r'))"
using r' D.equivalence_is_adjoint by simp
moreover have "src\<^sub>D (G.d (trg\<^sub>D r')) = trg\<^sub>D (F g)"
using fg r' G.G\<^sub>0_props trg_g
by (simp add: C.left_adjoint_is_ide)
ultimately show ?thesis
unfolding g'_def
using fg r' D.left_adjoints_compose F.preserves_left_adjoint by blast
qed
have 1: "D.is_right_adjoint (F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r'))"
proof -
have "D.equivalence_map (G.e (src\<^sub>D r'))"
using D.equivalence_map_def e_src.equivalence_in_bicategory_axioms by blast
hence "D.is_right_adjoint (G.e (src\<^sub>D r'))"
using r' D.equivalence_is_adjoint by simp
moreover have "D.is_right_adjoint (F f\<^sup>*\<^sup>C)"
using fg C.left_adjoint_extends_to_adjoint_pair F.preserves_adjoint_pair by blast
moreover have "src\<^sub>D (F f\<^sup>*\<^sup>C) = trg\<^sub>D (G.e (src\<^sub>D r'))"
using fg r' G.G\<^sub>0_props trg_f
by (simp add: C.right_adjoint_is_ide)
ultimately show ?thesis
using fg r' D.right_adjoints_compose F.preserves_right_adjoint by blast
qed
obtain f' where f': "D.adjoint_pair f' (F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r'))"
using 1 by auto
have f': "D.is_left_adjoint f' \<and> F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r') \<cong>\<^sub>D (f')\<^sup>*\<^sup>D"
using f' D.left_adjoint_determines_right_up_to_iso D.left_adjoint_extends_to_adjoint_pair
by blast
have "r' \<cong>\<^sub>D G.d (trg\<^sub>D r') \<star>\<^sub>D (G.e (trg\<^sub>D r') \<star>\<^sub>D r' \<star>\<^sub>D G.d (src\<^sub>D r')) \<star>\<^sub>D G.e (src\<^sub>D r')"
using r' e.\<eta>.components_are_iso e.\<phi>_in_hom [of r'] D.isomorphic_def
hom.ide_char hom.arr_char hom.iso_char
by auto
also have 1: "... \<cong>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F (G.G r') \<star>\<^sub>D G.e (src\<^sub>D r'))"
proof -
have "G.e (trg\<^sub>D r') \<star>\<^sub>D r' \<star>\<^sub>D G.d (src\<^sub>D r') \<cong>\<^sub>D F (G.G r')"
by (simp add: D.isomorphic_symmetric G.G\<^sub>1_props(3) G.G_ide r')
thus ?thesis
using r' D.hcomp_isomorphic_ide D.hcomp_ide_isomorphic by simp
qed
also have 2: "... \<cong>\<^sub>D G.d (trg\<^sub>D r') \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D G.e (src\<^sub>D r')"
proof -
have "F (G.G r') \<cong>\<^sub>D F (g \<star>\<^sub>C f\<^sup>*\<^sup>C)"
using fg F.preserves_iso C.isomorphic_def D.isomorphic_def by auto
also have "F (g \<star>\<^sub>C f\<^sup>*\<^sup>C) \<cong>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C"
using fg
by (meson C.adjoint_pair_antipar(1) C.hseqE C.ideD(1) C.isomorphic_implies_hpar(2)
C.right_adjoint_simps(1) D.isomorphic_symmetric F.weakly_preserves_hcomp)
finally have "D.isomorphic (F (G.G r')) (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C)"
by simp
moreover have "\<And>f g. D.ide (H\<^sub>D f g) \<Longrightarrow> src\<^sub>D f = trg\<^sub>D g"
by (metis (no_types) D.hseqE D.ideD(1))
ultimately show ?thesis
by (meson 1 D.hcomp_ide_isomorphic D.hcomp_isomorphic_ide D.hseqE D.ideD(1)
D.isomorphic_implies_hpar(2)
e_src.ide_left e_trg.ide_right)
qed
also have 3: "... \<cong>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')"
proof -
let ?a = "\<a>\<^sub>D\<^sup>-\<^sup>1[G.d (trg\<^sub>D r'), F g, F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')] \<cdot>\<^sub>D
(G.d (trg\<^sub>D r') \<star>\<^sub>D \<a>\<^sub>D[F g, F f\<^sup>*\<^sup>C, G.e (src\<^sub>D r')])"
have "\<guillemotleft>?a : G.d (trg\<^sub>D r') \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D G.e (src\<^sub>D r')
\<Rightarrow>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>G.d (trg\<^sub>D r') \<star>\<^sub>D \<a>\<^sub>D[F g, F f\<^sup>*\<^sup>C, G.e (src\<^sub>D r')] :
G.d (trg\<^sub>D r') \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D G.e (src\<^sub>D r')
\<Rightarrow>\<^sub>D G.d (trg\<^sub>D r') \<star>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')\<guillemotright>"
using fg r' 2 C.left_adjoint_is_ide D.hseqE D.ideD(1) D.isomorphic_implies_ide(2)
D.src_hcomp' D.hseqI' D.assoc_in_hom [of "F g" "F f\<^sup>*\<^sup>C" "G.e (src\<^sub>D r')"]
apply auto
by (metis C.hseqE C.ideD(1) C.isomorphic_implies_hpar(2) C.right_adjoint_simps(3)
D.hcomp_in_vhom D.ideD(1) D.ide_in_hom(2) e_trg.ide_right trg_f)
show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[G.d (trg\<^sub>D r'), F g, F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')] :
G.d (trg\<^sub>D r') \<star>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')
\<Rightarrow>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')\<guillemotright>"
using fg r' f' trg_g 2 C.left_adjoint_is_ide D.hseqE D.ideD(1)
D.isomorphic_implies_ide D.src_hcomp' D.hseqI'
D.assoc'_in_hom [of "G.d (trg\<^sub>D r')" "F g" "F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')"]
apply auto
by (metis (no_types, lifting) C.hseqE C.ideD(1) C.isomorphic_implies_ide(2)
C.right_adjoint_simps(3) D.assoc'_eq_inv_assoc D.ideD(1) D.trg_hcomp'
F.preserves_ide e_trg.ide_right)
qed
moreover have "D.iso ?a"
using fg r' D.isos_compose
by (metis 2 C.left_adjoint_is_ide C.right_adjoint_simps(1) D.arrI D.assoc_simps(3)
D.iso_hcomp D.hseqE D.ideD(1) D.ide_is_iso D.iso_assoc D.iso_assoc'
D.isomorphic_implies_ide(1) D.isomorphic_implies_ide(2) D.trg_hcomp'
F.preserves_ide calculation e_src.ide_left e_trg.ide_right f')
ultimately show ?thesis
using D.isomorphic_def by auto
qed
also have "(G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r') \<cong>\<^sub>D g' \<star>\<^sub>D f'\<^sup>*\<^sup>D"
using g'_def f'
by (metis 3 D.adjoint_pair_antipar(1) D.hcomp_ide_isomorphic D.hseq_char D.ideD(1)
D.isomorphic_implies_ide(2) g')
finally have "D.isomorphic r' (g' \<star>\<^sub>D f'\<^sup>*\<^sup>D)"
by simp
thus "\<exists>f' g'. D.is_left_adjoint f' \<and> D.is_left_adjoint g' \<and> r' \<cong>\<^sub>D g' \<star>\<^sub>D f'\<^sup>*\<^sup>D"
using f' g' by auto
qed
show "\<And>f f' \<mu> \<mu>'. \<lbrakk> D.is_left_adjoint f; D.is_left_adjoint f';
\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>D f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>D f'\<guillemotright> \<rbrakk> \<Longrightarrow> D.iso \<mu> \<and> D.iso \<mu>' \<and> \<mu> = \<mu>'"
proof -
fix f f' \<mu> \<mu>'
assume f: "D.is_left_adjoint f"
and f': "D.is_left_adjoint f'"
and \<mu>: "\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>D f'\<guillemotright>"
and \<mu>': "\<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>D f'\<guillemotright>"
have "C.is_left_adjoint (G.G f) \<and> C.is_left_adjoint (G.G f')"
using f f' G.preserves_left_adjoint by simp
moreover have "\<guillemotleft>G.G \<mu> : G.G f \<Rightarrow>\<^sub>C G.G f'\<guillemotright> \<and> \<guillemotleft>G.G \<mu>' : G.G f \<Rightarrow>\<^sub>C G.G f'\<guillemotright>"
using \<mu> \<mu>' G.preserves_hom by simp
ultimately have "C.iso (G.G \<mu>) \<and> C.iso (G.G \<mu>') \<and> G.G \<mu> = G.G \<mu>'"
using C.BS3 by blast
thus "D.iso \<mu> \<and> D.iso \<mu>' \<and> \<mu> = \<mu>'"
using \<mu> \<mu>' G.reflects_iso G.is_faithful by blast
qed
show "\<And>f g. \<lbrakk> D.is_left_adjoint f; D.is_left_adjoint g; src\<^sub>D f = src\<^sub>D g \<rbrakk>
\<Longrightarrow> \<exists>r \<rho>. tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r \<rho> f g"
proof -
fix f g
assume f: "D.is_left_adjoint f"
assume g: "D.is_left_adjoint g"
assume fg: "src\<^sub>D f = src\<^sub>D g"
have "C.is_left_adjoint (G.G f)"
using f G.preserves_left_adjoint by blast
moreover have "C.is_left_adjoint (G.G g)"
using g G.preserves_left_adjoint by blast
moreover have "src\<^sub>C (G.G f) = src\<^sub>C (G.G g)"
using f g D.left_adjoint_is_ide fg by simp
ultimately have 1: "\<exists>r \<rho>. tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> (G.G f) (G.G g)"
using C.BS2 by simp
obtain r \<rho> where \<rho>: "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> (G.G f) (G.G g)"
using 1 by auto
interpret \<rho>: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> \<open>G.G f\<close> \<open>G.G g\<close>
using \<rho> by simp
obtain r' where
r': "D.ide r' \<and> D.in_hhom r' (trg\<^sub>D f) (trg\<^sub>D g) \<and> C.isomorphic (G.G r') r"
using f g \<rho>.ide_base \<rho>.tab_in_hom G.locally_essentially_surjective
by (metis D.obj_trg G.preserves_reflects_arr G.preserves_trg \<rho>.leg0_simps(2-3)
\<rho>.leg1_simps(2,4) \<rho>.base_in_hom(1))
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : r \<Rightarrow>\<^sub>C G.G r'\<guillemotright> \<and> C.iso \<phi>"
using r' C.isomorphic_symmetric by blast
have \<sigma>: "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
(G.G r') (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>) (G.G f) (G.G g)"
using \<phi> \<rho>.is_preserved_by_base_iso by simp
have 1: "\<exists>\<rho>'. \<guillemotleft>\<rho>' : g \<Rightarrow>\<^sub>D H\<^sub>D r' f\<guillemotright> \<and>
G.G \<rho>' = V\<^sub>C (G.\<Phi> (r', f)) (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>)"
proof -
have "D.ide g"
by (simp add: D.left_adjoint_is_ide g)
moreover have "D.ide (H\<^sub>D r' f)"
using f r' D.left_adjoint_is_ide by auto
moreover have "src\<^sub>D g = src\<^sub>D (H\<^sub>D r' f)"
using fg by (simp add: calculation(2))
moreover have "trg\<^sub>D g = trg\<^sub>D (H\<^sub>D r' f)"
using calculation(2) r' by auto
moreover have
"\<guillemotleft>V\<^sub>C (G.\<Phi> (r', f)) (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>) : G.G g \<Rightarrow>\<^sub>C G.G (H\<^sub>D r' f)\<guillemotright>"
using f g r' \<phi> C.hseqI' G.\<Phi>_in_hom [of r' f] D.left_adjoint_is_ide \<rho>.ide_base
by (intro C.comp_in_homI, auto)
ultimately show ?thesis
using G.locally_full by simp
qed
obtain \<rho>' where \<rho>': "\<guillemotleft>\<rho>' : g \<Rightarrow>\<^sub>D H\<^sub>D r' f\<guillemotright> \<and>
G.G \<rho>' = V\<^sub>C (G.\<Phi> (r', f)) (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>)"
using 1 by auto
have "tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r' \<rho>' f g"
proof -
have "V\<^sub>C (C.inv (G.\<Phi> (r', f))) (G.G \<rho>') = V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>"
using r' f \<rho>' C.comp_assoc C.comp_cod_arr G.\<Phi>_components_are_iso
C.invert_side_of_triangle(1)
[of "G.G \<rho>'" "G.\<Phi> (r', f)" "V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>"]
by (metis (no_types, lifting) D.arrI D.in_hhom_def D.left_adjoint_is_ide G.preserves_arr)
thus ?thesis
using \<sigma> \<rho>' G.reflects_tabulation
by (simp add: D.left_adjoint_is_ide f r')
qed
thus "\<exists>r' \<rho>'. tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r' \<rho>' f g"
by auto
qed
qed
qed
subsection "Span(C) is a Bicategory of Spans"
text \<open>
We first consider an arbitrary 1-cell \<open>r\<close> in \<open>Span(C)\<close>, and show that it has a tabulation
as a span of maps. This is CKS Proposition 3 (stated more strongly to assert that
the ``output leg'' can also be taken to be a map, which the proof shows already).
\<close>
locale identity_arrow_in_span_bicategory =
span_bicategory C prj0 prj1 +
r: identity_arrow_of_spans C r
for C :: "'a comp" (infixr "\<cdot>" 55)
and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>0[_, _]")
and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>1[_, _]")
and r :: "'a arrow_of_spans_data"
begin
text \<open>
CKS say: ``Suppose \<open>r = (r\<^sub>0, R, r\<^sub>1): A \<rightarrow> B\<close> and put \<open>f = (1, R, r\<^sub>0)\<close>, \<open>g = (1, R, r\<^sub>1)\<close>.
Let \<open>k\<^sub>0, k\<^sub>1\<close> form a kernel pair for \<open>r\<^sub>0\<close> and define \<open>\<rho>\<close> by \<open>k\<^sub>0\<rho> = k\<^sub>1\<rho> = 1\<^sub>R\<close>.''
\<close>
abbreviation ra where "ra \<equiv> r.dom.apex"
abbreviation r0 where "r0 \<equiv> r.dom.leg0"
abbreviation r1 where "r1 \<equiv> r.dom.leg1"
abbreviation f where "f \<equiv> mkIde ra r0"
abbreviation g where "g \<equiv> mkIde ra r1"
abbreviation k0 where "k0 \<equiv> \<p>\<^sub>0[r0, r0]"
abbreviation k1 where "k1 \<equiv> \<p>\<^sub>1[r0, r0]"
text \<open>
Here \<open>ra\<close> is the apex \<open>R\<close> of the span \<open>(r\<^sub>0, R, r\<^sub>1)\<close>, and the spans \<open>f\<close> and \<open>g\<close> also have
that same 0-cell as their apex. The tabulation 2-cell \<open>\<rho>\<close> has to be an arrow of spans
from \<open>g = (1, R, r\<^sub>1)\<close> to \<open>r \<star> f\<close>, which is the span \<open>(k\<^sub>0, r\<^sub>1 \<cdot> k\<^sub>1)\<close>.
\<close>
abbreviation \<rho> where "\<rho> \<equiv> \<lparr>Chn = \<langle>ra \<lbrakk>r0, r0\<rbrakk> ra\<rangle>,
Dom = \<lparr>Leg0 = ra, Leg1 = r1\<rparr>,
Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>"
lemma has_tabulation:
shows "tabulation vcomp hcomp assoc unit src trg r \<rho> f g"
and "is_left_adjoint f" and "is_left_adjoint g"
proof -
have ide_f: "ide f"
using ide_mkIde r.dom.leg_in_hom(1) C.arr_dom C.dom_dom r.dom.apex_def r.dom.leg_simps(1)
by presburger
interpret f: identity_arrow_of_spans C f
using ide_f ide_char' by auto
have ide_g: "ide g"
using ide_mkIde r.dom.leg_in_hom
by (metis C.arr_dom C.dom_dom r.dom.leg_simps(3) r.dom.leg_simps(4))
interpret g: identity_arrow_of_spans C g
using ide_g ide_char' by auto
show "is_left_adjoint f"
using is_left_adjoint_char [of f] ide_f by simp
show "is_left_adjoint g"
using is_left_adjoint_char [of g] ide_g by simp
have ide_r: "ide r"
using ide_char' r.identity_arrow_of_spans_axioms by auto
have src_r: "src r = mkObj (C.cod r0)"
by (simp add: ide_r src_def)
have trg_r: "trg r = mkObj (C.cod r1)"
by (simp add: ide_r trg_def)
have src_f: "src f = mkObj ra"
using ide_f src_def by auto
have trg_f: "trg f = mkObj (C.cod r0)"
using ide_f trg_def by auto
have src_g: "src g = mkObj ra"
using ide_g src_def by auto
have trg_g: "trg g = mkObj (C.cod r1)"
using ide_g trg_def by auto
have hseq_rf: "hseq r f"
using ide_r ide_f src_r trg_f by simp
interpret rf: two_composable_arrows_of_spans C prj0 prj1 r f
using hseq_rf hseq_char by (unfold_locales, auto)
interpret rf: two_composable_identity_arrows_of_spans C prj0 prj1 r f ..
interpret rf: identity_arrow_of_spans C \<open>r \<star> f\<close>
using rf.ide_composite ide_char' by auto
let ?rf = "r \<star> f"
(* TODO: Put this expansion into two_composable_identity_arrows_of_spans. *)
have rf: "?rf = \<lparr>Chn = r0 \<down>\<down> r0,
Dom = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>,
Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>"
unfolding hcomp_def chine_hcomp_def
using hseq_rf C.comp_cod_arr by auto
interpret Cod_rf: span_in_category C \<open>\<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<close>
using ide_r ide_f rf C.comp_cod_arr
by (unfold_locales, auto)
have Dom_g: "Dom g = \<lparr>Leg0 = ra, Leg1 = r1\<rparr>" by simp
interpret Dom_g: span_in_category C \<open>\<lparr>Leg0 = ra, Leg1 = r1\<rparr>\<close>
using Dom_g g.dom.span_in_category_axioms by simp
interpret Dom_\<rho>: span_in_category C \<open>Dom \<rho>\<close>
using Dom_g g.dom.span_in_category_axioms by simp
interpret Cod_\<rho>: span_in_category C \<open>Cod \<rho>\<close>
using rf Cod_rf.span_in_category_axioms by simp
interpret \<rho>: arrow_of_spans C \<rho>
using Dom_\<rho>.apex_def Cod_\<rho>.apex_def C.comp_assoc C.comp_arr_dom
by (unfold_locales, auto)
have \<rho>: "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
proof
show 1: "arr \<rho>"
using arr_char \<rho>.arrow_of_spans_axioms by simp
show "dom \<rho> = g"
using 1 dom_char ideD(2) ide_g by fastforce
show "cod \<rho> = r \<star> f"
using 1 cod_char rf Cod_rf.apex_def by simp
qed
show "tabulation vcomp hcomp assoc unit src trg r \<rho> f g"
proof -
interpret T: tabulation_data vcomp hcomp assoc unit src trg r \<rho> f g
using ide_f \<rho> by (unfold_locales, auto)
show ?thesis
proof
show T1: "\<And>u \<omega>.
\<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
proof -
fix u \<omega>
assume u: "ide u"
assume \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
show "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
proof -
interpret u: identity_arrow_of_spans C u
using u ide_char' by auto
have v: "ide (dom \<omega>)"
using \<omega> by auto
interpret v: identity_arrow_of_spans C \<open>dom \<omega>\<close>
using v ide_char' by auto
interpret \<omega>: arrow_of_spans C \<omega>
using \<omega> arr_char by auto
have hseq_ru: "hseq r u"
using u \<omega> ide_cod by fastforce
interpret ru: two_composable_arrows_of_spans C prj0 prj1 r u
using hseq_ru hseq_char by (unfold_locales, auto)
interpret ru: two_composable_identity_arrows_of_spans C prj0 prj1 r u ..
text \<open>
CKS say:
``We must show that \<open>(f, \<rho>, g)\<close> is a wide tabulation of \<open>r\<close>.
Take \<open>u = (u\<^sub>0, U, u\<^sub>1): X \<rightarrow> A\<close>, \<open>v = (v\<^sub>0, V, v\<^sub>1): X \<rightarrow> B\<close>,
\<open>\<omega>: v \<Rightarrow> ru\<close> as in \<open>T1\<close>. Let \<open>P\<close> be the pullback of \<open>u\<^sub>1, r\<^sub>0\<close>.
Let \<open>w = (v\<^sub>0, V, p\<^sub>1\<omega>): X \<rightarrow> R\<close>, \<open>\<theta> = p\<^sub>0\<omega>: fw \<Rightarrow> u\<close>,
\<open>\<nu> = 1: v \<Rightarrow> gw\<close>; so \<open>\<omega> = (r\<theta>)(\<rho>w)\<nu>\<close> as required.''
\<close>
let ?R = "r.apex"
let ?A = "C.cod r0"
let ?B = "C.cod r1"
let ?U = "u.apex"
let ?u0 = "u.leg0"
let ?u1 = "u.leg1"
let ?X = "C.cod ?u0"
let ?V = "v.apex"
let ?v0 = "v.leg0"
let ?v1 = "v.leg1"
let ?\<omega> = "\<omega>.chine"
let ?P = "r0 \<down>\<down> ?u1"
let ?p0 = "\<p>\<^sub>0[r0, ?u1]"
let ?p1 = "\<p>\<^sub>1[r0, ?u1]"
let ?w1 = "?p1 \<cdot> ?\<omega>"
define w where "w = mkIde ?v0 ?w1"
let ?Q = "?R \<down>\<down> ?w1"
let ?q1 = "\<p>\<^sub>1[?R, ?w1]"
let ?\<rho> = "\<langle>?R \<lbrakk>r0, r0\<rbrakk> ?R\<rangle>"
have P: "?P = ru.apex"
using ru.apex_composite by auto
have Chn_\<omega>: "\<guillemotleft>?\<omega> : ?V \<rightarrow>\<^sub>C ?P\<guillemotright>"
using P Chn_in_hom \<omega> by force
have p0\<omega>: "\<guillemotleft>?p0 \<cdot> ?\<omega> : ?V \<rightarrow>\<^sub>C ?U\<guillemotright>"
using Chn_\<omega> ru.legs_form_cospan by auto
have w1: "\<guillemotleft>?w1 : ?V \<rightarrow>\<^sub>C ?R\<guillemotright>"
using Chn_\<omega> ru.legs_form_cospan r.dom.apex_def by blast
have r1w1: "r1 \<cdot> ?w1 = ?v1"
by (metis C.comp_assoc T.base_simps(3) \<omega> \<omega>.leg1_commutes
arrow_of_spans_data.select_convs(3) cod_char dom_char ideD(1) ideD(2)
in_homE ru.composite_in_hom ru.leg1_composite u v)
have w: "ide w"
unfolding w_def
using P \<omega> w1 by (intro ide_mkIde, auto)
interpret w: identity_arrow_of_spans C w
using w_def w ide_char' by auto
have hseq_fw: "hseq f w"
using w_def ide_f w src_def trg_def w1 by auto
interpret fw: two_composable_arrows_of_spans C prj0 prj1 f w
using w_def hseq_fw hseq_char by (unfold_locales, auto)
interpret fw: two_composable_identity_arrows_of_spans C prj0 prj1 f w ..
have hseq_gw: "hseq g w"
using w_def ide_g w src_def trg_def w1 by auto
interpret gw: two_composable_arrows_of_spans C prj0 prj1 g w
using hseq_gw hseq_char by (unfold_locales, auto)
interpret gw: two_composable_identity_arrows_of_spans C prj0 prj1 g w ..
interpret rfw: three_composable_arrows_of_spans C prj0 prj1 r f w ..
interpret rfw: three_composable_identity_arrows_of_spans C prj0 prj1 r f w ..
have arfw: "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
using fw.composable ide_f ide_r w rf.composable by auto
have fw_apex_eq: "fw.apex = ?R \<down>\<down> ?w1"
using w_def fw.dom.apex_def hcomp_def hseq_fw hseq_char \<omega> C.arr_dom_iff_arr
C.pbdom_def fw.chine_eq_apex fw.chine_simps(1)
by auto
have gw_apex_eq: "gw.apex = ?R \<down>\<down> ?w1"
using w_def \<omega> w1 gw.dom.apex_def hcomp_def hseq_gw hseq_char by auto
text \<open>
Well, CKS say take \<open>\<theta> = p\<^sub>0\<omega>\<close>, but taking this literally and trying to define
\<open>\<theta>\<close> so that \<open>Chn \<theta> = ?p\<^sub>0 \<cdot> ?\<omega>\<close>, does not yield the required \<open>dom \<theta> = ?R \<down>\<down> ?w1\<close>.
We need \<open>\<guillemotleft>Chn \<theta> : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?U\<guillemotright>\<close>, so we have to compose with a
projection, which leads to: \<open>Chn \<theta> = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]\<close>.
What CKS say is only correct if the projection \<open>\<p>\<^sub>0[?R, ?w1]\<close> is an identity,
which can't be guaranteed for an arbitrary choice of pullbacks.
\<close>
define \<theta>
where
"\<theta> = \<lparr>Chn = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1], Dom = Dom (f \<star> w), Cod = Cod u\<rparr>"
interpret Dom_\<theta>: span_in_category C \<open>Dom \<theta>\<close>
using \<theta>_def fw.dom.span_in_category_axioms by simp
interpret Cod_\<theta>: span_in_category C \<open>Cod \<theta>\<close>
using \<theta>_def u.cod.span_in_category_axioms by simp
have Dom_\<theta>_leg0_eq: "Dom_\<theta>.leg0 = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
have Dom_\<theta>_leg1_eq: "Dom_\<theta>.leg1 = r0 \<cdot> ?q1"
using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
have Cod_\<theta>_leg0_eq: "Cod_\<theta>.leg0 = ?u0"
using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
have Cod_\<theta>_leg1_eq: "Cod_\<theta>.leg1 = ?u1"
using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
have Chn_\<theta>_eq: "Chn \<theta> = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
using \<theta>_def by simp
interpret \<theta>: arrow_of_spans C \<theta>
proof
show 1: "\<guillemotleft>Chn \<theta> : Dom_\<theta>.apex \<rightarrow>\<^sub>C Cod_\<theta>.apex\<guillemotright>"
using \<theta>_def Chn_\<omega> ru.legs_form_cospan fw_apex_eq
by (intro C.in_homI, auto)
show "Cod_\<theta>.leg0 \<cdot> Chn \<theta> = Dom_\<theta>.leg0"
proof -
have "Cod_\<theta>.leg0 \<cdot> Chn \<theta> = ?u0 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
using Cod_\<theta>_leg0_eq Chn_\<theta>_eq by simp
also have "... = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
proof -
have "?u0 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1] = (?u0 \<cdot> ?p0 \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
using C.comp_assoc by simp
also have "... = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
proof -
have "?u0 \<cdot> ?p0 \<cdot> ?\<omega> = (?u0 \<cdot> ?p0) \<cdot> ?\<omega>"
using C.comp_assoc by simp
also have "... = \<omega>.cod.leg0 \<cdot> ?\<omega>"
proof -
have "\<omega>.cod.leg0 = ru.leg0"
using \<omega> cod_char hcomp_def hseq_ru by auto
also have "... = ?u0 \<cdot> ?p0"
using hcomp_def hseq_ru by auto
finally show ?thesis by simp
qed
also have "... = \<omega>.dom.leg0"
using \<omega>.leg0_commutes by simp
also have "... = ?v0"
using \<omega> dom_char by auto
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
also have "... = Dom_\<theta>.leg0"
using Dom_\<theta>_leg0_eq by simp
finally show ?thesis by blast
qed
show "Cod_\<theta>.leg1 \<cdot> Chn \<theta> = Dom_\<theta>.leg1"
proof -
have "Cod_\<theta>.leg1 \<cdot> Chn \<theta> = ?u1 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
using Cod_\<theta>_leg1_eq Chn_\<theta>_eq by simp
also have "... = r0 \<cdot> ?q1"
proof -
have "?u1 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1] = ((?u1 \<cdot> ?p0) \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
using C.comp_assoc by fastforce
also have "... = ((r0 \<cdot> ?p1) \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
using C.pullback_commutes' ru.legs_form_cospan by simp
also have "... = r0 \<cdot> ?w1 \<cdot> \<p>\<^sub>0[?R, ?w1]"
using C.comp_assoc by fastforce
also have "... = r0 \<cdot> ?R \<cdot> ?q1"
using \<omega> C.in_homE C.pullback_commutes' w1 by auto
also have "... = r0 \<cdot> ?q1"
using \<omega> w1 C.comp_cod_arr by auto
finally show ?thesis by simp
qed
also have "... = Dom_\<theta>.leg1"
using Dom_\<theta>_leg1_eq by simp
finally show ?thesis by blast
qed
qed
text \<open>
Similarly, CKS say to take \<open>\<nu> = 1: v \<Rightarrow> gw\<close>, but obviously this can't be
interpreted literally, either, because \<open>v.apex\<close> and \<open>gw.apex\<close> are not equal.
Instead, we have to define \<open>\<nu>\<close> so that \<open>Chn \<nu> = C.inv \<p>\<^sub>0[?R, ?w1]\<close>,
noting that \<open>\<p>\<^sub>0[?R, ?w1]\<close> is the pullback of an identity,
hence is an isomorphism. Then \<open>?v0 \<cdot> \<p>\<^sub>0[?R, ?w1] \<cdot> Chn \<nu> = ?v0\<close> and
\<open>?v1 \<cdot> \<p>\<^sub>1[?R, ?w1] \<cdot> Chn \<nu> = ?v1 \<cdot> ?w1\<close>, showing that \<open>\<nu>\<close> is an arrow
of spans.
\<close>
let ?\<nu>' = "\<p>\<^sub>0[?R, ?w1]"
define \<nu>
where
"\<nu> = \<lparr>Chn = C.inv ?\<nu>', Dom = Dom (dom \<omega>), Cod = Cod (g \<star> w)\<rparr>"
have iso_\<nu>: "C.inverse_arrows ?\<nu>' (Chn \<nu>)"
using \<nu>_def \<omega> w1 C.iso_pullback_ide
by (metis C.inv_is_inverse C.seqE arrow_of_spans_data.select_convs(1)
r.chine_eq_apex r.chine_simps(1) r.chine_simps(3) r.cod_simps(1)
r.dom.apex_def r.dom.ide_apex r.dom.is_span r1w1 v.dom.leg_simps(3))
text \<open>
$$
\xymatrix{
&& X \\
&& V \ar[u]_{v_0} \ar[d]_{\omega} \ar@/ul50pt/[ddddll]_{v_1} \ar@/l30pt/[dd]_<>(0.7){w_1}\\
& R\downarrow\downarrow w_1 \ar[ur]^{\nu'} \ar[dd]_{q_1}
& r_0\downarrow\downarrow u_1 \ar[d]_{p_1} \ar@/dl10pt/[drr]_<>(0.4){p_0}
& R\downarrow\downarrow w_1 \ar[ul]_{\nu'} \ar[dd]^<>(0.7){q_1} \ar@ {.>}[dr]_{\theta}\\
&& R && U \ar@/ur20pt/[uuull]_{u_0} \ar[dd]^{u_1} \\
& R \ar[dl]_{r_1} \ar@ {<->}[ur]_{R} \ar@ {.>}[dr]^{\rho} \ar@/dl5pt/[ddr]_<>(0.4){R}
&& R \ar@ {<->}[ul]^{R} \ar[dr]^{r_0} \ar[ur]_{r_1}\\
B && r_0\downarrow\downarrow r_0 \ar[uu]_{k_0} \ar[d]^{k_1} \ar[uu] \ar[ur]_{k_0} && A \\
& & R \ar[ull]^{r_1} \ar[urr]_{r_0} \\
}
$$
\<close>
have w1_eq: "?w1 = ?q1 \<cdot> C.inv ?\<nu>'"
proof -
have "?R \<cdot> ?q1 = ?w1 \<cdot> ?\<nu>'"
using iso_\<nu> \<omega> w1 C.pullback_commutes [of ?R ?w1] by blast
hence "?q1 = ?w1 \<cdot> ?\<nu>'"
using \<omega> w1 C.comp_cod_arr by auto
thus ?thesis
using iso_\<nu> \<omega> w1 r.dom.apex_def r.cod.apex_def r.chine_eq_apex
C.invert_side_of_triangle(2)
by (metis C.isoI C.prj1_simps(1) arrow_of_spans_data.select_convs(3)
fw.legs_form_cospan(2) span_data.simps(1-2) w_def)
qed
interpret Dom_\<nu>: span_in_category C \<open>Dom \<nu>\<close>
using \<nu>_def v.dom.span_in_category_axioms by simp
interpret Cod_\<nu>: span_in_category C \<open>Cod \<nu>\<close>
using \<nu>_def gw.cod.span_in_category_axioms by simp
interpret \<nu>: arrow_of_spans C \<nu>
proof
show 1: "\<guillemotleft>Chn \<nu> : Dom_\<nu>.apex \<rightarrow>\<^sub>C Cod_\<nu>.apex\<guillemotright>"
proof
show "C.arr (Chn \<nu>)"
using iso_\<nu> by auto
show "C.dom (Chn \<nu>) = Dom_\<nu>.apex"
using \<nu>_def iso_\<nu> w1 gw_apex_eq by fastforce
show "C.cod (Chn \<nu>) = Cod_\<nu>.apex"
using \<nu>_def iso_\<nu> gw_apex_eq C.comp_inv_arr C.pbdom_def
by (metis C.cod_comp arrow_of_spans_data.select_convs(3)
gw.apex_composite gw.chine_composite gw.chine_simps(1) gw.chine_simps(3))
qed
show "Cod_\<nu>.leg0 \<cdot> Chn \<nu> = Dom_\<nu>.leg0"
using w_def \<nu>_def 1 iso_\<nu> hcomp_def hseq_gw C.comp_arr_inv
C.comp_assoc v.leg0_commutes
by auto
show "Cod_\<nu>.leg1 \<cdot> Chn \<nu> = Dom_\<nu>.leg1"
using w_def \<nu>_def hcomp_def hseq_gw C.comp_assoc w1_eq r1w1
by auto
qed
text \<open>
Now we can proceed to establishing the conclusions of \<open>T1\<close>.
\<close>
have "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> dom \<rho> \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
proof (intro conjI)
show ide_w: "ide w"
using w by blast
show \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
using \<theta>_def \<theta>.arrow_of_spans_axioms arr_char dom_char cod_char hseq_fw hseq_char
hcomp_def fw.chine_eq_apex
by auto
show \<nu>: "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> dom \<rho> \<star> w\<guillemotright>"
proof -
have "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
using \<nu>_def \<omega> \<nu>.arrow_of_spans_axioms arr_char dom_char cod_char hseq_gw
hseq_char hcomp_def gw.chine_eq_apex
apply (intro in_homI) by auto
thus ?thesis
using T.tab_in_hom by simp
qed
show "iso \<nu>"
using iso_\<nu> iso_char arr_char \<nu>.arrow_of_spans_axioms by auto
show "T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
proof (intro arr_eqI)
have \<rho>w: "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
using w_def \<rho> ide_w hseq_rf hseq_fw hseq_gw by auto
have r\<theta>: "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
using arfw ide_r \<theta> fw.composite_simps(2) rf.composable by auto
have 1: "\<guillemotleft>T.composite_cell w \<theta> \<bullet> \<nu> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
using \<nu> \<rho>w arfw r\<theta> by auto
show "par (T.composite_cell w \<theta> \<bullet> \<nu>) \<omega>"
using 1 \<omega> by (elim in_homE, auto)
show "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) = ?\<omega>"
proof -
have 2: "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) =
Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
proof -
have "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) =
Chn (T.composite_cell w \<theta>) \<cdot> Chn \<nu>"
using 1 Chn_vcomp by blast
also have "... = (Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
proof -
have "seq (r \<star> \<theta>) (\<a>[r, f, w] \<bullet> (\<rho> \<star> w)) \<and> seq \<a>[r, f, w] (\<rho> \<star> w)"
using 1 by blast
thus ?thesis
using 1 Chn_vcomp by presburger
qed
finally show ?thesis
using C.comp_assoc by auto
qed
also have "... = ?\<omega>"
proof -
let ?LHS = "Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
have Chn_r\<theta>: "Chn (r \<star> \<theta>) = \<langle>r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?q1]
\<lbrakk>r0, ?u1\<rbrakk>
\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]\<rangle>"
using r\<theta> hcomp_def \<theta>_def chine_hcomp_def Dom_\<theta>_leg1_eq
by (metis arrI arrow_of_spans_data.select_convs(1,3)
hseq_char r.cod_simps(2) u.cod_simps(3))
have Chn_arfw: "Chn \<a>[r, f, w] = rfw.chine_assoc"
using \<alpha>_ide ide_f rf.composable fw.composable w by auto
have Chn_\<rho>w: "Chn (\<rho> \<star> w) = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
proof -
have "Chn (\<rho> \<star> w) =
chine_hcomp
\<lparr>Chn = ?\<rho>,
Dom = \<lparr>Leg0 = ?R, Leg1 = r1\<rparr>,
Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>
\<lparr>Chn = v.apex,
Dom = \<lparr>Leg0 = ?v0, Leg1 = ?w1\<rparr>,
Cod = \<lparr>Leg0 = ?v0, Leg1 = ?w1\<rparr>\<rparr>"
using \<rho> ide_w hseq_rf hseq_char hcomp_def src_def trg_def
by (metis (no_types, lifting) \<rho>w arrI arrow_of_spans_data.select_convs(1)
v.dom.apex_def w_def)
also have "... = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?V \<cdot> ?\<nu>'\<rangle>"
unfolding chine_hcomp_def by simp
also have "... = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
proof -
have "?V \<cdot> ?\<nu>' = ?\<nu>'"
using C.comp_ide_arr v.dom.ide_apex \<rho> w1 by auto
thus ?thesis by simp
qed
finally show ?thesis by blast
qed
have 3: "C.seq ?p1 ?\<omega>"
using w1 by blast
moreover have 4: "C.seq ?p1 ?LHS"
proof
show "\<guillemotleft>?LHS : v.apex \<rightarrow>\<^sub>C ru.apex\<guillemotright>"
by (metis (no_types, lifting) 1 2 Chn_in_hom ru.chine_eq_apex
v.chine_eq_apex)
show "\<guillemotleft>?p1 : ru.apex \<rightarrow>\<^sub>C ?R\<guillemotright>"
using P C.prj1_in_hom ru.legs_form_cospan by fastforce
qed
moreover have "?p0 \<cdot> ?LHS = ?p0 \<cdot> ?\<omega>"
proof -
have "?p0 \<cdot> ?LHS =
(?p0 \<cdot> Chn (r \<star> \<theta>)) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
using C.comp_assoc by simp
also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]) \<cdot>
Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
proof -
have "?p0 \<cdot> Chn (r \<star> \<theta>) = \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]"
by (metis C.prj_tuple(1) Chn_r\<theta> \<theta>_def arrI Dom_\<theta>_leg1_eq
arrow_of_spans_data.select_convs(3) chine_hcomp_props(2)
hseq_char r.cod_simps(2) r\<theta> u.cod_simps(3))
thus ?thesis by argo
qed
also have
"... = ?p0 \<cdot> ?\<omega> \<cdot> (rfw.Prj\<^sub>0\<^sub>0 \<cdot> Chn \<a>[r, f, w]) \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
using w_def \<theta>_def C.comp_assoc by simp
also have "... = ?p0 \<cdot> ?\<omega> \<cdot> (rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
using Chn_arfw rfw.prj_chine_assoc C.comp_assoc by simp
also have "... = ?p0 \<cdot> ?\<omega> \<cdot> ?\<nu>' \<cdot> Chn \<nu>"
proof -
have "rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w) = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
using w_def Chn_\<rho>w C.comp_cod_arr by simp
also have "... = ?\<nu>'"
by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(1) C.seqE
C.tuple_is_extensional Chn_\<rho>w 4)
finally have "rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w) = ?\<nu>'"
by blast
thus ?thesis by simp
qed
also have "... = ?p0 \<cdot> ?\<omega>"
using iso_\<nu> C.comp_arr_dom
by (metis (no_types, lifting) C.comp_arr_inv C.dom_comp \<nu>_def
\<omega>.chine_simps(1) 3 arrow_of_spans_data.simps(1) w1_eq)
finally show ?thesis by blast
qed
moreover have "?p1 \<cdot> ?LHS = ?w1"
proof -
have "?p1 \<cdot> ?LHS =
(?p1 \<cdot> Chn (r \<star> \<theta>)) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
using C.comp_assoc by simp
also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?q1]) \<cdot> Chn \<a>[r, f, w] \<cdot>
Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(2) C.seqE
C.tuple_is_extensional Chn_r\<theta> 4)
also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
using w_def Dom_\<theta>_leg1_eq C.comp_assoc by simp
also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
using Chn_arfw rfw.prj_chine_assoc(1) C.comp_assoc by simp
also have "... = r.chine \<cdot> ?q1 \<cdot> Chn \<nu>"
proof -
have "rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w) =
(k1 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
using w_def Chn_\<rho>w C.comp_cod_arr by simp
also have "... = k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
using C.comp_assoc by simp
also have "... = k1 \<cdot> ?\<rho> \<cdot> ?q1"
by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(2)
C.seqE C.tuple_is_extensional Chn_\<rho>w 4)
also have "... = (k1 \<cdot> ?\<rho>) \<cdot> ?q1"
using C.comp_assoc by presburger
also have "... = ?R \<cdot> ?q1"
by simp
also have "... = ?q1"
by (metis Dom_\<theta>_leg1_eq C.comp_ide_arr C.prj1_simps(3)
C.prj1_simps_arr C.seqE C.seqI Dom_\<theta>.leg_simps(3)
r.dom.ide_apex)
finally have "rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w) = ?q1"
by blast
thus ?thesis by simp
qed
also have "... = (r.chine \<cdot> ?p1) \<cdot> ?\<omega>"
using \<nu>_def w1_eq C.comp_assoc by simp
also have "... = ?w1"
using C.comp_cod_arr r.chine_eq_apex ru.prj_simps(1) by auto
finally show ?thesis by blast
qed
ultimately show ?thesis
using ru.legs_form_cospan C.prj_joint_monic by blast
qed
finally show ?thesis by argo
qed
qed
qed
thus ?thesis
using w_def by auto
qed
qed
show T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
\<lbrakk> ide w; ide w';
\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<bullet> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)"
proof -
fix u w w' \<theta> \<theta>' \<beta>
assume ide_w: "ide w"
assume ide_w': "ide w'"
assume \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
assume \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
assume \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
assume E: "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<bullet> \<beta>"
interpret T: uw\<theta>w'\<theta>'\<beta> vcomp hcomp assoc unit src trg r \<rho> f g u w \<theta> w' \<theta>' \<beta>
using ide_w ide_w' \<theta> \<theta>' \<beta> E comp_assoc
by (unfold_locales, auto)
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)"
proof
interpret u: identity_arrow_of_spans C u
using T.uw\<theta>.u_simps(1) ide_char' by auto
interpret w: identity_arrow_of_spans C w
using ide_w ide_char' by auto
interpret w': identity_arrow_of_spans C w'
using ide_w' ide_char' by auto
let ?u0 = u.leg0
let ?u1 = u.leg1
let ?w0 = w.leg0
let ?w1 = w.leg1
let ?wa = "w.apex"
let ?w0' = w'.leg0
let ?w1' = w'.leg1
let ?wa' = "w'.apex"
let ?R = ra
let ?p0 = "\<p>\<^sub>0[?R, ?w1]"
let ?p0' = "\<p>\<^sub>0[?R, ?w1']"
let ?p1 = "\<p>\<^sub>1[?R, ?w1]"
let ?p1' = "\<p>\<^sub>1[?R, ?w1']"
interpret fw: two_composable_identity_arrows_of_spans C prj0 prj1 f w
using hseq_char by (unfold_locales, auto)
interpret fw': two_composable_identity_arrows_of_spans C prj0 prj1 f w'
using hseq_char by (unfold_locales, auto)
have hseq_gw: "hseq g w"
using T.leg1_in_hom by auto
interpret gw: two_composable_identity_arrows_of_spans C prj0 prj1 g w
using hseq_gw hseq_char by (unfold_locales, auto)
have hseq_gw': "hseq g w'"
using T.leg1_in_hom by auto
interpret gw': two_composable_identity_arrows_of_spans C prj0 prj1 g w'
using hseq_gw' hseq_char by (unfold_locales, auto)
interpret rfw: three_composable_identity_arrows_of_spans C prj0 prj1 r f w ..
interpret rfw: identity_arrow_of_spans C \<open>r \<star> f \<star> w\<close>
using rfw.composites_are_identities ide_char' by auto
interpret rfw': three_composable_arrows_of_spans C prj0 prj1 r f w' ..
interpret rfw': three_composable_identity_arrows_of_spans C prj0 prj1 r f w' ..
interpret rfw': identity_arrow_of_spans C \<open>r \<star> f \<star> w'\<close>
using rfw'.composites_are_identities ide_char' by auto
have \<rho>w: "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
using \<rho> hseq_gw by blast
interpret \<rho>w: two_composable_arrows_of_spans C prj0 prj1 \<rho> w
using \<rho>w by (unfold_locales, auto)
have \<rho>w': "\<guillemotleft>\<rho> \<star> w' : g \<star> w' \<Rightarrow> (r \<star> f) \<star> w'\<guillemotright>"
using \<rho> hseq_gw' by blast
interpret \<rho>w': two_composable_arrows_of_spans C prj0 prj1 \<rho> w'
using \<rho>w' by (unfold_locales, auto)
have arfw: "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
using fw.composable ide_f ide_r ide_w rf.composable by auto
have arfw': "\<guillemotleft>\<a>[r, f, w'] : (r \<star> f) \<star> w' \<Rightarrow> r \<star> f \<star> w'\<guillemotright>"
using fw'.composable ide_f ide_r ide_w' rf.composable by auto
have r\<theta>: "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
by fastforce
interpret Dom_\<theta>: span_in_category C \<open>Dom \<theta>\<close>
using fw.dom.span_in_category_axioms
by (metis \<theta> arrow_of_spans_data.select_convs(2) in_homE dom_char)
interpret Cod_\<theta>: span_in_category C \<open>Cod \<theta>\<close>
using \<theta> u.cod.span_in_category_axioms cod_char by auto
interpret \<theta>: arrow_of_spans C \<theta>
using arr_char by auto
interpret r\<theta>: two_composable_arrows_of_spans C prj0 prj1 r \<theta>
using r\<theta> by (unfold_locales, auto)
have r\<theta>': "\<guillemotleft>r \<star> \<theta>' : r \<star> f \<star> w' \<Rightarrow> r \<star> u\<guillemotright>"
by fastforce
interpret Dom_\<theta>': span_in_category C \<open>Dom \<theta>'\<close>
using fw'.dom.span_in_category_axioms
by (metis \<theta>' arrow_of_spans_data.select_convs(2) in_homE dom_char)
interpret Cod_\<theta>': span_in_category C \<open>Cod \<theta>'\<close>
using \<theta>' u.cod.span_in_category_axioms cod_char by auto
interpret \<theta>': arrow_of_spans C \<theta>'
using arr_char by auto
interpret r\<theta>': two_composable_arrows_of_spans C prj0 prj1 r \<theta>'
using r\<theta>' by (unfold_locales, auto)
have 7: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
using \<beta> \<rho>w' arfw' r\<theta>' by auto
have 8: "\<guillemotleft>T.composite_cell w \<theta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
using \<rho>w arfw r\<theta> by auto
interpret ru: two_composable_identity_arrows_of_spans C prj0 prj1 r u
using hseq_char by (unfold_locales, auto)
interpret Dom_\<beta>: span_in_category C \<open>Dom \<beta>\<close>
using \<beta> fw.dom.span_in_category_axioms arr_char
by (metis comp_arr_dom in_homE gw.cod.span_in_category_axioms seq_char)
interpret Cod_\<beta>: span_in_category C \<open>Cod \<beta>\<close>
using \<beta> fw.cod.span_in_category_axioms arr_char
by (metis (no_types, lifting) comp_arr_dom ideD(2) in_homI
gw'.cod.span_in_category_axioms gw'.chine_is_identity hseq_gw' seqI'
seq_char ide_char)
interpret \<beta>: arrow_of_spans C \<beta>
using \<beta> arr_char by auto
text \<open>
CKS say: ``Take \<open>u\<close>, \<open>w\<close>, \<open>w'\<close>, \<open>\<theta>\<close>, \<open>\<theta>'\<close> as in \<open>T2\<close> and note that
\<open>fw = (w\<^sub>0, W, r\<^sub>0 w\<^sub>1)\<close>, \<open>gw = (w\<^sub>0, W, r\<^sub>1 w\<^sub>1)\<close>, \emph{etc}.
So \<open>\<beta>: W \<rightarrow> W'\<close> satisfies \<open>w\<^sub>0 = w\<^sub>0' \<beta>\<close>, \<open>r\<^sub>1 w\<^sub>1 = r\<^sub>1 w\<^sub>1' \<beta>\<close>.
But the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>.
So \<open>\<gamma> = \<beta> : w \<Rightarrow> w'\<close> is unique with \<open>\<beta> = g \<gamma>, \<theta> = \<theta>' (f \<gamma>).\<close>''
Once again, there is substantial punning in the proof sketch given by CKS.
We can express \<open>fw\<close> and \<open>gw\<close> almost in the form they indicate, but projections
are required.
\<close>
have cospan: "C.cospan ?R ?w1"
using hseq_char [of \<rho> w] src_def trg_def by auto
have cospan': "C.cospan ?R ?w1'"
using hseq_char [of \<rho> w'] src_def trg_def by auto
have fw: "f \<star> w = \<lparr>Chn = ?R \<down>\<down> ?w1,
Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r0 \<cdot> ?p1\<rparr>,
Cod = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r0 \<cdot> ?p1\<rparr>\<rparr>"
using ide_f hseq_char hcomp_def chine_hcomp_def fw.dom.apex_def cospan
fw.chine_eq_apex
by auto
have gw: "g \<star> w = \<lparr>Chn = ?R \<down>\<down> ?w1,
Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>,
Cod = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>\<rparr>"
using hseq_gw hseq_char hcomp_def chine_hcomp_def gw.dom.apex_def cospan
gw.chine_eq_apex
by auto
have fw': "f \<star> w' = \<lparr>Chn = ?R \<down>\<down> ?w1',
Dom = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r0 \<cdot> ?p1'\<rparr>,
Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r0 \<cdot> ?p1'\<rparr>\<rparr>"
using ide_f hseq_char hcomp_def chine_hcomp_def fw'.dom.apex_def cospan'
fw'.chine_eq_apex
by auto
have gw': "g \<star> w' = \<lparr>Chn = ?R \<down>\<down> ?w1',
Dom = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>,
Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>\<rparr>"
using hseq_gw' hseq_char hcomp_def chine_hcomp_def gw'.dom.apex_def cospan'
gw'.chine_eq_apex
by auto
text \<open>
Note that \<open>?p0\<close> and \<open>?p0'\<close> are only isomorphisms, not identities,
and we have \<open>?p1\<close> (which equals \<open>?w1 \<cdot> ?p0\<close>) and \<open>?p1'\<close> (which equals \<open>?w1' \<cdot> ?p0'\<close>)
in place of \<open>?w1\<close> and \<open>?w1'\<close>.
\<close>
text \<open>
The following diagram summarizes the
various given and defined arrows involved in the proof.
We have deviated slightly here from the nomenclature used in in CKS.
We prefer to use \<open>W\<close> and \<open>W'\<close> to denote the apexes of
\<open>w\<close> and \<open>w'\<close>, respectively.
We already have the expressions \<open>?R \<down>\<down> ?w1\<close> and \<open>?R \<down>\<down> ?w1'\<close> for the
apexes of \<open>fw\<close> and \<open>fw'\<close> (which are the same as the apexes of
\<open>gw\<close> and \<open>gw'\<close>, respectively) and we will not use any abbreviation for them.
\<close>
text \<open>
$$
\xymatrix{
&&& X \\
&& W \ar[ur]^{w_0} \ar[dr]_{w_1} \ar@ {.>}[rr]^{\gamma}
&& W' \ar[ul]_{w_0'} \ar[dl]^{w_1'} && U \ar@/r10pt/[dddl]^{u_1} \ar@/u7pt/[ulll]_{u_0}\\
& R\downarrow\downarrow w_1 \ar[ur]_{p_0} \ar[dr]^{p_1} \ar@/d15pt/[rrrr]_{\beta}
\ar@/u100pt/[urrrrr]^{\theta}
&& R && R \downarrow\downarrow w_1' \ar[ul]^{p_0'} \ar[dl]^{p_1'} \ar[ur]_{\theta'} \\
&& R \ar@ {.>}[dr]_{\rho} \ar@/dl7pt/[ddr]_{R} \ar[ur]_{R} \ar[dl]_{r_1} \ar@ {<->}[rr]_{R}
&& R \ar[ul]^{R} \ar[dr]_{r_0} \\
& B && r_0 \downarrow\downarrow r_0 \ar[d]^{k_1} \ar[ur]_{k_0} && A \\
&&& R \ar@/dr10pt/[urr]_{r_0} \ar@/dl5pt/[ull]^{r_1}
}
$$
\<close>
have Chn_\<beta>: "\<guillemotleft>\<beta>.chine: ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
using gw gw' Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
have \<beta>_eq: "\<beta> = \<lparr>Chn = \<beta>.chine,
Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>,
Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>\<rparr>"
using \<beta> gw gw' dom_char cod_char by auto
have Dom_\<beta>_eq: "Dom \<beta> = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>"
using \<beta> gw gw' dom_char cod_char by auto
have Cod_\<beta>_eq: "Cod \<beta> = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>"
using \<beta> gw gw' dom_char cod_char by auto
have \<beta>0: "?w0 \<cdot> ?p0 = ?w0' \<cdot> ?p0' \<cdot> \<beta>.chine"
using Dom_\<beta>_eq Cod_\<beta>_eq \<beta>.leg0_commutes C.comp_assoc by simp
have \<beta>1: "r1 \<cdot> ?p1 = r1 \<cdot> ?p1' \<cdot> \<beta>.chine"
using Dom_\<beta>_eq Cod_\<beta>_eq \<beta>.leg1_commutes C.comp_assoc by simp
have Dom_\<theta>_0: "Dom_\<theta>.leg0 = ?w0 \<cdot> ?p0"
using arrI dom_char fw T.uw\<theta>.\<theta>_simps(4) by auto
have Cod_\<theta>_0: "Cod_\<theta>.leg0 = ?u0"
using \<theta> cod_char by auto
have Dom_\<theta>_1: "Dom_\<theta>.leg1 = r0 \<cdot> ?p1"
using arrI dom_char fw T.uw\<theta>.\<theta>_simps(4) by auto
have Cod_\<theta>_1: "Cod_\<theta>.leg1 = ?u1"
using T.uw\<theta>.\<theta>_simps(5) cod_char by auto
have Dom_\<theta>'_0: "Dom_\<theta>'.leg0 = ?w0' \<cdot> ?p0'"
using dom_char fw' T.uw'\<theta>'.\<theta>_simps(4) by auto
have Cod_\<theta>'_0: "Cod_\<theta>'.leg0 = ?u0"
using T.uw'\<theta>'.\<theta>_simps(5) cod_char by auto
have Dom_\<theta>'_1: "Dom_\<theta>'.leg1 = r0 \<cdot> ?p1'"
using dom_char fw' T.uw'\<theta>'.\<theta>_simps(4) by auto
have Cod_\<theta>'_1: "Cod_\<theta>'.leg1 = ?u1"
using T.uw'\<theta>'.\<theta>_simps(5) cod_char by auto
have Dom_\<rho>_0: "Dom_\<rho>.leg0 = ?R"
by simp
have Dom_\<rho>_1: "Dom_\<rho>.leg1 = r1"
by simp
have Cod_\<rho>_0: "Cod_\<rho>.leg0 = k0"
by simp
have Cod_\<rho>_1: "Cod_\<rho>.leg1 = r1 \<cdot> k1"
by simp
have Chn_r\<theta>: "\<guillemotleft>r\<theta>.chine : rfw.chine \<rightarrow>\<^sub>C ru.chine\<guillemotright>"
using r\<theta>.chine_composite_in_hom ru.chine_composite rfw.chine_composite
Cod_\<theta>_1 Dom_\<theta>_1 fw.leg1_composite
by auto
have Chn_r\<theta>_eq: "r\<theta>.chine = \<langle>\<p>\<^sub>1[r0, r0 \<cdot> ?p1] \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1]\<rangle>"
using r\<theta>.chine_composite Cod_\<theta>_1 Dom_\<theta>_1 fw.leg1_composite C.comp_cod_arr
by (metis arrow_of_spans_data.simps(2) fw r.chine_eq_apex r.cod_simps(2)
rfw.prj_simps(10) rfw.prj_simps(16) span_data.simps(2))
have r\<theta>_cod_apex_eq: "r\<theta>.cod.apex = r0 \<down>\<down> ?u1"
using Cod_\<theta>_1 r\<theta>.chine_composite_in_hom by auto
hence r\<theta>'_cod_apex_eq: "r\<theta>'.cod.apex = r0 \<down>\<down> ?u1"
using Cod_\<theta>'_1 r\<theta>'.chine_composite_in_hom by auto
have Chn_r\<theta>': "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C ru.chine\<guillemotright>"
using r\<theta>'.chine_composite_in_hom ru.chine_composite rfw'.chine_composite
Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite
by auto
have Chn_r\<theta>'_eq: "r\<theta>'.chine =
\<langle>\<p>\<^sub>1[r0, r0 \<cdot> ?p1'] \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']\<rangle>"
using r\<theta>'.chine_composite Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite C.comp_cod_arr
by (metis arrow_of_spans_data.simps(2) fw' r.chine_eq_apex r.cod_simps(2)
rfw'.prj_simps(10) rfw'.prj_simps(16) span_data.simps(2))
have Chn_\<rho>w: "\<guillemotleft>\<rho>w.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C k0 \<down>\<down> ?w1\<guillemotright>"
using \<rho>w.chine_composite_in_hom by simp
have Chn_\<rho>w_eq: "\<rho>w.chine = \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
using \<rho>w.chine_composite C.comp_cod_arr ide_w
by (simp add: chine_hcomp_arr_ide hcomp_def)
have Chn_\<rho>w': "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C k0 \<down>\<down> ?w1'\<guillemotright>"
using \<rho>w'.chine_composite_in_hom by simp
have Chn_\<rho>w'_eq: "\<rho>w'.chine = \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> ?p0'\<rangle>"
using \<rho>w'.chine_composite C.comp_cod_arr ide_w' Dom_\<rho>_0 Cod_\<rho>_0
by (metis \<rho>w'.composite_is_arrow chine_hcomp_arr_ide chine_hcomp_def hseq_char
w'.cod_simps(3))
text \<open>
The following are some collected commutativity properties that are used
subsequently.
\<close>
have "C.commutative_square r0 ?u1 ?p1 \<theta>.chine"
using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1 Cod_\<theta>_1 \<theta>.leg1_commutes
apply (intro C.commutative_squareI) by auto
have "C.commutative_square r0 ?u1 (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
proof
have 1: "r0 \<cdot> ?p1' = ?u1 \<cdot> \<theta>'.chine"
using \<theta>'.leg1_commutes Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite by simp
show "C.cospan r0 ?u1"
using ru.legs_form_cospan(1) by blast
show "C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
using \<beta>.chine_in_hom \<theta>'.chine_in_hom
by (metis "1" C.dom_comp C.in_homE C.prj1_simps(1) C.prj1_simps(2)
C.seqI Cod_\<theta>'_1 Dom_\<theta>'.leg_simps(3) Chn_\<beta> \<theta>'.leg1_commutes cospan')
show "C.dom r0 = C.cod (?p1' \<cdot> \<beta>.chine)"
using \<beta>.chine_in_hom
by (metis C.cod_comp C.prj1_simps(3)
\<open>C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
cospan' r.dom.apex_def r.chine_eq_apex r.chine_simps(2))
show "r0 \<cdot> ?p1' \<cdot> \<beta>.chine = ?u1 \<cdot> \<theta>'.chine \<cdot> \<beta>.chine"
using 1 \<beta>.chine_in_hom C.comp_assoc by metis
qed
have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1
C.comp_assoc C.pullback_commutes' r\<theta>.legs_form_cospan(1)
apply (intro C.commutative_squareI)
apply auto
by (metis C.comp_assoc Cod_\<theta>_1 \<theta>.leg1_commutes)
hence "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
using fw.leg1_composite by auto
have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1'] (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])"
using C.tuple_is_extensional Chn_r\<theta>'_eq r\<theta>'.chine_simps(1) fw' by force
have "C.commutative_square ra ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0"
using C.pullback_commutes' gw.legs_form_cospan(1) rfw.prj_simps(2) C.comp_assoc
C.comp_cod_arr
apply (intro C.commutative_squareI) by auto
have "C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0"
using cospan'
apply (intro C.commutative_squareI)
apply simp_all
by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
arrow_of_spans_data.select_convs(2) rfw'.prj_simps(3)
span_data.select_convs(1-2))
have "C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1 \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
proof -
have "C.arr rfw.chine_assoc"
by (metis C.seqE rfw.prj_chine_assoc(1) rfw.prj_simps(1))
thus ?thesis
using C.tuple_is_extensional rfw.chine_assoc_def by fastforce
qed
have "C.commutative_square r0 (r0 \<cdot> ?p1') rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>"
by (metis (no_types, lifting) C.not_arr_null C.seqE C.tuple_is_extensional
arrow_of_spans_data.select_convs(2) rfw'.chine_assoc_def
rfw'.prj_chine_assoc(1) rfw'.prj_simps(1) span_data.select_convs(1-2))
have "C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0"
using C.tuple_is_extensional Chn_\<rho>w_eq \<rho>w.chine_simps(1) by fastforce
have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')"
using C.tuple_is_extensional \<rho>w'.chine_composite \<rho>w'.chine_simps(1) by force
have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'"
using C.tuple_is_extensional Chn_\<rho>w'_eq \<rho>w'.chine_simps(1) by force
text \<open>
Now, derive the consequences of the equation:
\[
\<open>(r \<star> \<theta>) \<bullet> \<a>[r, ?f, w] \<bullet> (?\<rho> \<star> w) = (r \<star> \<theta>') \<bullet> \<a>[r, ?f, w'] \<bullet> (?\<rho> \<star> w') \<bullet> \<beta>\<close>
\]
The strategy is to expand and simplify the left and right hand side to tuple form,
then compose with projections and equate corresponding components.
We first work on the right-hand side.
\<close>
have R: "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
proof -
have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
proof -
have 1: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
using \<beta> \<rho>w' arfw' r\<theta>' by auto
have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) = Chn (T.composite_cell w' \<theta>') \<cdot> \<beta>.chine"
using 1 Chn_vcomp by blast
also have "... = (r\<theta>'.chine \<cdot> Chn (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))) \<cdot> \<beta>.chine"
proof -
have "seq (r \<star> \<theta>') (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))"
using 1 by blast
thus ?thesis
using 1 Chn_vcomp by presburger
qed
also have "... = (r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
proof -
have "seq \<a>[r, f, w'] (\<rho> \<star> w')"
using 1 by blast
thus ?thesis
using 1 Chn_vcomp by presburger
qed
finally show ?thesis
using C.comp_assoc by auto
qed
also have "... = \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
proof -
let ?LHS = "r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
let ?RHS = "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
proof (intro C.comp_in_homI)
show "\<guillemotleft>\<beta>.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
using Chn_\<beta> by simp
show "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
using Chn_\<rho>w' by simp
show "\<guillemotleft>Chn \<a>[r, f, w'] : Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C rfw'.chine\<guillemotright>"
using arfw'
by (metis (no_types, lifting) Chn_in_hom Cod_\<rho>_0
arrow_of_spans_data.simps(2) rf rf.leg0_composite rfw'.chine_composite(1)
span_data.select_convs(1) w'.cod_simps(3))
show "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
using Chn_r\<theta>' by auto
qed
have 2: "C.commutative_square r0 ?u1
(?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
by fact
have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
using 2 Chn_\<beta> r\<theta>'_cod_apex_eq
C.tuple_in_hom [of r0 ?u1 "?p1' \<cdot> \<beta>.chine" "\<theta>'.chine \<cdot> \<beta>.chine"]
by fastforce
show ?thesis
proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
show "C.cospan r0 ?u1"
using ru.legs_form_cospan(1) by blast
show "C.seq ru.prj\<^sub>1 ?LHS"
using LHS r\<theta>'_cod_apex_eq by auto
show "C.seq ru.prj\<^sub>1 ?RHS"
using RHS r\<theta>'_cod_apex_eq by auto
show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
proof -
have "ru.prj\<^sub>0 \<cdot> ?LHS =
(ru.prj\<^sub>0 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
using C.comp_assoc by simp
also have "... = ((\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']) \<cdot> Chn \<a>[r, f, w']) \<cdot>
\<rho>w'.chine \<cdot> \<beta>.chine"
using Chn_r\<theta>'_eq C.comp_assoc fw'
\<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
(\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
by simp
also have "... = \<theta>'.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1'] \<cdot> Chn \<a>[r, f, w']) \<cdot>
\<rho>w'.chine \<cdot> \<beta>.chine"
using C.comp_assoc by simp
also have "... = \<theta>'.chine \<cdot> (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine) \<cdot>
\<beta>.chine"
using ide_f hseq_rf hseq_char \<alpha>_ide C.comp_assoc
rfw'.chine_assoc_def fw'.leg1_composite C.prj_tuple(1)
\<open>C.commutative_square r0 (r0 \<cdot> ?p1')
rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>\<close>
by simp
also have "... = \<theta>'.chine \<cdot> \<beta>.chine"
proof -
have "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine = gw'.apex"
proof (intro C.prj_joint_monic
[of ?R ?w1' "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine"
gw'.apex])
show "C.cospan ?R ?w1'"
using fw'.legs_form_cospan(1) by simp
show "C.seq ?p1' (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine)"
proof (intro C.seqI' C.comp_in_homI)
show "\<guillemotleft>\<rho>w'.chine : Dom_\<rho>.leg0 \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
using \<rho>w'.chine_composite_in_hom by simp
show "\<guillemotleft>\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, w'.leg1\<rbrakk> rfw'.Prj\<^sub>0\<rangle> :
Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C ?R \<down>\<down> w'.leg1\<guillemotright>"
using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close>
C.tuple_in_hom [of ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0]
rf rf.leg0_composite
by auto
show "\<guillemotleft>?p1' : ?R \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C f.apex\<guillemotright>"
using fw'.prj_in_hom(1) by auto
qed
show "C.seq ?p1' gw'.apex"
using gw'.dom.apex_def gw'.leg0_composite fw'.prj_in_hom by auto
show "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
?p0' \<cdot> gw'.apex"
proof -
have "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
(?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
using C.comp_assoc by simp
also have "... = rfw'.Prj\<^sub>0 \<cdot> \<rho>w'.chine"
using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by auto
also have
"... = \<p>\<^sub>0[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
using \<rho>w'.chine_composite Dom_\<rho>_0 Cod_\<rho>_0 C.comp_cod_arr by simp
also have "... = w'.chine \<cdot> ?p0'"
using \<open>C.commutative_square k0 ?w1'
(\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
by simp
also have "... = ?p0' \<cdot> gw'.apex"
using cospan C.comp_cod_arr C.comp_arr_dom gw'.chine_is_identity
gw'.chine_eq_apex gw'.chine_composite fw'.prj_in_hom
by auto
finally show ?thesis by simp
qed
show "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
?p1' \<cdot> gw'.apex"
proof -
have "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
(?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
using C.comp_assoc by simp
also have "... = rfw'.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w'.chine"
using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by simp
also have
"... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
using \<rho>w'.chine_composite Cod_\<rho>_0 C.comp_assoc C.comp_cod_arr
by simp
also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1'"
using \<open>C.commutative_square k0 ?w1'
(\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
by simp
also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1'"
using C.comp_assoc by metis
also have "... = ?p1'"
using \<rho>.leg0_commutes C.comp_cod_arr cospan' by simp
also have "... = ?p1' \<cdot> gw'.apex"
using C.comp_arr_dom cospan' gw'.chine_eq_apex gw'.chine_composite
by simp
finally show ?thesis by simp
qed
qed
thus ?thesis
using Chn_\<beta> C.comp_cod_arr gw'.apex_composite by auto
qed
also have "... = \<p>\<^sub>0[r0, ?u1] \<cdot> ?RHS"
using RHS 2 C.prj_tuple [of r0 ?u1] by simp
finally show ?thesis by simp
qed
show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
proof -
have "ru.prj\<^sub>1 \<cdot> ?LHS =
(ru.prj\<^sub>1 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
using C.comp_assoc by simp
also have "... = \<p>\<^sub>1[r0, fw'.leg1] \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
using Chn_r\<theta>' Chn_r\<theta>'_eq fw'
\<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
(\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
by simp
also have "... = (rfw'.Prj\<^sub>1 \<cdot> rfw'.chine_assoc) \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
using ide_f ide_w' hseq_rf hseq_char \<alpha>_ide fw'.leg1_composite C.comp_assoc
by auto
also have "... = (rfw'.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
using rfw'.prj_chine_assoc C.comp_assoc by simp
also have "... = ((k1 \<cdot> \<p>\<^sub>1[k0, ?w1']) \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
using C.comp_cod_arr by simp
also have "... = (k1 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
using C.comp_assoc by simp
also have "... = (k1 \<cdot> \<rho>.chine \<cdot> ?p1') \<cdot> \<beta>.chine"
using Chn_\<rho>w'_eq Dom_\<rho>_0 Cod_\<rho>_0
\<open>C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'\<close>
by simp
also have "... = (k1 \<cdot> \<rho>.chine) \<cdot> ?p1' \<cdot> \<beta>.chine"
using C.comp_assoc by metis
also have "... = (?R \<cdot> ?p1') \<cdot> \<beta>.chine"
using C.comp_assoc by simp
also have "... = ?p1' \<cdot> \<beta>.chine"
using C.comp_cod_arr C.prj1_in_hom [of ?R ?w1'] cospan' by simp
also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
using RHS 2 by simp
finally show ?thesis by simp
qed
qed
qed
finally show ?thesis by simp
qed
text \<open>
Now we work on the left-hand side.
\<close>
have L: "Chn (T.composite_cell w \<theta>) = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
proof -
have "Chn (T.composite_cell w \<theta>) = r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
using Chn_vcomp arfw C.comp_assoc by auto
moreover have "... = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
proof -
let ?LHS = "r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
let ?RHS = "\<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
have 2: "C.commutative_square r0 ?u1 ?p1 \<theta>.chine" by fact
have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
using Chn_r\<theta> Chn_\<rho>w rfw.chine_assoc_in_hom
by (metis (no_types, lifting) "8" Chn_in_hom Dom_\<rho>_0
arrow_of_spans_data.simps(2) calculation gw.chine_composite
r\<theta>_cod_apex_eq ru.chine_composite)
have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
using 2 C.tuple_in_hom [of r0 ?u1 "?p1" \<theta>.chine] cospan r\<theta>_cod_apex_eq
by simp
show ?thesis
proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
show "C.cospan r0 ?u1"
using ru.legs_form_cospan(1) by blast
show "C.seq ru.prj\<^sub>1 ?LHS"
using LHS r\<theta>_cod_apex_eq by auto
show "C.seq ru.prj\<^sub>1 ?RHS"
using RHS r\<theta>_cod_apex_eq by auto
show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
proof -
have "ru.prj\<^sub>0 \<cdot> ?LHS = (ru.prj\<^sub>0 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
using C.comp_assoc by simp
also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, f.leg1 \<cdot> fw.prj\<^sub>1]) \<cdot>
Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
using Chn_r\<theta>_eq Dom_\<theta>_1 Cod_\<theta>_1 fw.leg1_composite
\<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1]
(\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])\<close>
by simp
also have "... = \<theta>.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
using C.comp_assoc by simp
also have "... = \<theta>.chine \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
proof -
have "Chn \<a>[r, f, w] = rfw.chine_assoc"
using ide_f ide_w hseq_rf hseq_char \<alpha>_ide by auto
moreover have "\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> rfw.chine_assoc =
\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
using rfw.chine_assoc_def
\<open>C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1
\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>\<close>
by simp
ultimately show ?thesis by simp
qed
also have "... = \<theta>.chine \<cdot> (?R \<down>\<down> ?w1)"
proof -
have "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine = ?R \<down>\<down> ?w1"
proof (intro C.prj_joint_monic
[of ?R ?w1 "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
"?R \<down>\<down> ?w1"])
show "C.cospan ?R ?w1" by fact
show "C.seq ?p1 (\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine)"
proof -
have "C.seq rfw.Prj\<^sub>0\<^sub>1 \<rho>w.chine"
by (meson C.seqI' Chn_in_hom \<rho>w rfw.prj_in_hom(2)
\<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>)
thus ?thesis
using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>
by (metis (no_types) C.comp_assoc C.prj_tuple(2))
qed
show "C.seq ?p1 (?R \<down>\<down> ?w1)"
using gw.dom.apex_def gw.leg0_composite gw.prj_in_hom by auto
show "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
?p0 \<cdot> (?R \<down>\<down> ?w1)"
proof -
have "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
(?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
using C.comp_assoc by simp
also have "... = rfw.Prj\<^sub>0 \<cdot> \<rho>w.chine"
using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
also have "... = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
using Chn_\<rho>w_eq C.comp_cod_arr by simp
also have "... = ?p0"
using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close>
C.prj_tuple(1)
by blast
also have "... = ?p0 \<cdot> (?R \<down>\<down> ?w1)"
using C.comp_arr_dom gw.chine_eq_apex gw.chine_is_identity
by (metis C.arr_dom_iff_arr C.pbdom_def Dom_g gw.chine_composite
gw.chine_simps(1) span_data.select_convs(1))
finally show ?thesis by simp
qed
show "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
?p1 \<cdot> (?R \<down>\<down> ?w1)"
proof -
have "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
(?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
using C.comp_assoc by simp
also have "... = rfw.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w.chine"
using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
also have "... = (k0 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
using Chn_\<rho>w_eq C.comp_cod_arr by simp
also have "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
using C.comp_assoc by simp
also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1"
using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close> by simp
also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1"
using C.comp_assoc by metis
also have "... = ?p1 \<cdot> (?R \<down>\<down> ?w1)"
using C.comp_arr_dom C.comp_cod_arr cospan by simp
finally show ?thesis by blast
qed
qed
thus ?thesis by simp
qed
also have "... = \<theta>.chine"
using C.comp_arr_dom \<theta>.chine_in_hom gw.chine_eq_apex gw.chine_is_identity
Dom_\<theta>_0 Cod_\<theta>_0 Dom_\<theta>.apex_def Cod_\<theta>.apex_def
by (metis Dom_g \<theta>.chine_simps(1) \<theta>.chine_simps(2) gw.chine_composite
gw.dom.apex_def gw.leg0_composite span_data.select_convs(1))
also have "... = ru.prj\<^sub>0 \<cdot> ?RHS"
using 2 by simp
finally show ?thesis by blast
qed
show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
proof -
have "ru.prj\<^sub>1 \<cdot> ?LHS = (ru.prj\<^sub>1 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
using C.comp_assoc by simp
also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?p1]) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
proof -
have "r\<theta>.chine \<noteq> C.null \<Longrightarrow>
\<p>\<^sub>1[r.cod.leg0, Cod_\<theta>.leg1] \<cdot> r\<theta>.chine =
r.chine \<cdot> \<p>\<^sub>1[r0, Dom_\<theta>.leg1]"
by (metis (lifting) C.prj_tuple(2) C.tuple_is_extensional r.cod_simps(2)
r\<theta>.chine_composite)
thus ?thesis
using Cod_\<theta>_1 Dom_\<theta>_1 r\<theta>.chine_simps(1) fw by fastforce
qed
also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
using C.comp_assoc fw.leg1_composite by simp
also have "... = r.chine \<cdot> rfw.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w.chine"
using ide_f ide_w hseq_rf hseq_char \<alpha>_ide
rfw.prj_chine_assoc(1)
by auto
also have "... = r.chine \<cdot> k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<rho>w.chine"
using C.comp_cod_arr C.comp_assoc by simp
also have "... = r.chine \<cdot> k1 \<cdot> \<rho>.chine \<cdot> \<p>\<^sub>1[Dom_\<rho>.leg0, ?w1]"
using Chn_\<rho>w_eq
\<open>C.commutative_square k0 ?w1
(\<rho>.chine \<cdot> \<p>\<^sub>1[ra, w.leg1]) \<p>\<^sub>0[ra, w.leg1]\<close>
by auto
also have "... = r.chine \<cdot> (k1 \<cdot> \<rho>.chine) \<cdot> ?p1"
using C.comp_assoc Dom_\<rho>_0 by metis
also have "... = r.chine \<cdot> ra \<cdot> ?p1"
by simp
also have "... = r.chine \<cdot> ?p1"
using C.comp_cod_arr
by (metis C.comp_assoc r.cod_simps(1) r.chine_eq_apex r.chine_simps(1)
r.chine_simps(3))
also have "... = ?p1"
using C.comp_cod_arr r.chine_eq_apex r.chine_is_identity
by (metis 2 C.commutative_squareE r.dom.apex_def)
also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
using 2 by simp
finally show ?thesis by simp
qed
qed
qed
ultimately show ?thesis
by simp
qed
text \<open>
This is the main point: the equation E boils down to the following:
\[
\<open>?p1' \<cdot> \<beta>.chine = ?p1 \<and> \<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine\<close>
\]
The first equation gets us close to what we need, but we still need
\<open>?p1 \<cdot> C.inv ?p0 = ?w1\<close>, which follows from the fact that ?p0 is the
pullback of ?R.
\<close>
have *: "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle> = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
using L R E by simp
have **: "?p1' \<cdot> \<beta>.chine = ?p1"
by (metis "*" C.in_homE C.not_arr_null C.prj_tuple(2) C.tuple_in_hom
C.tuple_is_extensional
\<open>C.commutative_square r0 u.leg1
(\<p>\<^sub>1[ra, w'.leg1] \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>)
have ***: "\<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine"
by (metis "*" C.prj_tuple(1) \<open>C.commutative_square r0 ?u1
(?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
\<open>C.commutative_square r0 ?u1 ?p1 \<theta>.chine\<close>)
text \<open>
CKS say to take \<open>\<gamma> = \<beta>\<close>, but obviously this cannot work as
literally described, because \<open>\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>\<close>, whereas we must have
\<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>. Instead, we have to define \<open>\<gamma>\<close> by transporting \<open>\<beta>\<close> along the
projections from \<open>?R \<down>\<down> ?w1\<close> to \<open>?W\<close> and \<open>?R \<down>\<down> ?w1'\<close> to \<open>?W'\<close>.
These are isomorphisms by virtue of their being pullbacks of identities,
but they are not themselves necessarily identities.
Specifically, we take \<open>Chn \<gamma> = ?p0' \<cdot> Chn \<beta> \<cdot> C.inv ?p0\<close>.
\<close>
let ?\<gamma> = "\<lparr>Chn = ?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0, Dom = Dom w, Cod = Cod w'\<rparr>"
interpret Dom_\<gamma>: span_in_category C \<open>Dom ?\<gamma>\<close>
using w.dom.span_in_category_axioms by simp
interpret Cod_\<gamma>: span_in_category C \<open>Cod ?\<gamma>\<close>
using w'.cod.span_in_category_axioms by simp
text \<open>
It has to be shown that \<open>\<gamma>\<close> is an arrow of spans.
\<close>
interpret \<gamma>: arrow_of_spans C ?\<gamma>
proof
show "\<guillemotleft>Chn ?\<gamma> : Dom_\<gamma>.apex \<rightarrow>\<^sub>C Cod_\<gamma>.apex\<guillemotright>"
proof -
have "\<guillemotleft>Chn \<beta>: gw.apex \<rightarrow>\<^sub>C gw'.apex\<guillemotright>"
using Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
moreover have "\<guillemotleft>?p0' : gw'.apex \<rightarrow>\<^sub>C w'.apex\<guillemotright>"
using cospan' hseq_gw' hseq_char hcomp_def gw'.dom.apex_def w'.dom.apex_def
by auto
moreover have "\<guillemotleft>C.inv ?p0 : w.apex \<rightarrow>\<^sub>C gw.apex\<guillemotright>"
using cospan hseq_gw hseq_char hcomp_def gw.dom.apex_def w.dom.apex_def
C.iso_pullback_ide
by auto
ultimately show ?thesis
using Dom_\<gamma>.apex_def Cod_\<gamma>.apex_def by auto
qed
text \<open>
The commutativity property for the ``input leg'' follows directly from that
for \<open>\<beta>\<close>.
\<close>
show "Cod_\<gamma>.leg0 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg0"
using C.comp_assoc C.comp_arr_dom cospan C.iso_pullback_ide C.comp_arr_inv'
by (metis C.invert_side_of_triangle(2) Dom_\<beta>.leg_simps(1) Dom_\<beta>_eq \<beta>0
arrow_of_spans_data.select_convs(1,3) arrow_of_spans_data.simps(2)
r.dom.ide_apex span_data.select_convs(1) w'.cod_simps(2))
text \<open>
The commutativity property for the ``output leg'' is a bit more subtle.
\<close>
show "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg1"
proof -
have "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = ((?w1' \<cdot> ?p0') \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
using C.comp_assoc by simp
also have "... = ((?R \<cdot> ?p1') \<cdot> Chn \<beta>) \<cdot> C.inv ?p0"
using cospan' C.pullback_commutes [of ?R ?w1'] by auto
also have "... = (?p1' \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
using cospan' C.comp_cod_arr by simp
also have "... = ?p1 \<cdot> C.inv ?p0"
using ** by simp
also have "... = ?w1"
text \<open>
Sledgehammer found this at a time when I was still struggling to
understand what was going on.
\<close>
by (metis C.comp_cod_arr C.invert_side_of_triangle(2) C.iso_pullback_ide
C.prj1_simps(1,3) C.pullback_commutes' cospan r.dom.ide_apex
r.chine_eq_apex r.chine_simps(2))
also have "... = Dom_\<gamma>.leg1" by auto
finally show ?thesis by simp
qed
qed
text \<open>
What remains to be shown is that \<open>\<gamma>\<close> is unique with the properties asserted
by \<open>T2\<close>; \emph{i.e.} \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)\<close>.
CKS' assertion that the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>
does not really seem to be true. The reason \<open>\<gamma>\<close> is unique is because it is
obtained by transporting \<open>\<beta>\<close> along isomorphisms.
\<close>
have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright>"
using \<gamma>.arrow_of_spans_axioms arr_char dom_char cod_char by auto
have hseq_f\<gamma>: "hseq f ?\<gamma>"
using \<gamma> src_def trg_def arrI fw.composable hseqI' rf.are_arrows(2) by auto
have hseq_g\<gamma>: "hseq g ?\<gamma>"
using \<gamma> src_def trg_def fw.composable gw.are_arrows(1) hseqI' src_f by auto
interpret f\<gamma>: two_composable_arrows_of_spans C prj0 prj1 f ?\<gamma>
using hseq_f\<gamma> hseq_char by (unfold_locales, simp)
interpret f\<gamma>: arrow_of_spans C \<open>f \<star> ?\<gamma>\<close>
using f\<gamma>.composite_is_arrow arr_char by simp
interpret g\<gamma>: two_composable_arrows_of_spans C prj0 prj1 g ?\<gamma>
using hseq_g\<gamma> hseq_char by (unfold_locales, simp)
interpret g\<gamma>: arrow_of_spans C \<open>g \<star> ?\<gamma>\<close>
using g\<gamma>.composite_is_arrow arr_char by simp
have Chn_g\<gamma>: "Chn (g \<star> ?\<gamma>) = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> \<beta>.chine\<rangle>"
proof -
have "Chn (g \<star> ?\<gamma>) = \<langle>?R \<cdot> ?p1 \<lbrakk>?R, ?w1'\<rbrakk> (?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0\<rangle>"
using g\<gamma>.chine_composite by simp
also have "... = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> (?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0\<rangle>"
using C.comp_cod_arr cospan by simp
also have "... = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> \<beta>.chine\<rangle>"
proof -
have "(?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0 = ?p0' \<cdot> \<beta>.chine"
using C.comp_assoc C.iso_pullback_ide [of ?R ?w1] C.comp_inv_arr
C.comp_arr_dom Chn_\<beta>
by (metis C.comp_inv_arr' C.in_homE C.pbdom_def cospan r.dom.ide_apex)
thus ?thesis by simp
qed
ultimately show ?thesis by simp
qed
have Chn_\<beta>_eq: "\<beta>.chine = Chn (g \<star> ?\<gamma>)"
proof -
have "Chn (g \<star> ?\<gamma>) = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> Chn \<beta>\<rangle>"
using Chn_g\<gamma> by simp
also have "... = \<beta>.chine"
text \<open>Here was another score by sledgehammer while I was still trying
to understand it.\<close>
using ** C.prj_joint_monic
by (metis C.prj1_simps(1) C.tuple_prj cospan cospan')
finally show ?thesis by simp
qed
have \<beta>_eq_g\<gamma>: "\<beta> = g \<star> ?\<gamma>"
proof (intro arr_eqI)
show "par \<beta> (g \<star> ?\<gamma>)"
proof -
have "\<guillemotleft>g \<star> ?\<gamma> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
using ide_g \<gamma> T.leg1_simps(3)
by (intro hcomp_in_vhom, auto)
thus ?thesis
using \<beta> by (elim in_homE, auto)
qed
show "\<beta>.chine = Chn (g \<star> ?\<gamma>)"
using Chn_\<beta>_eq by simp
qed
moreover have "\<theta> = \<theta>' \<bullet> (f \<star> ?\<gamma>)"
proof (intro arr_eqI)
have f\<gamma>: "\<guillemotleft>f \<star> ?\<gamma> : f \<star> w \<Rightarrow> f \<star> w'\<guillemotright>"
using \<gamma> ide_f by auto
show par: "par \<theta> (\<theta>' \<bullet> (f \<star> ?\<gamma>))"
using \<theta> \<theta>' f\<gamma> by (elim in_homE, auto)
show "\<theta>.chine = Chn (\<theta>' \<bullet> (f \<star> ?\<gamma>))"
using par "***" Chn_vcomp calculation f\<gamma>.chine_composite g\<gamma>.chine_composite
by auto
qed
ultimately show 2: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> ?\<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> ?\<gamma>)"
using \<gamma> by simp
show "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>') \<Longrightarrow> \<gamma>' = ?\<gamma>"
proof -
fix \<gamma>'
assume 1: "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>')"
interpret \<gamma>': arrow_of_spans C \<gamma>'
using 1 arr_char by auto
have hseq_g\<gamma>': \<open>hseq g \<gamma>'\<close>
using 1 \<beta> by auto
interpret g\<gamma>': two_composable_arrows_of_spans C prj0 prj1 g \<gamma>'
using hseq_g\<gamma>' hseq_char by (unfold_locales, auto)
interpret g\<gamma>': arrow_of_spans C \<open>g \<star> \<gamma>'\<close>
using g\<gamma>'.composite_is_arrow arr_char by simp
show "\<gamma>' = ?\<gamma>"
proof (intro arr_eqI)
show par: "par \<gamma>' ?\<gamma>"
using 1 \<gamma> by fastforce
show "\<gamma>'.chine = \<gamma>.chine"
proof -
have "C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)"
proof
show "C.cospan ?R ?w1'" by fact
show 3: "C.span (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)"
proof (intro conjI)
show "C.seq g.chine ?p1"
using cospan by auto
show "C.seq \<gamma>'.chine ?p0"
using cospan 2 par arrow_of_spans_data.simps(1)
dom_char in_homE w.chine_eq_apex
by auto
thus "C.dom (g.chine \<cdot> ?p1) = C.dom (\<gamma>'.chine \<cdot> ?p0)"
using g.chine_eq_apex cospan by simp
qed
show "C.dom ra = C.cod (g.chine \<cdot> ?p1)"
using cospan by auto
show "?R \<cdot> g.chine \<cdot> ?p1 = ?w1' \<cdot> \<gamma>'.chine \<cdot> ?p0"
proof -
have "?w1' \<cdot> \<gamma>'.chine \<cdot> ?p0 = (?w1' \<cdot> \<gamma>'.chine) \<cdot> ?p0"
using C.comp_assoc by simp
moreover have "... = ?w1 \<cdot> ?p0"
using 1 \<gamma>'.leg1_commutes dom_char cod_char by auto
also have "... = ?R \<cdot> ?p1"
using cospan C.pullback_commutes [of ra ?w1] by auto
also have "... = ?R \<cdot> g.chine \<cdot> ?p1"
using 3 C.comp_cod_arr g.chine_is_identity g.chine_eq_apex g.dom.apex_def
by auto
finally show ?thesis by auto
qed
qed
have "C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)"
proof
show "C.cospan ?R ?w1'" by fact
show 3: "C.span (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)"
using cospan \<gamma>.chine_in_hom by auto
show "C.dom ?R = C.cod (g.chine \<cdot> ?p1)"
using cospan by auto
show "?R \<cdot> g.chine \<cdot> ?p1 = ?w1' \<cdot> \<gamma>.chine \<cdot> ?p0"
proof -
have "?w1' \<cdot> \<gamma>.chine \<cdot> ?p0 = (?w1' \<cdot> \<gamma>.chine) \<cdot> ?p0"
using C.comp_assoc by simp
moreover have "... = ?w1 \<cdot> ?p0"
using 1 \<gamma>.leg1_commutes dom_char cod_char by auto
also have "... = ?R \<cdot> ?p1"
using cospan C.pullback_commutes [of ra ?w1] by auto
also have "... = ?R \<cdot> g.chine \<cdot> ?p1"
using 3 C.comp_cod_arr g.chine_is_identity g.chine_eq_apex g.dom.apex_def
by auto
finally show ?thesis by auto
qed
qed
have "\<gamma>'.chine \<cdot> ?p0 = \<gamma>.chine \<cdot> ?p0"
proof -
have "\<gamma>'.chine \<cdot> ?p0 = ?p0' \<cdot> g\<gamma>'.chine"
using 1 dom_char cod_char g\<gamma>'.chine_composite
\<open>C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)\<close>
by auto
also have "... = ?p0' \<cdot> \<beta>.chine"
using 1 by simp
also have "... = ?p0' \<cdot> g\<gamma>.chine"
using Chn_\<beta>_eq by simp
also have "... = \<gamma>.chine \<cdot> ?p0"
using g\<gamma>.chine_composite
\<open>C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)\<close>
by simp
finally show ?thesis by simp
qed
thus ?thesis
using C.iso_pullback_ide C.iso_is_retraction C.retraction_is_epi
C.epiE [of "?p0" \<gamma>'.chine \<gamma>.chine] cospan \<gamma>.chine_in_hom
\<gamma>'.chine_in_hom
by auto
qed
qed
qed
qed
qed
qed
qed
qed
end
context span_bicategory
begin
interpretation chosen_right_adjoints vcomp hcomp assoc unit src trg ..
notation some_right_adjoint ("_\<^sup>*" [1000] 1000) (* TODO: Why is this needed? *)
notation isomorphic (infix "\<cong>" 50)
text \<open>
\<open>Span(C)\<close> is a bicategory of spans.
\<close>
lemma is_bicategory_of_spans:
shows "bicategory_of_spans vcomp hcomp assoc unit src trg"
proof
text \<open>
Every 1-cell \<open>r\<close> is isomorphic to the composition of a map and the right adjoint
of a map. The proof is to obtain a tabulation of \<open>r\<close> as a span of maps \<open>(f, g)\<close>
and then observe that \<open>r\<close> is isomorphic to \<open>g \<star> f\<^sup>*\<close>.
\<close>
show "\<And>r. ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> r \<cong> g \<star> f\<^sup>*"
proof -
fix r
assume r: "ide r"
interpret r: identity_arrow_of_spans C r
using r ide_char' by auto
interpret r: identity_arrow_in_span_bicategory C prj0 prj1 r ..
have \<rho>: "tabulation (\<bullet>) (\<star>) assoc unit src trg r r.\<rho> r.f r.g \<and>
is_left_adjoint r.f \<and> is_left_adjoint r.g"
using r r.has_tabulation by blast
interpret \<rho>: tabulation vcomp hcomp assoc unit src trg r r.\<rho> r.f r.g
using \<rho> by fast
have 1: "r \<cong> r.g \<star> r.f\<^sup>*"
using \<rho> \<rho>.yields_isomorphic_representation' \<rho>.T0.is_map
left_adjoint_extends_to_adjoint_pair
isomorphic_def [of "r.g \<star> r.f\<^sup>*" r] isomorphic_symmetric
by auto
thus "\<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> r \<cong> g \<star> f\<^sup>*"
using \<rho> by blast
qed
text \<open>
Every span of maps extends to a tabulation.
\<close>
show "\<And>f g. \<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk> \<Longrightarrow>
\<exists>r \<rho>. tabulation (\<bullet>) (\<star>) assoc unit src trg r \<rho> f g"
proof -
text \<open>
The proof idea is as follows: Let maps \<open>f = (f\<^sub>1, f\<^sub>0)\<close> and \<open>g = (g\<^sub>1, g\<^sub>0)\<close> be given.
Let \<open>f' = (f\<^sub>1 \<cdot> C.inv f\<^sub>0, C.cod f\<^sub>0)\<close> and \<open>g' = (g\<^sub>1 \<cdot> C.inv g\<^sub>0, C.cod g\<^sub>0)\<close>;
then \<open>f'\<close> and \<open>g'\<close> are maps isomorphic to \<open>f\<close> and \<open>g\<close>, respectively.
By a previous result, \<open>f'\<close> and \<open>g'\<close> extend to a tabulation \<open>(f', \<tau>, g')\<close> of
\<open>r = (f\<^sub>1 \<cdot> C.inv f\<^sub>0, g\<^sub>1 \<cdot> C.inv g\<^sub>0)\<close>.
Compose with isomorphisms \<open>\<guillemotleft>\<phi> : f' \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>\<close> to obtain
\<open>(f, (r \<star> \<phi>) \<cdot> \<tau> \<cdot> \<psi>, g)\<close> and show it must also be a tabulation.
\<close>
fix f g
assume f: "is_left_adjoint f"
assume g: "is_left_adjoint g"
assume fg: "src f = src g"
show "\<exists>r \<rho>. tabulation (\<bullet>) (\<star>) assoc unit src trg r \<rho> f g"
proof -
text \<open>We have to unpack the hypotheses to get information about f and g.\<close>
obtain f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f
where ff\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f"
using f adjoint_pair_def by auto
interpret ff\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f
using ff\<^sub>a by simp
interpret f: arrow_of_spans C f
using ide_char [of f] by simp
interpret f: identity_arrow_of_spans C f
using ide_char [of f] by (unfold_locales, auto)
obtain g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g
where G: "adjunction_in_bicategory vcomp hcomp assoc unit src trg g g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g"
using g adjoint_pair_def by auto
interpret gg\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg g g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g
using G by simp
interpret g: arrow_of_spans C g
using ide_char [of g] by simp
interpret g: identity_arrow_of_spans C g
using ide_char [of g] by (unfold_locales, auto)
let ?f' = "mkIde (C.cod f.leg0) (f.dom.leg1 \<cdot> C.inv f.leg0)"
have f': "ide ?f'"
proof -
have "C.span (C.cod f.leg0) (f.leg1 \<cdot> C.inv f.leg0)"
using f is_left_adjoint_char by auto
thus ?thesis
using ide_mkIde by blast
qed
interpret f': arrow_of_spans C ?f'
using f' ide_char by blast
interpret f': identity_arrow_of_spans C ?f'
using f' ide_char by (unfold_locales, auto)
let ?g' = "mkIde (C.cod g.leg0) (g.dom.leg1 \<cdot> C.inv g.leg0)"
have g': "ide ?g'"
proof -
have "C.span (C.cod g.leg0) (g.leg1 \<cdot> C.inv g.leg0)"
using g is_left_adjoint_char by auto
thus ?thesis
using ide_mkIde by blast
qed
interpret g': arrow_of_spans C ?g'
using g' ide_char by blast
interpret g': identity_arrow_of_spans C ?g'
using g' ide_char by (unfold_locales, auto)
let ?r = "mkIde (f'.leg1) (g'.leg1)"
have r: "ide ?r"
proof -
have "C.span (f'.leg1) (g'.leg1)"
using f g fg src_def is_left_adjoint_char by simp
thus ?thesis
using ide_mkIde by blast
qed
interpret r: arrow_of_spans C ?r
using r ide_char by blast
interpret r: identity_arrow_of_spans C ?r
using r ide_char by (unfold_locales, auto)
interpret r: identity_arrow_in_span_bicategory C prj0 prj1 ?r ..
have "r.f = ?f'"
using f r.chine_eq_apex is_left_adjoint_char by auto
have "r.g = ?g'"
using f r.chine_eq_apex fg src_def is_left_adjoint_char by simp
interpret \<rho>: tabulation \<open>(\<bullet>)\<close> \<open>(\<star>)\<close> assoc unit src trg ?r r.\<rho> r.f r.g
using r.has_tabulation by simp
have \<rho>_eq: "r.\<rho> = \<lparr>Chn = \<langle>C.cod f.leg0 \<lbrakk>f'.leg1, f'.leg1\<rbrakk> C.cod f.leg0\<rangle>,
Dom = \<lparr>Leg0 = C.cod f.leg0, Leg1 = g'.leg1\<rparr>,
Cod = \<lparr>Leg0 = \<p>\<^sub>0[f'.leg1, f'.leg1],
Leg1 = g'.leg1 \<cdot> \<p>\<^sub>1[f'.leg1, f'.leg1]\<rparr>\<rparr>"
using \<open>r.f = ?f'\<close> by auto
text \<open>Obtain the isomorphism from \<open>f'\<close> to \<open>f\<close>.\<close>
let ?\<phi> = "\<lparr>Chn = C.inv f.leg0, Dom = Dom ?f', Cod = Dom f\<rparr>"
interpret Dom_\<phi>: span_in_category C
\<open>Dom \<lparr>Chn = C.inv f.leg0,
Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
Cod = Dom f\<rparr>\<close>
using f'.dom.span_in_category_axioms by simp
interpret Cod_\<phi>: span_in_category C
\<open>Cod \<lparr>Chn = C.inv f.leg0,
Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
Cod = Dom f\<rparr>\<close>
using f.dom.span_in_category_axioms by simp
interpret \<phi>: arrow_of_spans C ?\<phi>
proof
show "\<guillemotleft>Chn \<lparr>Chn = C.inv f.leg0,
Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
Cod = Dom f\<rparr> : Dom_\<phi>.apex \<rightarrow>\<^sub>C Cod_\<phi>.apex\<guillemotright>"
using f f.dom.apex_def f'.dom.apex_def is_left_adjoint_char by auto
show "Cod_\<phi>.leg0 \<cdot> Chn \<lparr>Chn = C.inv f.leg0,
Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
Cod = Dom f\<rparr> =
Dom_\<phi>.leg0"
using f f.dom.apex_def is_left_adjoint_char C.comp_arr_inv C.inv_is_inverse
by simp
show "Cod_\<phi>.leg1 \<cdot> Chn \<lparr>Chn = C.inv f.leg0,
Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
Cod = Dom f\<rparr> =
Dom_\<phi>.leg1"
by simp
qed
have \<phi>: "\<guillemotleft>?\<phi> : ?f' \<Rightarrow> f\<guillemotright> \<and> iso ?\<phi>"
using f is_left_adjoint_char iso_char arr_char dom_char cod_char
\<phi>.arrow_of_spans_axioms C.iso_inv_iso f'.dom.apex_def f.dom.apex_def
by auto
text \<open>
Obtain the isomorphism from \<open>g\<close> to \<open>g'\<close>.
Recall: \<open>g' = mkIde (C.cod g.leg0) (g.dom.leg1 \<cdot> C.inv g.leg0)\<close>.
The isomorphism is given by \<open>g.leg0\<close>.
\<close>
let ?\<psi> = "\<lparr>Chn = g.leg0, Dom = Dom g, Cod = Dom ?g'\<rparr>"
interpret Dom_\<psi>: span_in_category C
\<open>Dom \<lparr>Chn = g.leg0,
Dom = Dom g,
Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr>\<close>
using g.dom.span_in_category_axioms by simp
interpret Cod_\<psi>: span_in_category C
\<open>Cod \<lparr>Chn = g.leg0,
Dom = Dom g,
Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr>\<close>
using g'.dom.span_in_category_axioms by simp
interpret \<psi>: arrow_of_spans C ?\<psi>
proof
show "\<guillemotleft>Chn \<lparr>Chn = g.leg0,
Dom = Dom g,
Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> :
Dom_\<psi>.apex \<rightarrow>\<^sub>C Cod_\<psi>.apex\<guillemotright>"
using g g.dom.apex_def g'.dom.apex_def is_left_adjoint_char by auto
show "Cod_\<psi>.leg0 \<cdot> Chn \<lparr>Chn = g.leg0,
Dom = Dom g,
Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> =
Dom_\<psi>.leg0"
using C.comp_cod_arr by simp
show "Cod_\<psi>.leg1 \<cdot> Chn \<lparr>Chn = g.leg0,
Dom = Dom g,
Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> =
Dom_\<psi>.leg1"
using g g.dom.apex_def is_left_adjoint_char C.comp_inv_arr C.inv_is_inverse
C.comp_assoc C.comp_arr_dom
by simp
qed
have \<psi>: "\<guillemotleft>?\<psi> : g \<Rightarrow> ?g'\<guillemotright> \<and> iso ?\<psi>"
using g is_left_adjoint_char iso_char arr_char dom_char cod_char
\<psi>.arrow_of_spans_axioms C.iso_inv_iso g.dom.apex_def g'.dom.apex_def
by auto
have \<rho>\<psi>: "tabulation (\<bullet>) (\<star>) assoc unit src trg ?r (r.\<rho> \<bullet> ?\<psi>) r.f g"
using \<psi> `r.g = ?g'` iso_inv_iso r.has_tabulation \<rho>.preserved_by_output_iso by simp
interpret \<tau>\<psi>: tabulation vcomp hcomp assoc unit src trg ?r \<open>r.\<rho> \<bullet> ?\<psi>\<close> r.f g
using \<rho>\<psi> by auto
have "tabulation (\<bullet>) (\<star>) assoc unit src trg ?r ((?r \<star> ?\<phi>) \<bullet> r.\<rho> \<bullet> ?\<psi>) f g"
using \<phi> `r.f = ?f'` \<tau>\<psi>.preserved_by_input_iso [of ?\<phi> f] by argo
thus ?thesis by auto
qed
qed
text \<open>The sub-bicategory of maps is locally essentially discrete.\<close>
show "\<And>f f' \<mu> \<mu>'. \<lbrakk> is_left_adjoint f; is_left_adjoint f'; \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright> \<rbrakk>
\<Longrightarrow> iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
proof -
fix f f' \<mu> \<mu>'
assume f: "is_left_adjoint f" and f': "is_left_adjoint f'"
assume \<mu>: "\<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>" and \<mu>': "\<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright>"
obtain f\<^sub>a \<eta> \<epsilon>
where f\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta> \<epsilon>"
using f adjoint_pair_def by auto
obtain f'\<^sub>a \<eta>' \<epsilon>'
where f'\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f' f'\<^sub>a \<eta>' \<epsilon>'"
using f' adjoint_pair_def adjunction_def by auto
interpret f\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta> \<epsilon>
using f\<^sub>a by simp
interpret f'\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f' f'\<^sub>a \<eta>' \<epsilon>'
using f'\<^sub>a by simp
interpret f: identity_arrow_of_spans C f
using ide_char' [of f] by simp
interpret f': identity_arrow_of_spans C f'
using ide_char' [of f'] by simp
interpret \<mu>: arrow_of_spans C \<mu> using \<mu> arr_char by auto
interpret \<mu>': arrow_of_spans C \<mu>' using \<mu>' arr_char by auto
have 1: "C.iso f.leg0 \<and> C.iso f'.leg0"
using f f' is_left_adjoint_char by simp
have 2: "\<mu>.chine = C.inv f'.leg0 \<cdot> f.leg0"
using \<mu> 1 dom_char cod_char \<mu>.leg0_commutes C.invert_side_of_triangle by auto
moreover have "\<mu>'.chine = C.inv f'.leg0 \<cdot> f.leg0"
using \<mu>' 1 dom_char cod_char \<mu>'.leg0_commutes C.invert_side_of_triangle by auto
ultimately have 3: "\<mu>.chine = \<mu>'.chine" by simp
have "iso \<mu>"
using 1 2 C.isos_compose C.iso_inv_iso \<mu> dom_char cod_char
iso_char arr_char \<mu>.arrow_of_spans_axioms
by auto
hence "iso \<mu>'"
using 3 iso_char arr_char \<mu>'.arrow_of_spans_axioms by simp
moreover have "\<mu> = \<mu>'"
using 3 \<mu> \<mu>' dom_char cod_char by fastforce
ultimately show "iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
by simp
qed
qed
text \<open>
We can now prove the easier half of the main result (CKS Theorem 4):
If \<open>B\<close> is biequivalent to \<open>Span(C)\<close>, where \<open>C\<close> is a category with pullbacks,
then \<open>B\<close> is a bicategory of spans.
(Well, it is easier given that we have already done the work to show that the notion
``bicategory of spans'' is respected by equivalence of bicategories.)
\<close>
theorem equivalent_implies_bicategory_of_spans:
assumes "equivalent_bicategories vcomp hcomp assoc unit src trg V\<^sub>1 H\<^sub>1 \<a>\<^sub>1 \<i>\<^sub>1 src\<^sub>1 trg\<^sub>1"
shows "bicategory_of_spans V\<^sub>1 H\<^sub>1 \<a>\<^sub>1 \<i>\<^sub>1 src\<^sub>1 trg\<^sub>1"
using assms is_bicategory_of_spans bicategory_of_spans_respects_equivalence by blast
end
subsection "Properties of Bicategories of Spans"
text \<open>
We now develop consequences of the axioms for a bicategory of spans, in preparation for
proving the other half of the main result.
\<close>
context bicategory_of_spans
begin
notation isomorphic (infix "\<cong>" 50)
text \<open>
The following is a convenience version of \<open>BS2\<close> that gives us what we generally want:
given specified \<open>f, g\<close> obtain \<open>\<rho>\<close> that makes \<open>(f, \<rho>, g)\<close> a tabulation of \<open>g \<star> f\<^sup>*\<close>,
not a tabulation of some \<open>r\<close> isomorphic to \<open>g \<star> f\<^sup>*\<close>.
\<close>
lemma BS2':
assumes "is_left_adjoint f" and "is_left_adjoint g" and "src f = src g"
and "isomorphic (g \<star> f\<^sup>*) r"
shows "\<exists>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
proof -
have 1: "is_left_adjoint f \<and> is_left_adjoint g \<and> g \<star> f\<^sup>* \<cong> r"
using assms BS1 by simp
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
using 1 isomorphic_def by blast
obtain r' \<rho>' where \<rho>': "tabulation V H \<a> \<i> src trg r' \<rho>' f g"
using assms 1 BS2 by blast
interpret \<rho>': tabulation V H \<a> \<i> src trg r' \<rho>' f g
using \<rho>' by simp
let ?\<psi> = "\<rho>'.T0.trnr\<^sub>\<epsilon> r' \<rho>'"
have \<psi>: "\<guillemotleft>?\<psi> : g \<star> f\<^sup>* \<Rightarrow> r'\<guillemotright> \<and> iso ?\<psi>"
using \<rho>'.yields_isomorphic_representation by blast
have "\<guillemotleft>\<phi> \<cdot> inv ?\<psi> : r' \<Rightarrow> r\<guillemotright> \<and> iso (\<phi> \<cdot> inv ?\<psi>)"
using \<phi> \<psi> iso_inv_iso isos_compose inv_in_hom by blast
hence 3: "tabulation V H \<a> \<i> src trg r ((\<phi> \<cdot> inv ?\<psi> \<star> f) \<cdot> \<rho>') f g"
using \<rho>'.is_preserved_by_base_iso by blast
hence "\<exists>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
by blast
thus ?thesis
using someI_ex [of "\<lambda>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"] by simp
qed
text \<open>
The following observation is made by CKS near the beginning of the proof of Theorem 4:
If \<open>w\<close> is an arbitrary 1-cell, and \<open>g\<close> and \<open>g \<star> w\<close> are maps, then \<open>w\<close> is in fact a map.
It is applied frequently.
\<close>
lemma BS4:
assumes "is_left_adjoint g" and "ide w" and "is_left_adjoint (g \<star> w)"
shows "is_left_adjoint w"
proof -
text \<open>
CKS say: ``by (i) there are maps \<open>m, n\<close> with \<open>w \<cong> nm\<^sup>*\<close>, so, by (ii), we have two
tabulations \<open>(1, \<rho>, gw)\<close>, \<open>(m, \<sigma>, gn)\<close> of \<open>gw\<close>; since tabulations are unique
up to equivalence, \<open>m\<close> is invertible and \<open>w \<cong> nm\<^sup>*\<close> is a map.''
\<close>
have ex_\<rho>: "\<exists>\<rho>. tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
proof -
have "(g \<star> w) \<star> src w \<cong> g \<star> w"
by (metis assms(3) ideD(1) iso_runit isomorphic_def left_adjoint_is_ide
runit_in_hom(2) hcomp_simps(1))
moreover have "isomorphic ((g \<star> w) \<star> (src w)\<^sup>*) (g \<star> w)"
proof -
have "(g \<star> w) \<star> src (g \<star> w) \<cong> g \<star> w"
using calculation isomorphic_implies_ide(2) by auto
moreover have "isomorphic (src (g \<star> w)) (src w)\<^sup>*"
proof -
interpret src_w: map_in_bicategory V H \<a> \<i> src trg \<open>src w\<close>
using assms obj_is_self_adjoint by (unfold_locales, auto)
interpret src_w: adjunction_in_bicategory V H \<a> \<i> src trg
\<open>src w\<close> \<open>(src w)\<^sup>*\<close> src_w.\<eta> src_w.\<epsilon>
using src_w.is_map left_adjoint_extends_to_adjunction by simp
have "adjoint_pair (src w) (src w)"
using assms obj_is_self_adjoint by simp
moreover have "adjoint_pair (src w) (src w)\<^sup>*"
using adjoint_pair_def src_w.adjunction_in_bicategory_axioms by auto
ultimately have "src w \<cong> (src w)\<^sup>*"
using left_adjoint_determines_right_up_to_iso by simp
moreover have "src w = src (g \<star> w)"
using assms isomorphic_def hcomp_simps(1) left_adjoint_is_ide by simp
ultimately show ?thesis by simp
qed
moreover have "src (g \<star> w) = trg (src (g \<star> w))"
using assms left_adjoint_is_ide by simp
ultimately show ?thesis
using assms left_adjoint_is_ide isomorphic_transitive isomorphic_symmetric
hcomp_ide_isomorphic
by blast
qed
ultimately show ?thesis
using assms obj_is_self_adjoint
left_adjoint_is_ide BS2' [of "src w" "g \<star> w" "g \<star> w"]
by auto
qed
obtain \<rho> where \<rho>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
using ex_\<rho> by auto
obtain m n where mn: "is_left_adjoint m \<and> is_left_adjoint n \<and> isomorphic w (n \<star> m\<^sup>*)"
using assms BS1 [of w] by auto
have m\<^sub>a: "adjoint_pair m m\<^sup>* \<and> isomorphic w (n \<star> m\<^sup>*)"
using mn adjoint_pair_def left_adjoint_extends_to_adjoint_pair by blast
have ex_\<sigma>: "\<exists>\<sigma>. tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
proof -
have "hseq n m\<^sup>*"
using mn isomorphic_implies_ide by auto
have "trg (n \<star> m\<^sup>*) = trg w"
using mn m\<^sub>a isomorphic_def
by (metis (no_types, lifting) arr_inv dom_inv in_homE trg_dom trg_inv)
hence "trg n = trg w"
using mn by (metis assms(2) ideD(1) trg.preserves_reflects_arr trg_hcomp')
hence "hseq g n"
using assms mn left_adjoint_is_ide ideD(1) by blast
have "hseq g w"
using assms left_adjoint_is_ide by simp
have "src m = src n"
using mn m\<^sub>a `hseq n m\<^sup>*` adjoint_pair_antipar [of m "m\<^sup>*"] by fastforce
have "is_left_adjoint (g \<star> n)"
using assms mn left_adjoints_compose `hseq g n` by blast
moreover have "src m = src (g \<star> n)"
using assms mn `hseq g n` `src m = src n` by simp
moreover have "(g \<star> n) \<star> m\<^sup>* \<cong> g \<star> w"
proof -
have 1: "src g = trg (n \<star> m\<^sup>*)"
using assms `trg (n \<star> m\<^sup>*) = trg w` `hseq g w` by fastforce
hence "(g \<star> n) \<star> m\<^sup>* \<cong> g \<star> n \<star> m\<^sup>*"
using assms mn m\<^sub>a assoc_in_hom iso_assoc `hseq g n` `hseq n m\<^sup>*`
isomorphic_def left_adjoint_is_ide right_adjoint_is_ide
by (metis hseqE ideD(2) ideD(3))
also have "... \<cong> g \<star> w"
using assms 1 mn m\<^sub>a isomorphic_symmetric hcomp_ide_isomorphic left_adjoint_is_ide
by simp
finally show ?thesis
using isomorphic_transitive by blast
qed
ultimately show ?thesis
using assms mn m\<^sub>a BS2' by blast
qed
obtain \<sigma> where \<sigma>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
using ex_\<sigma> by auto
interpret \<rho>: tabulation V H \<a> \<i> src trg \<open>g \<star> w\<close> \<rho> \<open>src w\<close> \<open>g \<star> w\<close>
using \<rho> by auto
interpret \<sigma>: tabulation V H \<a> \<i> src trg \<open>g \<star> w\<close> \<sigma> m \<open>g \<star> n\<close>
using \<sigma> by auto
text \<open>
As usual, the sketch given by CKS seems more suggestive than it is a precise recipe.
We can obtain an equivalence map \<open>\<guillemotleft>e : src w \<rightarrow> src m\<guillemotright>\<close> and \<open>\<theta>\<close> such that
\<open>\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright>\<close>.
We can also obtain an equivalence map \<open>\<guillemotleft>e' : src m \<rightarrow> src w\<guillemotright>\<close> and \<open>\<theta>'\<close> such that
\<open>\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright>\<close>. If \<open>\<theta>'\<close> can be taken to be an isomorphism; then we have
\<open>e' \<cong> src w \<star> e' \<cong> m\<close>. Since \<open>e'\<close> is an equivalence, this shows \<open>m\<close> is an equivalence,
hence its right adjoint \<open>m\<^sup>*\<close> is also an equivalence and therefore a map.
But \<open>w = n \<star> m\<^sub>a\<close>, so this shows that \<open>w\<close> is a map.
Now, we may assume without loss of generality that \<open>e\<close> and \<open>e'\<close> are part of an
adjoint equivalence.
We have \<open>\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright>\<close>.
We may take the transpose of \<open>\<theta>\<close> to obtain \<open>\<guillemotleft>\<zeta> : m \<Rightarrow> src w \<star> e'\<guillemotright>\<close>;
then \<open>\<guillemotleft>\<theta>' \<cdot> \<zeta> : m \<Rightarrow> m\<guillemotright>\<close> and \<open>\<guillemotleft>\<zeta> \<cdot> \<theta>' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>\<close>.
Since \<open>m\<close> and \<open>src w \<star> e'\<close> are maps, by \<open>BS3\<close> it must be that \<open>\<zeta>\<close> and \<open>\<theta>'\<close> are inverses.
\<close>
text \<open>
{\bf Note:} CKS don't cite \<open>BS3\<close> here. I am not sure whether this result can be proved
without \<open>BS3\<close>. For example, I am interested in knowing whether it can still be
proved under the the assumption that 2-cells between maps are unique, but not
necessarily invertible, or maybe even in a more general situation. It looks like
the invertibility part of \<open>BS3\<close> is not used in the proof below.
\<close>
have 2: "\<exists>e e' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi> \<and>
\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<star> n \<Rightarrow> (g \<star> w) \<star> e'\<guillemotright> \<and> iso \<nu> \<and>
\<sigma> = \<rho>.composite_cell e' \<theta>' \<cdot> \<nu> \<and>
\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright> \<and> \<guillemotleft>\<nu>' : g \<star> w \<Rightarrow> (g \<star> n) \<star> e\<guillemotright> \<and> iso \<nu>' \<and>
\<rho> = ((g \<star> w) \<star> \<theta>) \<cdot> \<a>[g \<star> w, m, e] \<cdot> (\<sigma> \<star> e) \<cdot> \<nu>'"
using \<rho> \<sigma>.apex_unique_up_to_equivalence [of \<rho> "src w" "g \<star> w"] comp_assoc
by metis
obtain e e' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
where *: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi> \<and>
\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<star> n \<Rightarrow> (g \<star> w) \<star> e'\<guillemotright> \<and> iso \<nu> \<and>
\<sigma> = \<rho>.composite_cell e' \<theta>' \<cdot> \<nu> \<and>
\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright> \<and> \<guillemotleft>\<nu>' : g \<star> w \<Rightarrow> (g \<star> n) \<star> e\<guillemotright> \<and> iso \<nu>' \<and>
\<rho> = \<sigma>.composite_cell e \<theta> \<cdot> \<nu>'"
using 2 comp_assoc by auto
interpret ee': equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e e' \<phi> \<psi>
using * by simp
have equiv_e: "equivalence_map e"
using ee'.equivalence_in_bicategory_axioms equivalence_map_def by auto
obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi>'"
using equivalence_refines_to_adjoint_equivalence [of e e' \<phi>]
ee'.unit_in_hom(2) ee'.unit_is_iso ee'.antipar equiv_e
by auto
interpret ee': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e e' \<phi> \<psi>'
using \<psi>' by simp
interpret e'e: adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e' e \<open>inv \<psi>'\<close> \<open>inv \<phi>\<close>
using * ee'.dual_adjoint_equivalence by simp
have equiv_e': "equivalence_map e'"
using e'e.equivalence_in_bicategory_axioms equivalence_map_def by auto
have "hseq m e"
using * ide_dom [of \<theta>]
apply (elim conjE in_homE) by simp
have "hseq (src w) e'"
using * ide_dom [of \<theta>']
apply (elim conjE in_homE) by simp
have "e'e.trnr\<^sub>\<eta> m \<theta> \<in> hom m (src w \<star> e')"
proof -
have "src m = trg e"
using `hseq m e` by auto
moreover have "src (src w) = trg e'"
using `hseq (src w) e'` by auto
moreover have "ide m"
using mn left_adjoint_is_ide by simp
moreover have "ide (src w)"
using assms by simp
ultimately show ?thesis
using * e'e.adjoint_transpose_right(1) by blast
qed
hence 3: "\<guillemotleft>e'e.trnr\<^sub>\<eta> m \<theta> : m \<Rightarrow> src w \<star> e'\<guillemotright>"
by simp
hence "\<guillemotleft>\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta> : m \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>"
using * by auto
moreover have "\<guillemotleft>m : m \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>src w \<star> e' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>"
using mn 3 ide_cod [of "e'e.trnr\<^sub>\<eta> m \<theta>"] left_adjoint_is_ide by fastforce
moreover have 4: "is_left_adjoint (src w \<star> e')"
proof -
have "is_left_adjoint (src w)"
using assms obj_is_self_adjoint by simp
moreover have "is_left_adjoint e'"
using e'e.adjunction_in_bicategory_axioms adjoint_pair_def by auto
ultimately show ?thesis
using left_adjoints_compose `hseq (src w) e'` by auto
qed
ultimately have "\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta> = m \<and> e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>' = src w \<star> e'"
using mn BS3 [of m m "\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta>" m]
BS3 [of "src w \<star> e'" "src w \<star> e'" "e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>'" "src w \<star> e'"]
by auto
hence "inverse_arrows \<theta>' (e'e.trnr\<^sub>\<eta> m \<theta>)"
using mn 4 left_adjoint_is_ide inverse_arrows_def by simp
hence 5: "iso \<theta>'"
by auto
have "equivalence_map (src w \<star> e')"
using assms obj_is_equivalence_map equiv_e' `hseq (src w) e'` equivalence_maps_compose
by auto
hence "equivalence_map m"
using * 5 equivalence_map_preserved_by_iso isomorphic_def by auto
hence "equivalence_map m\<^sup>*"
using mn m\<^sub>a right_adjoint_to_equivalence_is_equivalence by simp
hence "is_left_adjoint m\<^sup>*"
using equivalence_is_left_adjoint by simp
moreover have "hseq n m\<^sup>*"
using mn isomorphic_implies_ide by auto
ultimately have "is_left_adjoint (n \<star> m\<^sup>*)"
using mn left_adjoints_compose by blast
thus ?thesis
using mn left_adjoint_preserved_by_iso isomorphic_def isomorphic_symmetric
by metis
qed
end
subsection "Choosing Tabulations"
context bicategory_of_spans
begin
notation isomorphic (infix "\<cong>" 50)
notation iso_class ("\<lbrakk>_\<rbrakk>")
text \<open>
We will ultimately need to have chosen a specific tabulation for each 1-cell.
This has to be done carefully, to avoid unnecessary choices.
We start out by using \<open>BS1\<close> to choose a specific factorization of the form
\<open>r \<cong> tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<close> for each 1-cell \<open>r\<close>. This has to be done in such a way
that all elements of an isomorphism class are assigned the same factorization.
\<close>
abbreviation isomorphic_rep
where "isomorphic_rep r f g \<equiv> is_left_adjoint f \<and> is_left_adjoint g \<and> g \<star> f\<^sup>* \<cong> r"
definition tab\<^sub>0
where "tab\<^sub>0 r \<equiv> SOME f. \<exists>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"
definition tab\<^sub>1
where "tab\<^sub>1 r \<equiv> SOME g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) g"
definition rep
where "rep r \<equiv> SOME \<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
lemma rep_props:
assumes "ide r"
shows "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso (rep r)"
and "r \<cong> iso_class_rep \<lbrakk>r\<rbrakk>"
and "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
and "tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<cong> r"
proof -
have 1: "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
proof -
have "\<exists>f g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"
using assms BS1 isomorphic_symmetric rep_iso_class isomorphic_transitive
by blast
hence "isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) (tab\<^sub>1 r)"
using assms tab\<^sub>0_def tab\<^sub>1_def
someI_ex [of "\<lambda>f. \<exists>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"]
someI_ex [of "\<lambda>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) g"]
by simp
thus ?thesis
using assms isomorphic_symmetric isomorphic_transitive rep_iso_class by blast
qed
hence "\<exists>\<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
using isomorphic_def by blast
hence 2: "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso (rep r)"
using someI_ex [of "\<lambda>\<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"] rep_def by auto
show "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
using 2 by simp
show "iso (rep r)"
using 2 by simp
show "r \<cong> iso_class_rep \<lbrakk>r\<rbrakk>"
using assms rep_iso_class isomorphic_symmetric by simp
thus "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
using 1 isomorphic_transitive by blast
thus "tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<cong> r"
by simp
qed
lemma tab\<^sub>0_in_hom [intro]:
assumes "ide r"
shows "\<guillemotleft>tab\<^sub>0 r : src (tab\<^sub>0 r) \<rightarrow> src r\<guillemotright>"
and "\<guillemotleft>tab\<^sub>0 r : tab\<^sub>0 r \<Rightarrow> tab\<^sub>0 r\<guillemotright>"
proof -
show "\<guillemotleft>tab\<^sub>0 r : tab\<^sub>0 r \<Rightarrow> tab\<^sub>0 r\<guillemotright>"
using assms rep_props left_adjoint_is_ide by auto
have "trg (tab\<^sub>0 r) = src r"
using assms rep_props
by (metis ideD(1) isomorphic_implies_hpar(1) isomorphic_implies_hpar(3)
right_adjoint_simps(2) src_hcomp')
thus "\<guillemotleft>tab\<^sub>0 r : src (tab\<^sub>0 r) \<rightarrow> src r\<guillemotright>"
using assms rep_props left_adjoint_is_ide
by (intro in_hhomI, auto)
qed
lemma tab\<^sub>0_simps [simp]:
assumes "ide r"
shows "ide (tab\<^sub>0 r)"
and "is_left_adjoint (tab\<^sub>0 r)"
and "trg (tab\<^sub>0 r) = src r"
and "dom (tab\<^sub>0 r) = tab\<^sub>0 r" and "cod (tab\<^sub>0 r) = tab\<^sub>0 r"
using assms tab\<^sub>0_in_hom rep_props ide_dom left_adjoint_is_ide by auto
lemma tab\<^sub>1_in_hom [intro]:
assumes "ide r"
shows "\<guillemotleft>tab\<^sub>1 r : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
and "\<guillemotleft>tab\<^sub>1 r : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 r\<guillemotright>"
proof -
show "\<guillemotleft>tab\<^sub>1 r : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 r\<guillemotright>"
using assms rep_props left_adjoint_is_ide by auto
have "trg (tab\<^sub>1 r) = trg r"
using assms rep_props
by (metis ideD(1) isomorphic_implies_hpar(1) isomorphic_implies_hpar(4) trg_hcomp')
moreover have "src (tab\<^sub>0 r) = src (tab\<^sub>1 r)"
using assms rep_props by fastforce
ultimately show "\<guillemotleft>tab\<^sub>1 r : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
using assms rep_props left_adjoint_is_ide
by (intro in_hhomI, auto)
qed
lemma tab\<^sub>1_simps [simp]:
assumes "ide r"
shows "ide (tab\<^sub>1 r)"
and "is_left_adjoint (tab\<^sub>1 r)"
and "src (tab\<^sub>1 r) = src (tab\<^sub>0 r)" and "trg (tab\<^sub>1 r) = trg r"
and "dom (tab\<^sub>1 r) = tab\<^sub>1 r" and "cod (tab\<^sub>1 r) = tab\<^sub>1 r"
using assms tab\<^sub>1_in_hom rep_props ide_dom left_adjoint_is_ide by auto
lemma rep_in_hom [intro]:
assumes "ide r"
shows "\<guillemotleft>rep r : src r \<rightarrow> trg r\<guillemotright>"
and "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
proof -
show "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
using assms rep_props by auto
thus "\<guillemotleft>rep r : src r \<rightarrow> trg r\<guillemotright>"
using src_cod trg_cod by fastforce
qed
lemma rep_simps [simp]:
assumes "ide r"
shows "arr (rep r)"
and "src (rep r) = src r" and "trg (rep r) = trg r"
and "dom (rep r) = tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*" and "cod (rep r) = r"
using assms rep_in_hom by auto
lemma iso_rep:
assumes "ide r"
shows "iso (rep r)"
using assms rep_props by simp
end
text \<open>
Next, we assign a specific tabulation to each 1-cell r.
We can't just do this any old way if we ultimately expect to obtain a mapping that is
functorial with respect to vertical composition. What we have to do is to assign the
representative \<open>tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<close> its canonical tabulation, obtained as the adjoint
transpose of the identity, and then translate this to a tabulation of \<open>r\<close> via the chosen
isomorphism \<open>\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>.
\<close>
locale identity_in_bicategory_of_spans =
bicategory_of_spans +
fixes r :: 'a
assumes is_ide: "ide r"
begin
interpretation tab\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close>
using is_ide rep_props by (unfold_locales, auto)
interpretation tab\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>1 r\<close>
using is_ide rep_props by (unfold_locales, auto)
text \<open>
A tabulation \<open>(tab\<^sub>0 r, tab, tab\<^sub>1 r)\<close> of \<open>r\<close> can be obtained as the adjoint transpose
of the isomorphism \<open>\<guillemotleft>rep r : (tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>. It is essential to define
it this way if we expect the mapping from 2-cells of the underlying bicategory
to arrows of spans to preserve vertical composition.
\<close>
definition tab
where "tab \<equiv> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) (rep r)"
text \<open>
In view of \<open>BS2'\<close>, the 1-cell \<open>(tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*\<close> has the canonical tabulation
obtained via adjoint transpose of an identity. In fact, this tabulation generates the
chosen tabulation of \<open>r\<close> in the same isomorphism class by translation along the
isomorphism \<open>\<guillemotleft>rep r : (tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>. This fact is used to show that the
mapping from 2-cells to arrows of spans preserves identities.
\<close>
lemma canonical_tabulation:
shows "tabulation V H \<a> \<i> src trg
((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) (tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)) (tab\<^sub>0 r) (tab\<^sub>1 r)"
proof -
have "\<exists>\<rho>. tabulation V H \<a> \<i> src trg ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<rho> (tab\<^sub>0 r) (tab\<^sub>1 r)"
by (simp add: bicategory_of_spans.BS2' bicategory_of_spans_axioms is_ide
isomorphic_reflexive)
thus ?thesis
using is_ide tab\<^sub>0.canonical_tabulation by simp
qed
lemma tab_def_alt:
shows "tab = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
and "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
proof -
have "tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) (rep r \<cdot> ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*))"
using tab_def is_ide rep_in_hom [of r] comp_arr_dom by auto
also have "... = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
using is_ide tab\<^sub>0.trnr\<^sub>\<eta>_comp by auto
finally show 1: "tab = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)" by simp
have "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab =
((inv (rep r) \<star> tab\<^sub>0 r) \<cdot> (rep r \<star> tab\<^sub>0 r)) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
- unfolding 1 using comp_assoc by simp
+ unfolding 1 using comp_assoc by presburger
also have "... = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
proof -
have 1: "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> (rep r \<star> tab\<^sub>0 r) = ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r"
using whisker_right [of "tab\<^sub>0 r" "inv (rep r)" "rep r"] iso_rep rep_in_hom
inv_is_inverse comp_inv_arr
by (simp add: comp_inv_arr' is_ide)
show ?thesis
proof -
have "\<guillemotleft>tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) :
tab\<^sub>1 r \<Rightarrow> (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r\<guillemotright>"
by (meson canonical_tabulation tabulation_data.tab_in_hom(2) tabulation_def)
hence "((tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) =
tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
using 1 comp_cod_arr by blast
thus ?thesis
using 1 by simp
qed
qed
finally show "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
by blast
qed
lemma tab_is_tabulation:
shows "tabulation V H \<a> \<i> src trg r tab (tab\<^sub>0 r) (tab\<^sub>1 r)"
by (metis bicategory_of_spans.iso_rep bicategory_of_spans.rep_in_hom(2)
bicategory_of_spans_axioms is_ide canonical_tabulation tab_def_alt(1)
tabulation.is_preserved_by_base_iso)
(*
* TODO: If I pull the interpretation "tab" out of the following, Isabelle warns that
* the lemma is a redundant introduction rule and is being "ignored" for that purpose.
* However, the redundancy is only in the present context: if the enclosing locale is
* interpreted elsewhere, then the rule is not redundant. In order to make sure that
* the rule is not "ignored", I have put the interpretation "tab" into the proof to
* avoid the warning.
*)
lemma tab_in_hom [intro]:
shows "\<guillemotleft>tab : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
and "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
proof -
interpret tab: tabulation V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
using tab_is_tabulation by simp
show "\<guillemotleft>tab : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
using tab.tab_in_hom by auto
show "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
using tab.tab_in_hom by auto
qed
lemma tab_simps [simp]:
shows "arr tab"
and "src tab = src (tab\<^sub>0 r)" and "trg tab = trg r"
and "dom tab = tab\<^sub>1 r" and "cod tab = r \<star> tab\<^sub>0 r"
using tab_in_hom by auto
end
text \<open>
The following makes the chosen tabulation conveniently available whenever we are
considering a particular 1-cell.
\<close>
sublocale identity_in_bicategory_of_spans \<subseteq> tabulation V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
using is_ide tab_is_tabulation by simp
context identity_in_bicategory_of_spans
begin
interpretation tab\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close>
using is_ide rep_props by (unfold_locales, auto)
interpretation tab\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>1 r\<close>
using is_ide rep_props by (unfold_locales, auto)
text \<open>
The fact that adjoint transpose is a bijection allows us to invert the definition
of \<open>tab\<close> in terms of \<open>rep\<close> to express rep in terms of tab.
\<close>
lemma rep_in_terms_of_tab:
shows "rep r = T0.trnr\<^sub>\<epsilon> r tab"
using is_ide T0.adjoint_transpose_right(3) [of r "tab\<^sub>1 r" "rep r"] tab_def
by fastforce
lemma isomorphic_implies_same_tab:
assumes "isomorphic r r'"
shows "tab\<^sub>0 r = tab\<^sub>0 r'" and "tab\<^sub>1 r = tab\<^sub>1 r'"
using assms tab\<^sub>0_def tab\<^sub>1_def iso_class_eqI by auto
text \<open>
``Every 1-cell has a tabulation as a span of maps.''
Has a nice simple ring to it, but maybe not so useful for us, since we generally
really need to know that the tabulation has a specific form.
\<close>
lemma has_tabulation:
shows "\<exists>\<rho> f g. is_left_adjoint f \<and> is_left_adjoint g \<and> tabulation V H \<a> \<i> src trg r \<rho> f g"
using is_ide tab_is_tabulation rep_props by blast
end
subsection "Tabulations in a Bicategory of Spans"
context bicategory_of_spans
begin
abbreviation tab_of_ide
where "tab_of_ide r \<equiv> identity_in_bicategory_of_spans.tab V H \<a> \<i> src trg r"
abbreviation prj\<^sub>0
where "prj\<^sub>0 h k \<equiv> tab\<^sub>0 (k\<^sup>* \<star> h)"
abbreviation prj\<^sub>1
where "prj\<^sub>1 h k \<equiv> tab\<^sub>1 (k\<^sup>* \<star> h)"
lemma prj_in_hom [intro]:
assumes "ide h" and "is_left_adjoint k" and "trg h = trg k"
shows "\<guillemotleft>prj\<^sub>0 h k : src (prj\<^sub>0 h k) \<rightarrow> src h\<guillemotright>"
and "\<guillemotleft>prj\<^sub>1 h k : src (prj\<^sub>0 h k) \<rightarrow> src k\<guillemotright>"
and "\<guillemotleft>prj\<^sub>0 h k : prj\<^sub>0 h k \<Rightarrow> prj\<^sub>0 h k\<guillemotright>"
and "\<guillemotleft>prj\<^sub>1 h k : prj\<^sub>1 h k \<Rightarrow> prj\<^sub>1 h k\<guillemotright>"
by (intro in_hhomI, auto simp add: assms(1-3))
lemma prj_simps [simp]:
assumes "ide h" and "is_left_adjoint k" and "trg h = trg k"
shows "trg (prj\<^sub>0 h k) = src h"
and "src (prj\<^sub>1 h k) = src (prj\<^sub>0 h k)" and "trg (prj\<^sub>1 h k) = src k"
and "dom (prj\<^sub>0 h k) = prj\<^sub>0 h k" and "cod (prj\<^sub>0 h k) = prj\<^sub>0 h k"
and "dom (prj\<^sub>1 h k) = prj\<^sub>1 h k" and "cod (prj\<^sub>1 h k) = prj\<^sub>1 h k"
and "is_left_adjoint (prj\<^sub>0 h k)" and "is_left_adjoint (prj\<^sub>1 h k)"
using assms prj_in_hom by auto
end
text \<open>
Many of the commutativity conditions that we would otherwise have to worry about
when working with tabulations in a bicategory of spans reduce to trivialities.
The following locales try to exploit this to make our life more manageable.
\<close>
locale span_of_maps =
bicategory_of_spans +
fixes leg\<^sub>0 :: 'a
and leg\<^sub>1 :: 'a
assumes leg0_is_map: "is_left_adjoint leg\<^sub>0"
and leg1_is_map : "is_left_adjoint leg\<^sub>1"
text \<open>
The purpose of the somewhat strange-looking assumptions in this locale is
to cater to the form of data that we obtain from \<open>T1\<close>. Under the assumption
that we are in a bicategory of spans and that the legs of \<open>r\<close> and \<open>s\<close> are maps,
the hypothesized 2-cells will be uniquely determined isomorphisms, and an
arrow of spans \<open>w\<close> from \<open>r\<close> to \<open>s\<close> will be a map. We want to prove this once and
for all under the weakest assumptions we can manage.
\<close>
locale arrow_of_spans_of_maps =
bicategory_of_spans V H \<a> \<i> src trg +
r: span_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 +
s: span_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r\<^sub>0 :: 'a
and r\<^sub>1 :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a
and w :: 'a +
assumes is_ide: "ide w"
and leg0_lax: "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
and leg1_iso: "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
begin
notation isomorphic (infix "\<cong>" 50)
lemma composite_leg1_is_map:
shows "is_left_adjoint (s\<^sub>1 \<star> w)"
using r.leg1_is_map leg1_iso left_adjoint_preserved_by_iso' isomorphic_def
isomorphic_symmetric
by auto
lemma is_map:
shows "is_left_adjoint w"
using is_ide composite_leg1_is_map s.leg1_is_map BS4 [of s\<^sub>1 w] by auto
lemma hseq_leg\<^sub>0:
shows "hseq s\<^sub>0 w"
by (metis ideD(1) ide_dom in_homE leg0_lax)
lemma composite_with_leg0_is_map:
shows "is_left_adjoint (s\<^sub>0 \<star> w)"
using left_adjoints_compose is_map s.leg0_is_map hseq_leg\<^sub>0 by blast
lemma leg0_uniquely_isomorphic:
shows "s\<^sub>0 \<star> w \<cong> r\<^sub>0"
and "\<exists>!\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
proof -
show 1: "s\<^sub>0 \<star> w \<cong> r\<^sub>0"
using leg0_lax composite_with_leg0_is_map r.leg0_is_map BS3 [of "s\<^sub>0 \<star> w" r\<^sub>0]
isomorphic_def
by auto
have "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> iso \<theta>"
using 1 isomorphic_def by simp
moreover have "\<And>\<theta> \<theta>'. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<Longrightarrow> \<guillemotleft>\<theta>' : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<Longrightarrow> \<theta> = \<theta>'"
using BS3 r.leg0_is_map composite_with_leg0_is_map by blast
ultimately show "\<exists>!\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" by blast
qed
lemma leg1_uniquely_isomorphic:
shows "r\<^sub>1 \<cong> s\<^sub>1 \<star> w"
and "\<exists>!\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
proof -
show 1: "r\<^sub>1 \<cong> s\<^sub>1 \<star> w"
using leg1_iso isomorphic_def by auto
have "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
using leg1_iso isomorphic_def isomorphic_symmetric by simp
moreover have "\<And>\<nu> \<nu>'. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<Longrightarrow> \<guillemotleft>\<nu>' : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<Longrightarrow> \<nu> = \<nu>'"
using BS3 r.leg1_is_map composite_leg1_is_map by blast
ultimately show "\<exists>!\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" by blast
qed
definition the_\<theta>
where "the_\<theta> \<equiv> THE \<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
definition the_\<nu>
where "the_\<nu> \<equiv> THE \<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
lemma the_\<theta>_props:
shows "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" and "iso the_\<theta>"
proof -
show "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
unfolding the_\<theta>_def
using the1I2 [of "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"]
leg0_uniquely_isomorphic
by simp
thus "iso the_\<theta>"
using BS3 r.leg0_is_map composite_with_leg0_is_map by simp
qed
lemma the_\<theta>_in_hom [intro]:
shows "\<guillemotleft>the_\<theta> : src r\<^sub>0 \<rightarrow> trg r\<^sub>0\<guillemotright>"
and "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
using the_\<theta>_props apply auto
by (metis cod_trg in_hhom_def in_homE isomorphic_implies_hpar(3) leg0_uniquely_isomorphic(1)
src_dom trg.preserves_cod)
lemma the_\<theta>_simps [simp]:
shows "arr the_\<theta>"
and "src the_\<theta> = src r\<^sub>0" and "trg the_\<theta> = trg r\<^sub>0"
and "dom the_\<theta> = s\<^sub>0 \<star> w" and "cod the_\<theta> = r\<^sub>0"
using the_\<theta>_in_hom by auto
lemma the_\<nu>_props:
shows "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" and "iso the_\<nu>"
proof -
show "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
unfolding the_\<nu>_def
using the1I2 [of "\<lambda>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" "\<lambda>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"]
leg1_uniquely_isomorphic
by simp
thus "iso the_\<nu>"
using BS3 r.leg1_is_map composite_leg1_is_map by simp
qed
lemma the_\<nu>_in_hom [intro]:
shows "\<guillemotleft>the_\<nu> : src r\<^sub>1 \<rightarrow> trg r\<^sub>1\<guillemotright>"
and "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
using the_\<nu>_props apply auto
by (metis in_hhom_def in_homE isomorphic_implies_hpar(3) leg1_uniquely_isomorphic(1)
src_cod trg_dom)
lemma the_\<nu>_simps [simp]:
shows "arr the_\<nu>"
and "src the_\<nu> = src r\<^sub>1" and "trg the_\<nu> = trg r\<^sub>1"
and "dom the_\<nu> = r\<^sub>1" and "cod the_\<nu> = s\<^sub>1 \<star> w"
using the_\<nu>_in_hom by auto
end
(*
* TODO: I could probably avoid repeating the declarations of the locale parameters
* if I was willing to accept them being given in their order of appearance.
*)
locale arrow_of_spans_of_maps_to_tabulation_data =
bicategory_of_spans V H \<a> \<i> src trg +
arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w +
\<sigma>: tabulation_data V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r\<^sub>0 :: 'a
and r\<^sub>1 :: 'a
and s :: 'a
and \<sigma> :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a
and w :: 'a
text \<open>
The following declaration allows us to inherit the rules and other facts defined in
locale @{locale uw\<theta>}. It is tedious to prove very much without these in place.
\<close>
sublocale arrow_of_spans_of_maps_to_tabulation_data \<subseteq> uw\<theta> V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 r\<^sub>0 w the_\<theta>
using \<sigma>.tab_in_hom is_ide the_\<theta>_props by (unfold_locales, auto)
locale arrow_of_spans_of_maps_to_tabulation =
arrow_of_spans_of_maps_to_tabulation_data +
tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
locale tabulation_in_maps =
span_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1 +
tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and s :: 'a
and \<sigma> :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a
sublocale tabulation_in_maps \<subseteq> tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 ..
sublocale identity_in_bicategory_of_spans \<subseteq>
tabulation_in_maps V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
using is_ide rep_props by (unfold_locales, auto)
locale cospan_of_maps_in_bicategory_of_spans =
bicategory_of_spans +
fixes h :: 'a
and k :: 'a
assumes h_is_map: "is_left_adjoint h"
and k_is_map: "is_left_adjoint k"
and cospan: "trg h = trg k"
begin
text \<open>
The following sublocale declaration is perhaps pushing the limits of sensibility,
but the purpose is, given a cospan of maps \<open>(h, k)\<close>, to obtain ready access to the
composite \<open>k\<^sup>* \<star> h\<close> and its chosen tabulation.
\<close>
sublocale identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close>
using h_is_map k_is_map cospan left_adjoint_is_ide
by (unfold_locales, auto)
notation isomorphic (infix "\<cong>" 50)
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
interpretation h: map_in_bicategory V H \<a> \<i> src trg h
using h_is_map by (unfold_locales, auto)
interpretation k: map_in_bicategory V H \<a> \<i> src trg k
using k_is_map by (unfold_locales, auto)
text \<open>
Our goal here is to reformulate the biuniversal properties of the chosen tabulation
of \<open>k\<^sup>* \<star> h\<close> in terms of its transpose, which yields a 2-cell from \<open>k \<star> tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
to \<open>h \<star> tab\<^sub>0 (k\<^sup>* \<star> h)\<close>. These results do not depend on \<open>BS3\<close>.
\<close>
abbreviation p\<^sub>0
where "p\<^sub>0 \<equiv> prj\<^sub>0 h k"
abbreviation p\<^sub>1
where "p\<^sub>1 \<equiv> prj\<^sub>1 h k"
lemma p\<^sub>0_in_hom [intro]:
shows "\<guillemotleft>p\<^sub>0 : src p\<^sub>0 \<rightarrow> src h\<guillemotright>"
by auto
lemma p\<^sub>1_in_hom [intro]:
shows "\<guillemotleft>p\<^sub>1 : src p\<^sub>0 \<rightarrow> src k\<guillemotright>"
using prj_in_hom cospan h.ide_left k_is_map by blast
lemma p\<^sub>0_simps [simp]:
shows "trg p\<^sub>0 = src h"
by simp
lemma p\<^sub>1_simps [simp]:
shows "trg p\<^sub>1 = src k"
using k.antipar(1) by auto
definition \<phi>
where "\<phi> \<equiv> k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab)"
lemma \<phi>_in_hom [intro]:
shows "\<guillemotleft>\<phi> : src p\<^sub>0 \<rightarrow> trg h\<guillemotright>"
and "\<guillemotleft>\<phi> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
proof -
show 1: "\<guillemotleft>\<phi> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
unfolding \<phi>_def
using k.antipar cospan k.adjoint_transpose_left(2) [of "h \<star> p\<^sub>0" "p\<^sub>1"]
by fastforce
show "\<guillemotleft>\<phi> : src p\<^sub>0 \<rightarrow> trg h\<guillemotright>"
using 1 k.antipar src_dom trg_cod by fastforce
qed
lemma \<phi>_simps [simp]:
shows "arr \<phi>"
and "src \<phi> = src p\<^sub>0" and "trg \<phi> = trg h"
and "dom \<phi> = k \<star> p\<^sub>1" and "cod \<phi> = h \<star> p\<^sub>0"
using \<phi>_in_hom by auto
lemma transpose_\<phi>:
shows "tab = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi>"
proof -
- have "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi> =
- \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab"
+ have "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi> = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab"
unfolding \<phi>_def
using k.antipar cospan
k.adjoint_transpose_left(4)
[of "h \<star> p\<^sub>0" "p\<^sub>1" "\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab"]
by fastforce
also have "... = (\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0]) \<cdot> tab"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = tab"
using k.antipar cospan comp_cod_arr comp_assoc_assoc' by simp
finally show ?thesis by simp
qed
lemma transpose_triangle:
assumes "ide w"
and "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>" and "\<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright>"
shows "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>) =
(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
proof -
have u: "ide u"
using assms(2) by auto
have v: "ide v"
using assms(3) by auto
have 0: "src p\<^sub>0 = trg w"
by (metis assms(2) hseqE ideD(1) src.preserves_reflects_arr u vconn_implies_hpar(3))
have 1: "src h = trg u"
using assms(1-2) 0 trg_dom trg_cod hseqI' vconn_implies_hpar(4) by auto
have 2: "src k = trg v"
using assms(1,3) 0 trg_dom trg_cod hseqI'
by (metis ideD(1) leg1_simps(2) leg1_simps(3) p\<^sub>1_simps trg_hcomp' vconn_implies_hpar(4))
have 3: "src u = src v \<and> src u = src w"
using assms 0 k.antipar src_dom src_cod hseqI'
by (metis ideD(1) leg0_simps(2) leg1_simps(2) leg1_simps(3) src_hcomp'
vconn_implies_hpar(3))
have 4: "src h = trg \<theta>"
using assms 1 k.antipar by auto
define \<chi> where "\<chi> = \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)"
have \<chi>: "\<guillemotleft>\<chi> : p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> p\<^sub>0 \<star> w\<guillemotright>"
unfolding \<chi>_def
using assms 0 k.antipar cospan by (intro comp_in_homI, auto)
have "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>) =
k.trnl\<^sub>\<epsilon> (h \<star> u) ((k\<^sup>* \<star> h \<star> \<theta>) \<cdot> \<chi> \<cdot> \<nu>)"
unfolding \<chi>_def
using assms 1 k.antipar cospan assoc_naturality [of "k\<^sup>*" h \<theta>] comp_assoc
by (metis "4" h.ide_left ide_char in_homE k.ide_right)
also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k\<^sup>* \<star> h \<star> \<theta>) \<cdot> (k \<star> \<chi> \<cdot> \<nu>)"
proof -
have "ide (h \<star> u)"
using "1" u assms h.ide_left by blast
moreover have "seq (k\<^sup>* \<star> h \<star> \<theta>) (\<chi> \<cdot> \<nu>)"
using assms 1 k.antipar cospan \<chi> seqI' hseqI'
apply (intro seqI)
apply auto
apply blast
proof -
have "dom (k\<^sup>* \<star> h \<star> \<theta>) = k\<^sup>* \<star> h \<star> p\<^sub>0 \<star> w"
using assms
by (metis "4" cospan hcomp_simps(2-3) h.ide_left hseqI' ide_char in_homE k.antipar(2)
k.ide_right)
also have "... = cod \<chi>"
using \<chi> by auto
finally show "dom (k\<^sup>* \<star> h \<star> \<theta>) = cod \<chi>" by simp
qed
moreover have "src k = trg (k\<^sup>* \<star> h \<star> \<theta>)"
using assms k.antipar cospan calculation(2) by auto
ultimately show ?thesis
using k.trnl\<^sub>\<epsilon>_comp by simp
qed
also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k\<^sup>* \<star> h \<star> \<theta>) \<cdot> (k \<star> \<chi>) \<cdot> (k \<star> \<nu>)"
using assms u \<chi> whisker_left
by (metis k.ide_left seqI')
also have
"... = (\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> u] \<cdot> (k \<star> k\<^sup>* \<star> h \<star> \<theta>)) \<cdot> (k \<star> \<chi>) \<cdot> (k \<star> \<nu>)"
unfolding k.trnl\<^sub>\<epsilon>_def by simp
also have "... = (h \<star> \<theta>) \<cdot>
(\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<chi>)) \<cdot>
(k \<star> \<nu>)"
proof -
have "\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> u] \<cdot> (k \<star> k\<^sup>* \<star> h \<star> \<theta>) =
\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
using assms 4 k.antipar cospan assoc'_naturality [of k "k\<^sup>*" "h \<star> \<theta>"] hseqI' by auto
also have "... = \<l>[h \<star> u] \<cdot> ((k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>)) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (\<l>[h \<star> u] \<cdot> (trg k \<star> h \<star> \<theta>)) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
proof -
have "(k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) = k.\<epsilon> \<cdot> (k \<star> k\<^sup>*) \<star> (h \<star> u) \<cdot> (h \<star> \<theta>)"
using assms 1 k.antipar cospan hseqI' interchange comp_arr_dom comp_cod_arr
k.counit_in_hom
by fastforce
also have "... = k.\<epsilon> \<star> h \<star> \<theta>"
using assms k.antipar cospan comp_arr_dom comp_cod_arr k.counit_in_hom
whisker_left
by (metis h.ide_left in_homE)
also have "... = (trg k \<star> h \<star> \<theta>) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)"
using assms 4 k.antipar cospan whisker_left comp_arr_dom comp_cod_arr hseqI'
interchange [of "trg k" k.\<epsilon> "h \<star> \<theta>" "h \<star> p\<^sub>0 \<star> w"]
by auto
finally have "(k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) = (trg k \<star> h \<star> \<theta>) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
proof -
have "\<l>[h \<star> u] \<cdot> (trg k \<star> h \<star> \<theta>) = (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w]"
using assms 1 4 k.antipar cospan lunit_naturality [of "h \<star> \<theta>"]
by (metis hcomp_simps(3-4) h.ide_left hseqI' ide_char in_homE trg_hcomp')
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
finally have "\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> u] \<cdot> (k \<star> k\<^sup>* \<star> h \<star> \<theta>) =
(h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
proof -
have "\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)) =
\<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot>
(trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
proof -
have "\<l>[h \<star> p\<^sub>0 \<star> w] =
\<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
proof -
have "\<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) =
\<a>[h, p\<^sub>0, w] \<cdot> \<ll> ((h \<star> p\<^sub>0) \<star> w) \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
using assms 0 k.antipar cospan comp_cod_arr \<ll>_ide_simp by simp
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> \<ll> (\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
using assms 0 k.antipar cospan \<ll>.is_natural_2 [of "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"] by simp
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w] \<cdot> \<ll> (h \<star> p\<^sub>0 \<star> w)"
using assms 0 k.antipar cospan \<ll>.is_natural_1 [of "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"] comp_assoc
by simp
also have "... = (\<a>[h, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<ll> (h \<star> p\<^sub>0 \<star> w)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = \<ll> (h \<star> p\<^sub>0 \<star> w)"
using assms 0 k.antipar cospan comp_cod_arr comp_assoc_assoc' by simp
also have "... = \<l>[h \<star> p\<^sub>0 \<star> w]"
using assms 0 k.antipar cospan \<ll>_ide_simp by simp
finally show ?thesis by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[trg h, h \<star> p\<^sub>0, w] \<cdot>
((trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
using assms 0 k.antipar cospan lunit_hcomp comp_assoc by simp
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
(\<a>\<^sup>-\<^sup>1[trg h, h \<star> p\<^sub>0, w] \<cdot> (k.\<epsilon> \<star> (h \<star> p\<^sub>0) \<star> w)) \<cdot>
((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
proof -
have "(trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) =
(k.\<epsilon> \<star> (h \<star> p\<^sub>0) \<star> w) \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
using assms 0 k.antipar cospan comp_arr_dom comp_cod_arr
interchange [of "trg h" k.\<epsilon> "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]" "h \<star> p\<^sub>0 \<star> w"]
interchange [of k.\<epsilon> "k \<star> k\<^sup>*" "(h \<star> p\<^sub>0) \<star> w" "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot>
((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
using assms 0 k.antipar cospan assoc'_naturality [of k.\<epsilon> "h \<star> p\<^sub>0" w] comp_assoc
by simp
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot>
((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot>
(k \<star> tab \<star> w)"
proof -
have "k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) =
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot>
(k \<star> tab \<star> w)"
proof -
have "seq \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] (\<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
using \<chi>_def assms 0 k.antipar cospan \<chi> by blast
thus ?thesis
using assms 0 k.antipar cospan whisker_left by auto
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot>
((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot>
\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w]) \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
proof -
have "k \<star> tab \<star> w = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> (k \<star> tab \<star> w)"
proof -
have "\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> (k \<star> tab \<star> w) =
(\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w]) \<cdot> (k \<star> tab \<star> w)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (k \<star> ((k\<^sup>* \<star> h) \<star> p\<^sub>0) \<star> w) \<cdot> (k \<star> tab \<star> w)"
using assms k.antipar 0 comp_assoc_assoc' by simp
also have "... = k \<star> tab \<star> w"
using assms k.antipar 0 comp_cod_arr
by (simp add: hseqI')
finally show ?thesis by simp
qed
also have "... = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
using assms 0 k.antipar cospan assoc'_naturality [of k tab w] by simp
finally have "k \<star> tab \<star> w = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
((k.\<epsilon> \<star> h \<star> p\<^sub>0) \<star> w) \<cdot>
(\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<star> w) \<cdot>
((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
proof -
have "\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot>
(k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot> \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] =
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<star> w"
proof -
have "\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot>
(k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot> \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> ((\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, (\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
using assms 0 k.antipar cospan \<alpha>_def \<a>'_def by simp
also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
using assms 0 k.antipar cospan
by (intro E.eval_eqI, simp_all)
also have "... = \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<star> w"
using assms 0 k.antipar cospan \<alpha>_def \<a>'_def by simp
finally show ?thesis by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[h, p\<^sub>0, w] \<cdot>
(\<l>[h \<star> p\<^sub>0] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<cdot>
(k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
using assms 0 k.antipar cospan comp_assoc hseqI' whisker_right by auto
also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
unfolding \<phi>_def k.trnl\<^sub>\<epsilon>_def
using assms 0 k.antipar cospan comp_assoc whisker_left by simp
finally have "\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
(k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)) =
\<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
by blast
thus ?thesis
using \<chi>_def comp_assoc by simp
qed
finally show ?thesis by simp
qed
text \<open>
\<open>BS3\<close> implies that \<open>\<phi>\<close> is the unique 2-cell from \<open>k \<star> p\<^sub>1\<close> to \<open>h \<star> p\<^sub>0\<close> and is an isomorphism.
\<close>
lemma \<phi>_uniqueness:
shows "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright> \<Longrightarrow> \<mu> = \<phi>" and "iso \<phi>"
proof -
have 2: "is_left_adjoint (k \<star> p\<^sub>1)"
using k.antipar cospan left_adjoints_compose by (simp add: k_is_map)
have 3: "is_left_adjoint (h \<star> p\<^sub>0)"
using k.antipar cospan left_adjoints_compose by (simp add: h_is_map)
show "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright> \<Longrightarrow> \<mu> = \<phi>"
using \<phi>_in_hom 2 3 BS3 by simp
show "iso \<phi>"
using \<phi>_in_hom 2 3 BS3 by simp
qed
text \<open>
As a consequence, the chosen tabulation of \<open>k\<^sup>* \<star> h\<close> is the unique 2-cell from
\<open>p\<^sub>1\<close> to \<open>(k\<^sup>* \<star> h) \<star> p\<^sub>0\<close>, and therefore if we are given any such 2-cell we may
conclude it yields a tabulation of \<open>k\<^sup>* \<star> h\<close>.
\<close>
lemma tab_uniqueness:
assumes "\<guillemotleft>\<tau> : p\<^sub>1 \<Rightarrow> (k\<^sup>* \<star> h) \<star> p\<^sub>0\<guillemotright>"
shows "\<tau> = tab"
proof -
have "\<guillemotleft>k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>) : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
using assms k.antipar cospan k.adjoint_transpose_left(2) [of "h \<star> p\<^sub>0" "p\<^sub>1"]
assoc_in_hom
by auto
hence "tab = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 (k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>))"
using transpose_\<phi> \<phi>_uniqueness(1) by auto
also have "... = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>"
using assms k.antipar cospan k.adjoint_transpose_left(4) assoc_in_hom by simp
also have "... = (\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0]) \<cdot> \<tau>"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = \<tau>"
using assms k.antipar cospan comp_cod_arr comp_assoc_assoc' by auto
finally show ?thesis by simp
qed
text \<open>
The following lemma reformulates the biuniversal property of the canonical tabulation
of \<open>k\<^sup>* \<star> h\<close> as a biuniversal property of \<open>\<phi>\<close>, regarded as a square that commutes up to
isomorphism.
\<close>
lemma \<phi>_biuniversal_prop:
assumes "ide u" and "ide v"
shows "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
and "\<And>w w' \<theta> \<theta>' \<beta>.
\<lbrakk> ide w; ide w';
\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>;
\<guillemotleft>\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>;
(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
(h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>) \<rbrakk>
\<Longrightarrow> \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<beta>"
proof -
fix \<mu>
assume \<mu>: "\<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright>"
have 1: "src h = trg u"
using assms \<mu> ide_cod
by (metis ide_def in_homE seq_if_composable)
have 2: "src k = trg v"
using assms \<mu> ide_dom
by (metis ideD(1) in_homE not_arr_null seq_if_composable)
let ?\<omega> = "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u] \<cdot> k.trnl\<^sub>\<eta> v \<mu>"
have \<omega>: "\<guillemotleft>?\<omega> : v \<Rightarrow> (k\<^sup>* \<star> h) \<star> u\<guillemotright>"
using assms \<mu> 1 2 k.antipar cospan k.adjoint_transpose_left(1) [of "h \<star> u" v]
assoc_in_hom
by auto
obtain w \<theta> \<nu>
where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = ?\<omega>"
using assms \<omega> T1 [of u ?\<omega>] comp_assoc by (metis in_homE)
have 0: "src p\<^sub>0 = trg w"
using w\<theta>\<nu> ide_dom
by (metis hseqE ideD(1) in_homE)
have "\<mu> = k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>)"
proof -
have "\<mu> = k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ?\<omega>)"
proof -
have "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ?\<omega>) =
k.trnl\<^sub>\<epsilon> (h \<star> u) ((\<a>[k\<^sup>*, h, u] \<cdot> \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u]) \<cdot> k.trnl\<^sub>\<eta> v \<mu>)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k.trnl\<^sub>\<eta> v \<mu>)"
proof -
have "(\<a>[k\<^sup>*, h, u] \<cdot> \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u]) \<cdot> k.trnl\<^sub>\<eta> v \<mu> = (k\<^sup>* \<star> h \<star> u) \<cdot> k.trnl\<^sub>\<eta> v \<mu>"
using comp_assoc_assoc'
by (simp add: "1" assms(1) cospan k.antipar(2))
also have "... = k.trnl\<^sub>\<eta> v \<mu>"
using "1" \<omega> assms(1) comp_ide_arr cospan k.antipar(2) by fastforce
finally show ?thesis
by simp
qed
also have "... = \<mu>"
using assms \<mu> k.antipar cospan 1 2 k.adjoint_transpose_left(3) by simp
finally show ?thesis by simp
qed
thus ?thesis using w\<theta>\<nu> by simp
qed
also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
using assms k.antipar cospan w\<theta>\<nu> transpose_triangle [of w \<theta> u \<nu>] by auto
finally have "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
by simp
thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and>
\<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
using w\<theta>\<nu> by blast
next
fix w w' \<theta> \<theta>' \<beta>
assume w: "ide w"
assume w': "ide w'"
assume \<theta>: "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
assume \<theta>': "\<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
assume \<beta>: "\<guillemotleft>\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>"
assume eq: "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
(h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>)"
have 0: "src p\<^sub>0 = trg w"
using \<theta> ide_dom
by (metis ideD(1) in_homE not_arr_null seq_if_composable)
interpret uw\<theta>w'\<theta>': uw\<theta>w'\<theta>' V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close>
u w \<theta> w' \<theta>'
using w \<theta> w' \<theta>' apply (unfold_locales) by auto
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<beta>"
proof -
let ?LHS = "\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)"
let ?RHS = "\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>') \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w'] \<cdot> (tab \<star> w') \<cdot> \<beta>"
have eq': "?LHS = ?RHS"
proof -
have "k.trnl\<^sub>\<epsilon> (h \<star> u) ?LHS =
k.trnl\<^sub>\<epsilon> (h \<star> u)
(\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> (p\<^sub>1 \<star> w))"
using assms 0 w \<theta> \<beta> k.antipar cospan comp_arr_dom
by (metis tab_simps(1) tab_simps(4) whisker_right)
also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> p\<^sub>1 \<star> w)"
using assms w \<theta> \<beta> transpose_triangle
by (metis arr_dom ide_hcomp ide_in_hom(2) in_homE ide_leg1 not_arr_null
seq_if_composable)
also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
using assms 0 w k.antipar cospan comp_arr_dom by simp
also have "... = (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>)"
using eq by blast
also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) ?RHS"
using assms w' \<theta>' \<beta> transpose_triangle by simp
finally have 4: "k.trnl\<^sub>\<epsilon> (h \<star> u) ?LHS = k.trnl\<^sub>\<epsilon> (h \<star> u) ?RHS"
by simp
have "src k = trg (p\<^sub>1 \<star> w)"
using assms 0 w k.antipar cospan by simp
moreover have "src k\<^sup>* = trg (h \<star> u)"
using assms 0 w k.antipar cospan by simp
moreover have "ide (h \<star> u)"
using assms 0 w k.antipar cospan by simp
moreover have "ide (p\<^sub>1 \<star> w)"
using assms 0 w k.antipar cospan by simp
ultimately have "inj_on (k.trnl\<^sub>\<epsilon> (h \<star> u)) (hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u))"
using assms 0 w w' k.antipar cospan k.adjoint_transpose_left(6) bij_betw_imp_inj_on
by blast
moreover have "?LHS \<in> hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"
proof -
have "\<guillemotleft>\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) :
p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> u\<guillemotright>"
using k.antipar cospan
apply (intro comp_in_homI)
apply auto
by auto
thus ?thesis by simp
qed
moreover have "?RHS \<in> hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"
proof -
have "\<guillemotleft>\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>') \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w'] \<cdot>
(tab \<star> w') \<cdot> \<beta> : p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> u\<guillemotright>"
using \<beta> k.antipar cospan
apply (intro comp_in_homI)
apply auto
by auto
thus ?thesis by blast
qed
ultimately show "?LHS = ?RHS"
using assms 4 k.antipar cospan bij_betw_imp_inj_on
inj_on_def [of "k.trnl\<^sub>\<epsilon> (h \<star> u)" "hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"]
by simp
qed
moreover have "seq \<a>[k\<^sup>*, h, u] (composite_cell w \<theta>)"
using assms k.antipar cospan tab_in_hom hseqI'
apply (intro seqI hseqI) by auto
moreover have "seq \<a>[k\<^sup>*, h, u] (composite_cell w' \<theta>' \<cdot> \<beta>)"
using assms \<beta> k.antipar cospan tab_in_hom hseqI'
apply (intro seqI hseqI) by auto
ultimately have "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
using assms 0 w w' \<beta> k.antipar cospan iso_assoc iso_is_section section_is_mono
monoE [of "\<a>[k\<^sup>*, h, u]" "composite_cell w \<theta>" "composite_cell w' \<theta>' \<cdot> \<beta>"]
comp_assoc
by simp
thus ?thesis
using w w' \<theta> \<theta>' \<beta> eq' T2 [of w w' \<theta> u \<theta>' \<beta>] by metis
qed
qed
text \<open>
Using the uniqueness properties established for \<open>\<phi>\<close>, we obtain yet another reformulation
of the biuniversal property associated with the chosen tabulation of \<open>k\<^sup>* \<star> h\<close>,
this time as a kind of pseudo-pullback. We will use this to show that the
category of isomorphism classes of maps has pullbacks.
\<close>
lemma has_pseudo_pullback:
assumes "is_left_adjoint u" and "is_left_adjoint v" and "isomorphic (k \<star> v) (h \<star> u)"
shows "\<exists>w. is_left_adjoint w \<and> isomorphic (p\<^sub>0 \<star> w) u \<and> isomorphic v (p\<^sub>1 \<star> w)"
and "\<And>w w'. \<lbrakk> is_left_adjoint w; is_left_adjoint w';
p\<^sub>0 \<star> w \<cong> u; v \<cong> p\<^sub>1 \<star> w; p\<^sub>0 \<star> w' \<cong> u; v \<cong> p\<^sub>1 \<star> w' \<rbrakk> \<Longrightarrow> w \<cong> w'"
proof -
interpret u: map_in_bicategory V H \<a> \<i> src trg u
using assms(1) by (unfold_locales, auto)
interpret v: map_in_bicategory V H \<a> \<i> src trg v
using assms(2) by (unfold_locales, auto)
obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright> \<and> iso \<mu>"
using assms(3) by auto
obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and>
\<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
using assms \<mu> \<phi>_biuniversal_prop(1) [of u v \<mu>] by auto
have "is_left_adjoint w \<and> isomorphic (p\<^sub>0 \<star> w) u \<and> isomorphic v (p\<^sub>1 \<star> w)"
proof (intro conjI)
show 1: "is_left_adjoint w"
using assms(2) w\<theta>\<nu> left_adjoint_preserved_by_iso' isomorphic_def BS4 leg1_is_map
by blast
show "v \<cong> p\<^sub>1 \<star> w"
using w\<theta>\<nu> isomorphic_def by blast
show "p\<^sub>0 \<star> w \<cong> u"
proof -
have "src p\<^sub>0 = trg w"
using w\<theta>\<nu> ide_dom
by (metis ideD(1) in_homE not_arr_null seq_if_composable)
hence "is_left_adjoint (p\<^sub>0 \<star> w)"
using 1 left_adjoints_compose by simp
thus ?thesis
using assms w\<theta>\<nu> 1 BS3 isomorphic_def by metis
qed
qed
thus "\<exists>w. is_left_adjoint w \<and> p\<^sub>0 \<star> w \<cong> u \<and> v \<cong> p\<^sub>1 \<star> w"
by blast
show "\<And>w w'. \<lbrakk> is_left_adjoint w; is_left_adjoint w';
p\<^sub>0 \<star> w \<cong> u; v \<cong> p\<^sub>1 \<star> w; p\<^sub>0 \<star> w' \<cong> u; v \<cong> p\<^sub>1 \<star> w' \<rbrakk> \<Longrightarrow> w \<cong> w'"
proof -
fix w w'
assume w: "is_left_adjoint w" and w': "is_left_adjoint w'"
assume 1: "p\<^sub>0 \<star> w \<cong> u"
assume 2: "v \<cong> p\<^sub>1 \<star> w"
assume 3: "p\<^sub>0 \<star> w' \<cong> u"
assume 4: "v \<cong> p\<^sub>1 \<star> w'"
obtain \<theta> where \<theta>: "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
using 1 by auto
obtain \<theta>' where \<theta>': "\<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
using 3 by auto
obtain \<nu> where \<nu>: "\<guillemotleft>\<nu>: v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
using 2 by blast
obtain \<nu>' where \<nu>': "\<guillemotleft>\<nu>': v \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>'"
using 4 by blast
let ?\<beta> = "\<nu>' \<cdot> inv \<nu>"
have \<beta>: "\<guillemotleft>?\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>"
using \<nu> \<nu>' by (elim conjE in_homE, auto)
interpret uw\<theta>: uw\<theta> V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close> u w \<theta>
using w \<theta> left_adjoint_is_ide
by (unfold_locales, auto)
interpret uw'\<theta>': uw\<theta> V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close>
u w' \<theta>'
using w' \<theta>' left_adjoint_is_ide
by (unfold_locales, auto)
interpret uw\<theta>w'\<theta>': uw\<theta>w'\<theta>' V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close> u w \<theta> w' \<theta>'
using w w' \<theta> \<theta>' left_adjoint_is_ide by unfold_locales
have "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
(h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot>
(k \<star> ?\<beta>)"
proof -
let ?LHS = "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
let ?RHS = "(h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> ?\<beta>)"
have "\<guillemotleft>?LHS : k \<star> p\<^sub>1 \<star> w \<Rightarrow> h \<star> u\<guillemotright>"
using w k.antipar by fastforce
moreover have "\<guillemotleft>?RHS : k \<star> p\<^sub>1 \<star> w \<Rightarrow> h \<star> u\<guillemotright>"
using w k.antipar \<beta> by fastforce
moreover have "is_left_adjoint (k \<star> p\<^sub>1 \<star> w)"
using w k.is_map left_adjoints_compose by simp
moreover have "is_left_adjoint (h \<star> u)"
using assms h.is_map left_adjoints_compose by auto
ultimately show "?LHS = ?RHS"
using BS3 by blast
qed
hence "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = ?\<beta>"
using assms left_adjoint_is_ide w w' \<theta> \<theta>' \<nu> \<nu>' \<beta>
\<phi>_biuniversal_prop(2) [of u v w w' \<theta> \<theta>' ?\<beta>]
by presburger
thus "w \<cong> w'"
using w w' BS3 isomorphic_def by metis
qed
qed
end
subsubsection "Tabulations in Maps"
text \<open>
Here we focus our attention on the properties of tabulations in a bicategory of spans,
in the special case in which both legs are maps.
\<close>
context tabulation_in_maps
begin
text \<open>
The following are the conditions under which \<open>w\<close> is a 1-cell induced via \<open>T1\<close> by
a 2-cell \<open>\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>\<close>: \<open>w\<close> is an arrow of spans and \<open>\<omega>\<close> is obtained by
composing the tabulation \<open>\<sigma>\<close> with \<open>w\<close> and the isomorphisms that witness \<open>w\<close> being
an arrow of spans.
\<close>
abbreviation is_induced_by_cell
where "is_induced_by_cell w r\<^sub>0 \<omega> \<equiv>
arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<omega>) s\<^sub>0 s\<^sub>1 w \<and>
composite_cell w (arrow_of_spans_of_maps.the_\<theta> V H r\<^sub>0 s\<^sub>0 w) \<cdot>
(arrow_of_spans_of_maps.the_\<nu> V H (dom \<omega>) s\<^sub>1 w) = \<omega>"
lemma induced_map_unique:
assumes "is_induced_by_cell w r\<^sub>0 \<omega>" and "is_induced_by_cell w' r\<^sub>0 \<omega>"
shows "isomorphic w w'"
proof -
interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s\<^sub>0 s\<^sub>1 w
using assms(1) by auto
interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w
..
- interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 "dom \<omega>" s\<^sub>0 s\<^sub>1 w'
+ interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s\<^sub>0 s\<^sub>1 w'
using assms(2) by auto
interpret w': arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w'
..
let ?\<beta> = "w'.the_\<nu> \<cdot> inv w.the_\<nu>"
have \<beta>: "\<guillemotleft>?\<beta> : s\<^sub>1 \<star> w \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
using w.the_\<nu>_props w'.the_\<nu>_props arr_iff_in_hom by auto
have 1: "composite_cell w w.the_\<theta> = composite_cell w' w'.the_\<theta> \<cdot> (w'.the_\<nu> \<cdot> inv w.the_\<nu>)"
proof -
have "composite_cell w' w'.the_\<theta> \<cdot> (w'.the_\<nu> \<cdot> inv w.the_\<nu>) =
((composite_cell w' w'.the_\<theta>) \<cdot> w'.the_\<nu>) \<cdot> inv w.the_\<nu>"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = \<omega> \<cdot> inv w.the_\<nu>"
using assms(2) comp_assoc by simp
also have "... = (composite_cell w w.the_\<theta> \<cdot> w.the_\<nu>) \<cdot> inv w.the_\<nu>"
using assms(1) comp_assoc by simp
also have "... = composite_cell w w.the_\<theta> \<cdot> w.the_\<nu> \<cdot> inv w.the_\<nu>"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = composite_cell w w.the_\<theta>"
proof -
have "w.the_\<nu> \<cdot> inv w.the_\<nu> = s\<^sub>1 \<star> w"
using w.the_\<nu>_props comp_arr_inv inv_is_inverse by auto
thus ?thesis
using composite_cell_in_hom w.ide_w w.the_\<theta>_props comp_arr_dom
by (metis composite_cell_in_hom in_homE w.w_in_hom(1))
qed
finally show ?thesis by auto
qed
have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
using 1 \<beta> w.is_ide w'.is_ide w.the_\<theta>_props w'.the_\<theta>_props
T2 [of w w' w.the_\<theta> r\<^sub>0 w'.the_\<theta> ?\<beta>]
by blast
thus ?thesis
using BS3 w.is_map w'.is_map by blast
qed
text \<open>
The object src \<open>s\<^sub>0\<close> forming the apex of the tabulation satisfies the conditions for
being a map induced via \<open>T1\<close> by the 2-cell \<open>\<sigma>\<close> itself. This is ultimately required
for the map from 2-cells to arrows of spans to be functorial with respect to vertical
composition.
\<close>
lemma apex_is_induced_by_cell:
shows "is_induced_by_cell (src s\<^sub>0) s\<^sub>0 \<sigma>"
proof -
have 1: "arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1 s\<^sub>0 s\<^sub>1 (src s\<^sub>0)"
using iso_runit [of s\<^sub>0] iso_runit [of s\<^sub>1] tab_in_hom
apply unfold_locales
apply simp
using ide_leg0 isomorphic_def
apply blast
using ide_leg1 isomorphic_def leg1_simps(3) runit'_in_vhom [of s\<^sub>1 "src s\<^sub>0"] iso_runit'
by blast
interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 \<open>dom \<sigma>\<close> s\<^sub>0 s\<^sub>1 \<open>src s\<^sub>0\<close>
using 1 tab_in_hom by simp
interpret w: arrow_of_spans_of_maps_to_tabulation
V H \<a> \<i> src trg s\<^sub>0 \<open>dom \<sigma>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 \<open>src s\<^sub>0\<close>
..
show "is_induced_by_cell (src s\<^sub>0) s\<^sub>0 \<sigma>"
proof (intro conjI)
show "arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 (dom \<sigma>) s\<^sub>0 s\<^sub>1 (src s\<^sub>0)"
using w.arrow_of_spans_of_maps_axioms by simp
show "composite_cell (src s\<^sub>0) w.the_\<theta> \<cdot> w.the_\<nu> = \<sigma>"
proof -
have \<theta>: "w.the_\<theta> = \<r>[s\<^sub>0]"
using iso_runit [of s\<^sub>0] w.leg0_uniquely_isomorphic w.the_\<theta>_props
the1_equality [of "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> src s\<^sub>0 \<Rightarrow> s\<^sub>0\<guillemotright> \<and> iso \<theta>"]
by auto
have \<nu>: "w.the_\<nu> = \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
using iso_runit' w.leg1_uniquely_isomorphic w.the_\<nu>_props leg1_simps(3)
the1_equality [of "\<lambda>\<nu>. \<guillemotleft>\<nu> : s\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> src s\<^sub>0\<guillemotright> \<and> iso \<nu>"] tab_in_vhom'
by auto
have "composite_cell (src s\<^sub>0) \<r>[s\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1] = \<sigma>"
proof -
have "composite_cell (src s\<^sub>0) \<r>[s\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1] =
((s \<star> \<r>[s\<^sub>0]) \<cdot> \<a>[s, s\<^sub>0, src s\<^sub>0]) \<cdot> (\<sigma> \<star> src s\<^sub>0) \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (\<r>[s \<star> s\<^sub>0] \<cdot> (\<sigma> \<star> src s\<^sub>0)) \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
using runit_hcomp comp_assoc by simp
also have "... = \<sigma> \<cdot> \<r>[s\<^sub>1] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
using runit_naturality tab_in_hom
by (metis tab_simps(1) tab_simps(2) tab_simps(4) tab_simps(5) comp_assoc)
also have "... = \<sigma>"
using iso_runit tab_in_hom comp_arr_dom comp_arr_inv inv_is_inverse by simp
finally show ?thesis by simp
qed
thus ?thesis
using \<theta> \<nu> comp_assoc by simp
qed
qed
qed
end
subsubsection "Composing Tabulations"
text \<open>
Given tabulations \<open>(r\<^sub>0, \<rho>, r\<^sub>1)\<close> of \<open>r\<close> and \<open>(s\<^sub>0, \<sigma>, s\<^sub>1)\<close> of \<open>s\<close> in a bicategory of spans,
where \<open>(r\<^sub>0, r\<^sub>1)\<close> and \<open>(s\<^sub>0, s\<^sub>1)\<close> are spans of maps and 1-cells \<open>r\<close> and \<open>s\<close> are composable,
we can construct a 2-cell that yields a tabulation of \<open>r \<star> s\<close>.
The proof uses the fact that the 2-cell \<open>\<phi>\<close> associated with the cospan \<open>(r\<^sub>0, s\<^sub>1)\<close>
is an isomorphism, which we have proved above
(\<open>cospan_of_maps_in_bicategory_of_spans.\<phi>_uniqueness\<close>) using \<open>BS3\<close>.
However, this is the only use of \<open>BS3\<close> in the proof, and it seems plausible that it would be
possible to establish that \<open>\<phi>\<close> is an isomorphism in more general situations in which the
subbicategory of maps is not locally essentially discrete. Alternatively, more general
situations could be treated by adding the assertion that \<open>\<phi>\<close> is an isomorphism as part of
a weakening of \<open>BS3\<close>.
\<close>
locale composite_tabulation_in_maps =
bicategory_of_spans V H \<a> \<i> src trg +
\<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
\<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and \<rho> :: 'a
and r\<^sub>0 :: 'a
and r\<^sub>1 :: 'a
and s :: 'a
and \<sigma> :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a +
assumes composable: "src r = trg s"
begin
text \<open>
Interpret \<open>(r\<^sub>0, s\<^sub>1)\<close> as a @{locale cospan_of_maps_in_bicategory_of_spans},
to obtain the isomorphism \<open>\<phi>\<close> in the central diamond, along with the assertion
that it is unique.
\<close>
interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0
using \<rho>.leg0_is_map \<sigma>.leg1_is_map composable by (unfold_locales, auto)
text \<open>
We need access to simps, etc. in the preceding interpretation, yet trying to declare
it as a sublocale introduces too many conflicts at the moment.
As it confusing elsewhere to figure out exactly how, in other contexts, to express
the particular interpretation that is needed, to make things easier we include the
following lemma. Then we can just recall the lemma to find out how to express
the interpretation required in a given context.
\<close>
lemma r\<^sub>0s\<^sub>1_is_cospan:
shows "cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0"
..
text \<open>
The following define the projections associated with the natural tabulation of \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>.
\<close>
abbreviation p\<^sub>0
where "p\<^sub>0 \<equiv> r\<^sub>0s\<^sub>1.p\<^sub>0"
abbreviation p\<^sub>1
where "p\<^sub>1 \<equiv> r\<^sub>0s\<^sub>1.p\<^sub>1"
text \<open>
$$
\xymatrix{
&& {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
$$
\<close>
text \<open>
Next, we define the 2-cell that is the composite of the tabulation \<open>\<sigma>\<close>, the tabulation \<open>\<rho>\<close>,
and the central diamond that commutes up to unique isomorphism \<open>\<phi>\<close>.
\<close>
definition tab
where "tab \<equiv> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1)"
lemma tab_in_hom [intro]:
shows "\<guillemotleft>tab : r\<^sub>1 \<star> p\<^sub>1 \<Rightarrow> (r \<star> s) \<star> s\<^sub>0 \<star> p\<^sub>0\<guillemotright>"
using \<rho>.T0.antipar(1) r\<^sub>0s\<^sub>1.\<phi>_in_hom composable \<rho>.leg0_in_hom(1) \<sigma>.leg1_in_hom(1)
hseqI' composable
by (unfold tab_def, intro comp_in_homI, auto)
interpretation tabulation_data V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
using composable tab_in_hom
by (unfold_locales, auto)
text \<open>
In the subsequent proof we will use coherence to shortcut a few of the calculations.
\<close>
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
text \<open>
The following is applied twice in the proof of property \<open>T2\<close> for the composite
tabulation. It's too long to repeat.
\<close>
lemma technical:
assumes "ide w"
and "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
and "w\<^sub>r = p\<^sub>1 \<star> w"
and "\<theta>\<^sub>r = (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
shows "\<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r = \<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
text \<open>
$$
\xymatrix{
&& X \ar[d]^{w} \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta}} \\
&& {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
$$
\<close>
proof -
interpret uw\<theta>: uw\<theta> V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close> u w \<theta>
using assms(1-2) composable
by (unfold_locales, auto)
show ?thesis
proof -
have "\<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
(\<a>[r, s, u] \<cdot> ((r \<star> s) \<star> \<theta>)) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (r \<star> s \<star> \<theta>) \<cdot> \<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using assoc_naturality [of r s \<theta>] composable comp_assoc by simp
also have "... = (r \<star> s \<star> \<theta>) \<cdot> \<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
((\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
\<rho>.composite_cell p\<^sub>1 r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
unfolding tab_def
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
((r \<star> \<sigma> \<star> p\<^sub>0) \<cdot> \<rho>.composite_cell p\<^sub>1 r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using composable \<rho>.T0.antipar(1) hseqI' comp_assoc whisker_right by auto
also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
(\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using composable \<rho>.T0.antipar(1) whisker_right tab_def tab_in_hom(2)
composable hseqI' comp_assoc
by force
also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
((\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]) \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
using assoc'_naturality [of \<rho> p\<^sub>1 w] \<rho>.T0.antipar(1) r\<^sub>0s\<^sub>1.base_simps(2) comp_assoc
by auto
also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w]) \<cdot> \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "(\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
proof -
have "(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) =
\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1 \<star> w]"
using pentagon' \<rho>.T0.antipar(1) comp_assoc by simp
moreover have 1: "seq (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w)(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]))"
using \<rho>.T0.antipar(1)
by (intro seqI hseqI, auto simp add: hseqI')
ultimately
have "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
((\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
using \<rho>.T0.antipar(1) iso_inv_iso iso_assoc inv_inv
invert_side_of_triangle(2)
[of "(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])"
"\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]" "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1 \<star> w]"]
by fastforce
hence "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
- using comp_assoc by simp
+ using comp_assoc by presburger
moreover have "seq (inv (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w)) \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
using \<rho>.T0.antipar(1) iso_inv_iso 1 hseqI'
by (intro seqI hseqI, auto)
ultimately show ?thesis
using \<rho>.T0.antipar(1) iso_inv_iso iso_assoc inv_inv inv_hcomp
invert_side_of_triangle(1)
[of "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]" "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w"
"\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"]
by fastforce
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
(((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w]) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] = \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w] \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
using assoc'_naturality [of r r\<^sub>0s\<^sub>1.\<phi> w] r\<^sub>0s\<^sub>1.cospan by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (r \<star> s \<star> \<theta>) \<cdot>
(\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w]) \<cdot>
(r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w] =
\<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w)"
using assoc'_naturality [of r "\<sigma> \<star> p\<^sub>0" w]
by (simp add: composable hseqI')
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (r \<star> s \<star> \<theta>) \<cdot>
(r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
((r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
proof -
have "\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] =
r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]"
proof -
have "\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] =
\<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, (\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
using \<alpha>_def \<a>'_def composable by simp
also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
using composable
by (intro E.eval_eqI, simp_all)
also have "... = r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]"
using \<alpha>_def \<a>'_def composable by simp
finally show ?thesis by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (r \<star> s \<star> \<theta>) \<cdot>
(r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
\<rho>.composite_cell (p\<^sub>1 \<star> w)
(((\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])"
using assms(3) arrI \<rho>.T0.antipar(1) hseqI' whisker_left by auto
also have "... = (r \<star> (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
(\<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot> ((\<sigma> \<star> p\<^sub>0) \<star> w)) \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
using \<rho>.T0.antipar(1) hseqI' comp_assoc whisker_left by auto
also have "... = (r \<star> (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
using assoc_naturality [of \<sigma> p\<^sub>0 w] comp_assoc by simp
finally show ?thesis
using assms(3-4) by simp
qed
qed
lemma composite_is_tabulation:
shows "tabulation V H \<a> \<i> src trg (r \<star> s) tab (s\<^sub>0 \<star> p\<^sub>0) (r\<^sub>1 \<star> p\<^sub>1)"
proof
show "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> (r \<star> s) \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright> \<and>
\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright> \<and> iso \<nu> \<and>
composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
proof -
fix u \<omega>
assume u: "ide u"
assume \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> (r \<star> s) \<star> u\<guillemotright>"
let ?v = "dom \<omega>"
have 1: "\<guillemotleft>\<a>[r, s, u] \<cdot> \<omega> : ?v \<Rightarrow> r \<star> s \<star> u\<guillemotright>"
proof -
(*
* TODO: I think this highlights the current issue with assoc_in_hom:
* it can't be applied automatically here because there isn't any way to
* obtain the equations src r = trg s and src s = trg u from assumption \<omega>.
* Maybe this can be improved with a little bit of thought, but not while
* a lot of other stuff is being changed, too.
*)
have "src r = trg s \<and> src s = trg u"
by (metis \<omega> arr_cod hseq_char in_homE hcomp_simps(1))
thus ?thesis
using u \<omega> hseqI'
by (intro comp_in_homI, auto)
qed
obtain w\<^sub>r \<theta>\<^sub>r \<nu>\<^sub>r
where w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r: "ide w\<^sub>r \<and> \<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright> \<and>
\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright> \<and> iso \<nu>\<^sub>r \<and>
\<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r \<cdot> \<nu>\<^sub>r = \<a>[r, s, u] \<cdot> \<omega>"
using u \<omega> \<rho>.T1 [of "s \<star> u" "\<a>[r, s, u] \<cdot> \<omega>"]
by (metis 1 \<rho>.ide_base \<sigma>.ide_base arr_cod composable ide_hcomp in_homE
match_1 not_arr_null seq_if_composable)
text \<open>
$$
\xymatrix{
&& X \ar@ {.>}[ddl]^{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
\ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r}} \\
&& \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& \\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
$$
\<close>
text \<open>We need some simps, etc., otherwise the subsequent diagram chase is very painful.\<close>
have w\<^sub>r: "ide w\<^sub>r"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
have [simp]: "src w\<^sub>r = src u"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r
by (metis \<omega> 1 comp_arr_dom in_homE seqE hcomp_simps(1) vseq_implies_hpar(1))
have [simp]: "trg w\<^sub>r = src \<rho>"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r
by (metis 1 arrI not_arr_null seqE seq_if_composable)
have \<theta>\<^sub>r_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright>"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
have \<theta>\<^sub>r_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>r : src u \<rightarrow> trg s\<guillemotright>"
using \<theta>\<^sub>r_in_hom src_cod [of \<theta>\<^sub>r] trg_cod [of \<theta>\<^sub>r]
by (metis arr_cod in_hhom_def in_homE hcomp_simps(1-2))
have [simp]: "src \<theta>\<^sub>r = src u" using \<theta>\<^sub>r_in_hhom by auto
have [simp]: "trg \<theta>\<^sub>r = trg s" using \<theta>\<^sub>r_in_hhom by auto
have [simp]: "dom \<theta>\<^sub>r = r\<^sub>0 \<star> w\<^sub>r" using \<theta>\<^sub>r_in_hom by blast
have [simp]: "cod \<theta>\<^sub>r = s \<star> u" using \<theta>\<^sub>r_in_hom by blast
have \<nu>\<^sub>r_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright>" using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
have \<nu>\<^sub>r_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>r : src u \<rightarrow> trg r\<guillemotright>"
using \<nu>\<^sub>r_in_hom src_dom [of \<nu>\<^sub>r] trg_dom [of \<nu>\<^sub>r]
by (metis \<rho>.leg1_simps(4) arr_cod arr_dom_iff_arr cod_trg in_hhomI in_homE
src_cod src_dom src_hcomp' trg.preserves_cod hcomp_simps(2) w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r)
have [simp]: "src \<nu>\<^sub>r = src u" using \<nu>\<^sub>r_in_hhom by auto
have [simp]: "trg \<nu>\<^sub>r = trg r" using \<nu>\<^sub>r_in_hhom by auto
have [simp]: "dom \<nu>\<^sub>r = ?v" using \<nu>\<^sub>r_in_hom by auto
have [simp]: "cod \<nu>\<^sub>r = r\<^sub>1 \<star> w\<^sub>r" using \<nu>\<^sub>r_in_hom by auto
have iso_\<nu>\<^sub>r: "iso \<nu>\<^sub>r" using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
obtain w\<^sub>s \<theta>\<^sub>s \<nu>\<^sub>s
where w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s: "ide w\<^sub>s \<and> \<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu>\<^sub>s : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s\<^sub>1 \<star> w\<^sub>s\<guillemotright> \<and> iso \<nu>\<^sub>s \<and>
\<sigma>.composite_cell w\<^sub>s \<theta>\<^sub>s \<cdot> \<nu>\<^sub>s = \<theta>\<^sub>r"
using u w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<sigma>.T1 [of u \<theta>\<^sub>r] by auto
text \<open>
$$
\xymatrix{
&& X \ar[ddl]^{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
\ar@/ur20pt/[dddrr]^{u} \ar@ {.>}[ddr]_{w_s} \xtwocell[dddrr]{}\omit{^{<-1.5>\theta_s}}
\xtwocell[ddd]{}\omit{^{<1>\nu_s}} \\
&& \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
$$
\<close>
have w\<^sub>s: "ide w\<^sub>s"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
have [simp]: "src w\<^sub>s = src u"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s src_cod
by (metis arr_dom in_homE src_dom hcomp_simps(1))
have [simp]: "trg w\<^sub>s = src \<sigma>"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s
by (metis \<sigma>.tab_simps(2) arr_dom in_homE not_arr_null seq_if_composable)
have \<theta>\<^sub>s_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright>"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
have \<theta>\<^sub>s_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>s : src u \<rightarrow> src s\<guillemotright>"
using \<theta>\<^sub>s_in_hom src_cod trg_cod
by (metis \<sigma>.leg0_simps(3) arr_dom in_hhom_def in_homE trg_dom hcomp_simps(2))
have [simp]: "src \<theta>\<^sub>s = src u" using \<theta>\<^sub>s_in_hhom by auto
have [simp]: "trg \<theta>\<^sub>s = src s" using \<theta>\<^sub>s_in_hhom by auto
have [simp]: "dom \<theta>\<^sub>s = s\<^sub>0 \<star> w\<^sub>s" using \<theta>\<^sub>s_in_hom by blast
have [simp]: "cod \<theta>\<^sub>s = u" using \<theta>\<^sub>s_in_hom by blast
have \<nu>\<^sub>s_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>s : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s\<^sub>1 \<star> w\<^sub>s\<guillemotright>" using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
have \<nu>\<^sub>s_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>s : src u \<rightarrow> trg s\<guillemotright>"
using \<nu>\<^sub>s_in_hom src_dom trg_cod
by (metis \<open>src \<theta>\<^sub>r = src u\<close> \<open>trg \<theta>\<^sub>r = trg s\<close> \<theta>\<^sub>r_in_hom in_hhomI in_homE src_dom trg_dom)
have [simp]: "src \<nu>\<^sub>s = src u" using \<nu>\<^sub>s_in_hhom by auto
have [simp]: "trg \<nu>\<^sub>s = trg s" using \<nu>\<^sub>s_in_hhom by auto
have [simp]: "dom \<nu>\<^sub>s = r\<^sub>0 \<star> w\<^sub>r" using \<nu>\<^sub>s_in_hom by auto
have [simp]: "cod \<nu>\<^sub>s = s\<^sub>1 \<star> w\<^sub>s" using \<nu>\<^sub>s_in_hom by auto
have iso_\<nu>\<^sub>s: "iso \<nu>\<^sub>s" using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
obtain w \<theta>\<^sub>t \<nu>\<^sub>t
where w\<theta>\<^sub>t\<nu>\<^sub>t: "ide w \<and> \<guillemotleft>\<theta>\<^sub>t : p\<^sub>0 \<star> w \<Rightarrow> w\<^sub>s\<guillemotright> \<and> \<guillemotleft>\<nu>\<^sub>t : w\<^sub>r \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>\<^sub>t \<and>
(s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) = \<nu>\<^sub>s"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s iso_\<nu>\<^sub>s r\<^sub>0s\<^sub>1.\<phi>_biuniversal_prop(1) [of w\<^sub>s w\<^sub>r \<nu>\<^sub>s] by blast
text \<open>
$$
\xymatrix{
&& X \ar[ddl]_{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
\ar@/ur20pt/[dddrr]^{u} \ar[ddr]^{w_s} \xtwocell[dddrr]{}\omit{^{<-1.5>\theta_s}}
\ar@ {.>}[d]^{w} \xtwocell[ddl]{}\omit{^<-2>{\nu_t}} \xtwocell[ddr]{}\omit{^<2>{\theta_t}} \\
&& {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
$$
\<close>
text \<open>{\bf Note:} \<open>w\<close> is not necessarily a map.\<close>
have w: "ide w"
using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
have [simp]: "src w = src u"
using w\<theta>\<^sub>t\<nu>\<^sub>t src_cod
by (metis \<nu>\<^sub>s_in_hom \<open>src \<nu>\<^sub>s = src u\<close> in_homE seqE hcomp_simps(1) src_vcomp
vseq_implies_hpar(1))
have [simp]: "trg w = src p\<^sub>0"
using w\<theta>\<^sub>t\<nu>\<^sub>t
by (metis \<nu>\<^sub>s_in_hom arrI not_arr_null r\<^sub>0s\<^sub>1.\<phi>_simps(2) seqE seq_if_composable)
have \<theta>\<^sub>t_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>t : p\<^sub>0 \<star> w \<Rightarrow> w\<^sub>s\<guillemotright>"
using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
have \<theta>\<^sub>t_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>t : src u \<rightarrow> src \<sigma>\<guillemotright>"
using \<theta>\<^sub>t_in_hom src_cod trg_cod \<open>src w\<^sub>s = src u\<close> \<open>trg w\<^sub>s = src \<sigma>\<close> by fastforce
have [simp]: "src \<theta>\<^sub>t = src u" using \<theta>\<^sub>t_in_hhom by auto
have [simp]: "trg \<theta>\<^sub>t = src \<sigma>" using \<theta>\<^sub>t_in_hhom by auto
have [simp]: "dom \<theta>\<^sub>t = p\<^sub>0 \<star> w" using \<theta>\<^sub>t_in_hom by blast
have (* [simp]: *) "cod \<theta>\<^sub>t = w\<^sub>s" using \<theta>\<^sub>t_in_hom by blast
have \<nu>\<^sub>t_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>t : w\<^sub>r \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright>" using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
have \<nu>\<^sub>t_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>t : src u \<rightarrow> src \<rho>\<guillemotright>"
using \<nu>\<^sub>t_in_hom src_dom trg_dom \<open>src w\<^sub>r = src u\<close> \<open>trg w\<^sub>r = src \<rho>\<close> by fastforce
have [simp]: "src \<nu>\<^sub>t = src u" using \<nu>\<^sub>t_in_hhom by auto
have [simp]: "trg \<nu>\<^sub>t = src \<rho>" using \<nu>\<^sub>t_in_hhom by auto
have (* [simp]: *) "dom \<nu>\<^sub>t = w\<^sub>r" using \<nu>\<^sub>t_in_hom by auto
have [simp]: "cod \<nu>\<^sub>t = p\<^sub>1 \<star> w" using \<nu>\<^sub>t_in_hom by auto
have iso_\<nu>\<^sub>t: "iso \<nu>\<^sub>t" using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
define \<theta> where "\<theta> = \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
have \<theta>: "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
proof (unfold \<theta>_def, intro comp_in_homI)
show "\<guillemotleft>\<a>[s\<^sub>0, p\<^sub>0, w] : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> s\<^sub>0 \<star> p\<^sub>0 \<star> w\<guillemotright>"
using w\<theta>\<^sub>t\<nu>\<^sub>t by auto
show "\<guillemotleft>s\<^sub>0 \<star> \<theta>\<^sub>t : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0 \<star> w\<^sub>s\<guillemotright>"
using w\<theta>\<^sub>t\<nu>\<^sub>t by auto
show "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright>"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
qed
define \<nu> where "\<nu> = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
have \<nu>: "\<guillemotleft>\<nu> : ?v \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright>"
proof (unfold \<nu>_def, intro comp_in_homI)
show "\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright>"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by blast
show "\<guillemotleft>r\<^sub>1 \<star> \<nu>\<^sub>t : r\<^sub>1 \<star> w\<^sub>r \<Rightarrow> r\<^sub>1 \<star> p\<^sub>1 \<star> w\<guillemotright>"
using w\<theta>\<^sub>t\<nu>\<^sub>t by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] : r\<^sub>1 \<star> p\<^sub>1 \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright>"
using w\<theta>\<^sub>t\<nu>\<^sub>t assoc_in_hom by (simp add: \<rho>.T0.antipar(1))
qed
have iso_\<nu>: "iso \<nu>"
using \<nu> w\<theta>\<^sub>t\<nu>\<^sub>t w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<rho>.T0.antipar(1) iso_inv_iso
apply (unfold \<nu>_def, intro isos_compose) by auto
have *: "arr ((s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot> (\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t \<theta>\<^sub>r_in_hom comp_assoc by auto
have "((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = \<omega>"
proof -
have "seq (r \<star> \<theta>\<^sub>r) (\<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r)"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r hseqI' \<rho>.base_simps(2) composable by fastforce
hence "\<omega> = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> \<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r \<cdot> \<nu>\<^sub>r"
using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r invert_side_of_triangle(1) iso_assoc
by (metis 1 \<rho>.ide_base \<sigma>.ide_base arrI assoc'_eq_inv_assoc composable hseq_char'
seqE seq_if_composable u vconn_implies_hpar(2) vconn_implies_hpar(4) w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> \<rho>.composite_cell w\<^sub>r (\<sigma>.composite_cell w\<^sub>s \<theta>\<^sub>s \<cdot> \<nu>\<^sub>s) \<cdot> \<nu>\<^sub>r"
using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
using w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc by simp
text \<open>Rearrange to create \<open>\<theta>\<close> and \<open>\<nu>\<close>, leaving \<open>tab\<close> in the middle.\<close>
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
((\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t)) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (\<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t)) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
proof -
have "(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) = \<sigma> \<star> \<theta>\<^sub>t"
using comp_arr_dom comp_cod_arr interchange
by (metis \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> \<sigma>.tab_simps(1) \<sigma>.tab_simps(4) arrI w\<theta>\<^sub>t\<nu>\<^sub>t)
also have "... = ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
using comp_arr_dom comp_cod_arr interchange w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t \<sigma>.tab_in_hom
by (metis \<open>dom \<theta>\<^sub>t = p\<^sub>0 \<star> w\<close> \<sigma>.tab_simps(5) arrI)
finally have "(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) = ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
using assoc_naturality [of s s\<^sub>0 \<theta>\<^sub>t] w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> arrI by force
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot>
(\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
proof -
have "r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) =
(r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
proof -
have "seq ((s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t))
(\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
proof -
have "seq (s \<star> \<theta>\<^sub>s)
((s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
using \<open>\<guillemotleft>\<a>[r, s, u] \<cdot> \<omega> : dom \<omega> \<Rightarrow> r \<star> s \<star> u\<guillemotright>\<close> calculation by blast
thus ?thesis
using comp_assoc by presburger
qed
thus ?thesis
using whisker_left [of r "(s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
"\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)"]
w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc
by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> ((r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r]) \<cdot>
(\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
proof -
have "seq (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) (r\<^sub>0 \<star> \<nu>\<^sub>t)"
using 1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t
apply (intro seqI' comp_in_homI)
apply auto
apply auto
by (intro hcomp_in_vhom, auto)
hence "r \<star> (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) =
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> (r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t)"
using whisker_left by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
(((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r)) \<cdot> \<nu>\<^sub>r"
proof -
have "(r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] = \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> ((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t)"
using assoc_naturality [of r r\<^sub>0 \<nu>\<^sub>t] \<nu>\<^sub>t_in_hom by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t))) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
(\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r) = \<rho> \<star> \<nu>\<^sub>t"
using comp_arr_dom comp_cod_arr interchange
by (metis \<open>dom \<nu>\<^sub>t = w\<^sub>r\<close> \<rho>.tab_simps(1) \<rho>.tab_simps(5) arrI w\<theta>\<^sub>t\<nu>\<^sub>t)
also have "... = (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t)"
using comp_arr_dom comp_cod_arr interchange
by (metis \<open>cod \<nu>\<^sub>t = p\<^sub>1 \<star> w\<close> \<open>trg \<nu>\<^sub>t = src \<rho>\<close> \<rho>.T0.antipar(1) \<rho>.tab_simps(1)
\<rho>.tab_simps(2) \<rho>.tab_simps(4) r\<^sub>0s\<^sub>1.base_simps(2) trg.preserves_reflects_arr
trg_hcomp')
finally have "((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r) = (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t)" by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> ((\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
(\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) =
((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
proof -
have "seq (s \<star> \<theta>\<^sub>s) (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
using \<theta>\<^sub>s_in_hom \<theta>\<^sub>s_in_hhom \<theta>\<^sub>t_in_hom \<theta>\<^sub>t_in_hhom 1 calculation by blast
moreover have "src r = trg (s \<star> \<theta>\<^sub>s)"
using composable hseqI by force
ultimately
have "\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) =
(\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> s \<star> \<theta>\<^sub>s)) \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
using whisker_left comp_assoc by simp
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> w\<^sub>s] \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
using assoc_naturality comp_assoc
by (metis \<open>cod \<theta>\<^sub>s = u\<close> \<open>dom \<theta>\<^sub>s = s\<^sub>0 \<star> w\<^sub>s\<close> \<open>trg \<theta>\<^sub>s = src s\<close>
\<rho>.base_simps(2-4) \<sigma>.base_simps(2-4) arrI assoc'_naturality composable w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
also have "... = (((r \<star> s) \<star> \<theta>\<^sub>s) \<cdot> ((r \<star> s) \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
proof -
have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> w\<^sub>s] \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) =
((r \<star> s) \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
using arrI hseq_char assoc'_naturality [of r s "s\<^sub>0 \<star> \<theta>\<^sub>t"] \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> composable
by auto
thus ?thesis
using comp_assoc by auto
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
using \<theta>_def \<theta> whisker_left by force
finally show ?thesis by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot>
((r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot>
((\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] = \<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot> ((\<sigma> \<star> p\<^sub>0) \<star> w)"
using assoc_naturality [of \<sigma> p\<^sub>0 w] by (simp add: w\<theta>\<^sub>t\<nu>\<^sub>t)
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
(r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
((r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]) \<cdot>
(\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
using r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t hseqI' whisker_left comp_assoc by force
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
(r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
(\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]) \<cdot>
(\<rho> \<star> p\<^sub>1 \<star> w)) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] =
\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
proof -
have 1: "(r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) =
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
using pentagon
by (simp add: \<rho>.T0.antipar(1) w)
moreover have 2: "seq \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
using \<rho>.T0.antipar(1) w by simp
moreover have "inv (r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]) = r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using \<rho>.T0.antipar(1) w by simp
ultimately have "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) =
((r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]) \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
using \<rho>.T0.antipar(1) w comp_assoc
invert_side_of_triangle(1)
[of "\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]" "r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]"
"\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)"]
by simp
hence "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] =
(\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
using \<rho>.T0.antipar(1) w
invert_side_of_triangle(2)
[of "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)"
"(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]" "\<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"]
using \<open>trg w = src p\<^sub>0\<close> hseqI' by simp
thus ?thesis
- using comp_assoc by simp
- qed
- thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
+ qed
+ thus ?thesis
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
(r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w]) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w) = ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using assoc'_naturality [of \<rho> p\<^sub>1 w] by (simp add: \<rho>.T0.antipar(1) w\<theta>\<^sub>t\<nu>\<^sub>t)
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
(r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> ((r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w]) \<cdot>
((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "(r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] = \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w] \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w)"
using assoc_naturality [of r r\<^sub>0s\<^sub>1.\<phi> w] r\<^sub>0s\<^sub>1.cospan w\<theta>\<^sub>t\<nu>\<^sub>t by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
(r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot>
(((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot>
((\<rho> \<star> p\<^sub>1) \<star> w)) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "(r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w] =
\<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w)"
proof -
have "arr w \<and> dom w = w \<and> cod w = w"
- using ide_char w by presburger
+ using ide_char w by blast
then show ?thesis
using hseqI' assoc_naturality [of r "\<sigma> \<star> p\<^sub>0" w] composable by auto
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
(r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot>
((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w)) \<cdot>
(tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
proof -
have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) =
(r \<star> \<sigma> \<star> p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
using w \<rho>.T0.antipar(1) composable hseqI' whisker_right by auto
also have "... = (((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
proof -
have "((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) =
r \<star> \<sigma> \<star> p\<^sub>0"
proof -
have "((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot>
(r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) =
((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> ((r \<star> s \<star> s\<^sub>0 \<star> p\<^sub>0) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]))) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
using comp_assoc_assoc' by (simp add: composable)
also have "... = ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
using comp_cod_arr by (simp add: composable hseqI')
also have "... = ((r \<star> (s \<star> s\<^sub>0) \<star> p\<^sub>0)) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
using whisker_left comp_assoc_assoc' assoc_in_hom hseqI'
by (metis \<rho>.ide_base \<sigma>.base_simps(2) \<sigma>.ide_base \<sigma>.ide_leg0
\<sigma>.leg0_simps(2-3) \<sigma>.leg1_simps(3) r\<^sub>0s\<^sub>1.ide_leg0
r\<^sub>0s\<^sub>1.leg0_simps(2) r\<^sub>0s\<^sub>1.p\<^sub>0_simps hcomp_simps(1))
also have "... = r \<star> \<sigma> \<star> p\<^sub>0"
using comp_cod_arr
by (simp add: composable hseqI')
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = (r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> \<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> \<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> tab \<star> w"
using tab_def by simp
also have "... = ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) \<cdot> (tab \<star> w)"
using w \<rho>.T0.antipar(1) composable tab_in_hom hseqI' comp_assoc whisker_right
by auto
finally have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot>
((\<rho> \<star> p\<^sub>1) \<star> w) =
((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) \<cdot> (tab \<star> w)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w])) \<cdot>
\<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>"
proof -
have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
\<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) =
((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w]"
proof -
have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
\<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot>
(\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> (\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>)\<rbrace>"
using w comp_assoc \<a>'_def \<alpha>_def composable by simp
also have "... = \<lbrace>((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
using w composable
apply (intro E.eval_eqI) by simp_all
also have "... = ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w]"
using w comp_assoc \<a>'_def \<alpha>_def composable by simp
finally show ?thesis by simp
qed
thus ?thesis
using \<nu>_def comp_assoc by simp
qed
also have "... = ((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>"
proof -
have "((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) = (r \<star> s) \<star> \<theta>"
using \<theta>_def w whisker_left composable
by (metis \<theta> arrI ide_base comp_assoc)
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
finally show "((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = \<omega>"
by simp
qed
thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright> \<and>
\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright> \<and> iso \<nu> \<and>
composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
using w\<theta>\<^sub>t\<nu>\<^sub>t \<theta> \<nu> iso_\<nu> comp_assoc by metis
qed
show "\<And>u w w' \<theta> \<theta>' \<beta>.
\<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w' \<Rightarrow> u\<guillemotright>;
\<guillemotleft>\<beta> : (r\<^sub>1 \<star> p\<^sub>1) \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w'\<guillemotright>;
composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
proof -
fix u w w' \<theta> \<theta>' \<beta>
assume w: "ide w"
assume w': "ide w'"
assume \<theta>: "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
assume \<theta>': "\<guillemotleft>\<theta>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w' \<Rightarrow> u\<guillemotright>"
assume \<beta>: "\<guillemotleft>\<beta> : (r\<^sub>1 \<star> p\<^sub>1) \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w'\<guillemotright>"
assume eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
interpret uw\<theta>w'\<theta>'\<beta>: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg
\<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close> u w \<theta> w' \<theta>' \<beta>
using w w' \<theta> \<theta>' \<beta> eq composable tab_in_hom comp_assoc
by (unfold_locales, auto)
text \<open>
$$
\begin{array}{ll}
\xymatrix{
&& X \ar[d]_{w'} \xtwocell[ddl]{}\omit{^{\beta}}
\ar@/ul20pt/[dddll]_<>(0.25){w}|<>(0.33)@ {>}_<>(0.5){p_1}|<>(0.67)@ {>}_<>(0.75){r_1}
\ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta'}}\\
&& {\rm src}~\phi \ar[dl]^{p_1} \ar[dr]_{p_0} \ddtwocell\omit{^\phi} \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
\\
\hspace{5cm}
=
\qquad
\xy/50pt/
\xymatrix{
&& X \ar[d]_{w} \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta}}\\
&& {\rm src}~\phi \ar[dl]^{p_1} \ar[dr]_{p_0} \ddtwocell\omit{^\phi} \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
\endxy
\end{array}
$$
\<close>
text \<open>
First apply property \<open>\<rho>.T2\<close> using \<open>\<guillemotleft>\<beta>\<^sub>r : r\<^sub>1 \<star> p\<^sub>1 \<star> w \<Rightarrow> r\<^sub>1 \<star> p\<^sub>1 \<star> w'\<guillemotright>\<close>
(obtained by composing \<open>\<beta>\<close> with associativities) and ``everything to the right''
as \<open>\<theta>\<^sub>r\<close> and \<open>\<theta>\<^sub>r'\<close>. This yields \<open>\<guillemotleft>\<gamma>\<^sub>r : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>\<close>.
Next, apply property \<open>\<rho>.T2\<close> to obtain \<open>\<guillemotleft>\<gamma>\<^sub>s : p\<^sub>0 \<star> w \<Rightarrow> p\<^sub>0 \<star> w'\<guillemotright>\<close>.
For this use \<open>\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>\<^sub>s' : s\<^sub>0 \<star> p\<^sub>0 \<star> w'\<guillemotright>\<close>
obtained by composing \<open>\<theta>\<close> and \<open>\<theta>'\<close> with associativities.
We also need \<open>\<guillemotleft>\<beta>\<^sub>s : s\<^sub>1 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>1 \<star> p\<^sub>0 \<star> w'\<guillemotright>\<close>.
To get this, transport \<open>r\<^sub>0 \<star> \<gamma>\<^sub>r\<close> across \<open>\<phi>\<close>; we need \<open>\<phi>\<close> to be an isomorphism
in order to do this.
Finally, apply the biuniversal property of \<open>\<phi>\<close> to get \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>
and verify the required equation.
\<close>
let ?w\<^sub>r = "p\<^sub>1 \<star> w"
have w\<^sub>r: "ide ?w\<^sub>r" by simp
let ?w\<^sub>r' = "p\<^sub>1 \<star> w'"
have w\<^sub>r': "ide ?w\<^sub>r'" by simp
define \<theta>\<^sub>r where "\<theta>\<^sub>r = (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
have \<theta>\<^sub>r: "\<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> ?w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright>"
unfolding \<theta>\<^sub>r_def
using \<rho>.T0.antipar(1) hseqI'
by (intro comp_in_homI hcomp_in_vhom, auto)
define \<theta>\<^sub>r' where "\<theta>\<^sub>r' = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']"
have \<theta>\<^sub>r': "\<guillemotleft>\<theta>\<^sub>r' : r\<^sub>0 \<star> ?w\<^sub>r' \<Rightarrow> s \<star> u\<guillemotright>"
unfolding \<theta>\<^sub>r'_def
using \<rho>.T0.antipar(1) hseqI'
by (intro comp_in_homI hcomp_in_vhom, auto)
define \<beta>\<^sub>r where "\<beta>\<^sub>r = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
have \<beta>\<^sub>r: "\<guillemotleft>\<beta>\<^sub>r : r\<^sub>1 \<star> ?w\<^sub>r \<Rightarrow> r\<^sub>1 \<star> ?w\<^sub>r'\<guillemotright>"
unfolding \<beta>\<^sub>r_def
using \<rho>.T0.antipar(1)
by (intro comp_in_homI hcomp_in_vhom, auto)
have eq\<^sub>r: "\<rho>.composite_cell ?w\<^sub>r \<theta>\<^sub>r = \<rho>.composite_cell ?w\<^sub>r' \<theta>\<^sub>r' \<cdot> \<beta>\<^sub>r"
text \<open>
$$
\begin{array}{ll}
\xymatrix{
&& X \ar[ddl]^{w_r'} \xtwocell[dddll]{}\omit{^<2>{\beta_r}}
\ar@/ul20pt/[dddll]_<>(0.33){w_r}|<>(0.67)@ {>}_<>(0.75){r_1}
\ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r'}}\\
&& \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& \\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
\\
\hspace{5cm}
=\qquad
\xy/50pt/
\xymatrix{
&& X \ar[ddl]^{w_r} \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r}}\\
&& \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
&& \\
{\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
}
\endxy
\end{array}
$$
\<close>
proof -
have "\<rho>.composite_cell ?w\<^sub>r \<theta>\<^sub>r = \<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using \<theta>\<^sub>r_def technical uw\<theta>w'\<theta>'\<beta>.uw\<theta>.uw\<theta> by blast
also have "... = \<a>[r, s, u] \<cdot> (((r \<star> s) \<star> \<theta>') \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w'] \<cdot>
(tab \<star> w') \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using eq comp_assoc by simp
also have "... = (r \<star> \<theta>\<^sub>r') \<cdot> \<a>[r, r\<^sub>0, ?w\<^sub>r'] \<cdot> (\<rho> \<star> ?w\<^sub>r') \<cdot> \<beta>\<^sub>r"
proof -
have "\<a>[r, s, u] \<cdot> (composite_cell w' \<theta>' \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
\<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (r \<star> (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot>
\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w'] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w') \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
proof -
have "\<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
\<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot>
((\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using comp_cod_arr \<rho>.T0.antipar(1) \<beta> comp_assoc_assoc' by simp
also have "... = (\<a>[r, s, u] \<cdot> ((r \<star> s) \<star> \<theta>') \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w'] \<cdot> (tab \<star> w') \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = ((r \<star> (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w'] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w')) \<cdot>
\<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using \<theta>\<^sub>r'_def technical [of w' \<theta>' u ?w\<^sub>r' \<theta>\<^sub>r'] comp_assoc by fastforce
finally show ?thesis
using comp_assoc by simp
qed
finally show ?thesis
using \<theta>\<^sub>r'_def \<beta>\<^sub>r_def comp_assoc by auto
qed
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>"
using eq\<^sub>r \<rho>.T2 [of ?w\<^sub>r ?w\<^sub>r' \<theta>\<^sub>r "s \<star> u" \<theta>\<^sub>r' \<beta>\<^sub>r] w\<^sub>r w\<^sub>r' \<theta>\<^sub>r \<theta>\<^sub>r' \<beta>\<^sub>r by blast
obtain \<gamma>\<^sub>r where \<gamma>\<^sub>r: "\<guillemotleft>\<gamma>\<^sub>r : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>\<^sub>r"
using 1 by blast
let ?w\<^sub>s = "p\<^sub>0 \<star> w"
have w\<^sub>s: "ide ?w\<^sub>s" by simp
let ?w\<^sub>s' = "p\<^sub>0 \<star> w'"
have w\<^sub>s': "ide ?w\<^sub>s'" by simp
define \<theta>\<^sub>s where "\<theta>\<^sub>s = \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
have \<theta>\<^sub>s: "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
using \<theta>\<^sub>s_def by auto
define \<theta>\<^sub>s' where "\<theta>\<^sub>s' = \<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']"
have \<theta>\<^sub>s': "\<guillemotleft>\<theta>\<^sub>s' : s\<^sub>0 \<star> p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
using \<theta>\<^sub>s'_def by auto
define \<beta>\<^sub>s where "\<beta>\<^sub>s = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
have \<beta>\<^sub>s: "\<guillemotleft>\<beta>\<^sub>s : s\<^sub>1 \<star> ?w\<^sub>s \<Rightarrow> s\<^sub>1 \<star> ?w\<^sub>s'\<guillemotright>"
unfolding \<beta>\<^sub>s_def
using \<gamma>\<^sub>r r\<^sub>0s\<^sub>1.\<phi>_in_hom(2) r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1)
apply (intro comp_in_homI)
apply auto
by auto
have eq\<^sub>s: "\<sigma>.composite_cell (p\<^sub>0 \<star> w) (\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) =
\<sigma>.composite_cell (p\<^sub>0 \<star> w') (\<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<beta>\<^sub>s"
text \<open>
$$
\begin{array}{ll}
\xy/67pt/
\xymatrix{
&& X \ar[d]^{w'} \ar@/l10pt/[dl]_{w} \ddltwocell\omit{^{\gamma_r}}
\ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta_s'}}\\
& {\rm src}~\phi \ar[dr]_{p_1} \ar[d]_{p_0}
& {\rm src}~\phi \ar[d]^{p_1} \ar[dr]_{p_0} \ddrtwocell\omit{^\phi} \xtwocell[ddl]{}\omit{^\;\;\;\;\phi^{-1}} \\
& {\rm src}~\sigma \ar[dr]_{s_1} & {\rm src}~\rho \ar[d]^{r_0}
& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
&& {\rm src}~r = {\rm trg}~s && {\rm src}~s \ar[ll]^{s}
}
\endxy
\\
\hspace{5cm}=
\xy/50pt/
\xymatrix{
& X \ar@/dl15pt/[ddr]_<>(0.5){w_s}
\ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta_s}}\\
& \\
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
& {\rm src}~r = {\rm trg}~s && {\rm src}~s \ar[ll]^{s}
}
\endxy
\end{array}
$$
\<close>
proof -
have "\<sigma>.composite_cell (p\<^sub>0 \<star> w') (\<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<beta>\<^sub>s =
(\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
using \<beta>\<^sub>s_def \<theta>\<^sub>r'_def whisker_left comp_assoc by simp
also have "... = \<theta>\<^sub>r \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
using \<gamma>\<^sub>r by simp
also have "... = ((s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])) \<cdot> \<a>[s, s\<^sub>0, ?w\<^sub>s] \<cdot> (\<sigma> \<star> ?w\<^sub>s) \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
using \<theta>\<^sub>r_def comp_assoc by simp
also have "... = (s \<star> \<theta>) \<cdot> \<sigma>.composite_cell (p\<^sub>0 \<star> w) \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
proof -
have "(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] =
\<sigma> \<star> p\<^sub>0 \<star> w"
proof -
have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] = cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) hseqI' comp_assoc_assoc' by simp
text \<open>Here the fact that \<open>\<phi>\<close> is a retraction is used.\<close>
moreover have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = cod \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_arr_inv' whisker_right [of w r\<^sub>0s\<^sub>1.\<phi> "inv r\<^sub>0s\<^sub>1.\<phi>"]
by simp
moreover have "\<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] = dom (\<sigma> \<star> p\<^sub>0 \<star> w)"
using r\<^sub>0s\<^sub>1.base_simps(2) hseq_char comp_assoc_assoc' by auto
moreover have "hseq (inv r\<^sub>0s\<^sub>1.\<phi>) w"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2)
by (intro hseqI, auto)
moreover have "hseq \<sigma> (p\<^sub>0 \<star> w)"
by (intro hseqI, auto)
ultimately show ?thesis
using comp_arr_dom comp_cod_arr by simp
qed
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<sigma>.composite_cell (p\<^sub>0 \<star> w) (\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
using \<theta>\<^sub>s_def whisker_left
by (metis \<sigma>.ide_base \<theta>\<^sub>s arrI comp_assoc)
finally show ?thesis by simp
qed
hence 2: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>"
using \<sigma>.T2 [of ?w\<^sub>s ?w\<^sub>s' \<theta>\<^sub>s u \<theta>\<^sub>s' \<beta>\<^sub>s] w\<^sub>s w\<^sub>s' \<theta>\<^sub>s \<theta>\<^sub>s' \<beta>\<^sub>s
by (metis \<theta>\<^sub>s'_def \<theta>\<^sub>s_def)
obtain \<gamma>\<^sub>s where \<gamma>\<^sub>s: "\<guillemotleft>\<gamma>\<^sub>s : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>\<^sub>s) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>\<^sub>s"
using 2 by blast
have eq\<^sub>t: "(s\<^sub>1 \<star> \<gamma>\<^sub>s) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
text \<open>
$$
\xy/78pt/
\xymatrix{
& X \ar[d]^{w'} \ar@/ul15pt/[ddl]_{w_r} \xtwocell[ddl]{}\omit{^{\gamma_r}} \\
& {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
{\rm src}~\rho \ar[dr]^{r_0}
&& {\rm src}~\sigma \ar[dl]_{s_1} \\
& {\rm src}~r = {\rm trg}~s &
}
\endxy
\qquad = \qquad
\xy/78pt/
\xymatrix{
& X \ar[d]^{w} \ar@/ur15pt/[ddr]^{w_s'} \xtwocell[ddr]{}\omit{^{\gamma_s}} \\
& {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
{\rm src}~\rho \ar[dr]^{r_0}
&& {\rm src}~\sigma \ar[dl]_{s_1} \\
& {\rm src}~r = {\rm trg}~s &
}
\endxy
$$
\<close>
proof -
have "(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) =
\<beta>\<^sub>s \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "\<beta>\<^sub>s \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
(\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using \<beta>\<^sub>s_def comp_assoc by metis
also have "... = (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
proof -
have "(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
r\<^sub>0 \<star> \<gamma>\<^sub>r"
proof -
have "(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_assoc_assoc' comp_cod_arr
by (simp add: hseqI')
(* Used here that \<phi> is a section. *)
also have "... = (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_inv_arr' \<rho>.T0.antipar(1)
whisker_right [of w "inv r\<^sub>0s\<^sub>1.\<phi>" r\<^sub>0s\<^sub>1.\<phi>] comp_cod_arr
by simp
also have "... = r\<^sub>0 \<star> \<gamma>\<^sub>r"
proof -
have "hseq r\<^sub>0 \<gamma>\<^sub>r"
using \<beta>\<^sub>s \<beta>\<^sub>s_def by blast
thus ?thesis
using comp_assoc_assoc' comp_arr_dom
by (metis (no_types) \<gamma>\<^sub>r \<rho>.ide_leg0 comp_assoc_assoc'(1) hcomp_simps(3)
hseq_char ide_char in_homE r\<^sub>0s\<^sub>1.ide_leg1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps w w\<^sub>r)
qed
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (s\<^sub>1 \<star> ?w\<^sub>s') \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
proof -
have "(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] = \<a>[s\<^sub>1, p\<^sub>0, w']"
using comp_cod_arr by simp
thus ?thesis
using comp_assoc by metis
qed
finally show ?thesis by simp
qed
also have "... = (s\<^sub>1 \<star> \<gamma>\<^sub>s) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using \<gamma>\<^sub>s by simp
finally show ?thesis by simp
qed
have 3: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
using w w' w\<^sub>s' w\<^sub>r \<gamma>\<^sub>r \<gamma>\<^sub>s eq\<^sub>t
r\<^sub>0s\<^sub>1.\<phi>_biuniversal_prop(2) [of ?w\<^sub>s' ?w\<^sub>r w w' \<gamma>\<^sub>s "p\<^sub>0 \<star> w'" \<gamma>\<^sub>r]
by blast
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
using 3 by blast
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
proof -
have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
proof -
have "\<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
proof -
have "\<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>) = (\<theta>\<^sub>s' \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w']) \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
using \<theta>\<^sub>s'_def comp_arr_dom comp_assoc comp_assoc_assoc'(2) by auto
also have "... = (\<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>)) \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
using assoc_naturality [of s\<^sub>0 p\<^sub>0 \<gamma>] comp_assoc
by (metis \<gamma> \<gamma>\<^sub>r \<sigma>.leg0_simps(4-5) r\<^sub>0s\<^sub>1.leg0_simps(4-5)
r\<^sub>0s\<^sub>1.leg1_simps(3) hseqE in_homE leg0_simps(2))
also have "... = \<theta>\<^sub>s \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
by (metis \<gamma> \<gamma>\<^sub>s arrI comp_ide_arr w\<^sub>s')
also have "... = \<theta>"
using \<theta>\<^sub>s_def comp_assoc comp_arr_dom comp_assoc_assoc' by simp
finally show ?thesis by simp
qed
moreover have "\<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>"
proof -
have "\<beta> = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta>\<^sub>r \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
proof -
have "\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta>\<^sub>r \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w] =
(\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
using \<beta>\<^sub>r_def comp_assoc by simp
also have "... = \<beta>"
using comp_arr_dom comp_cod_arr
by (metis \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 comp_assoc_assoc'(2) hseqE ideD(1)
uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(4-5) leg1_simps(2) w w' w\<^sub>r w\<^sub>r')
finally show ?thesis by simp
qed
also have "... = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> (r\<^sub>1 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
using \<gamma>\<^sub>r by simp
also have "... = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>)"
using assoc_naturality [of r\<^sub>1 p\<^sub>1 \<gamma>]
by (metis \<gamma> \<gamma>\<^sub>r \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.leg1_simps(5-6) hseqE
ide_char in_homE leg1_simps(2))
also have "... = (\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>"
using comp_cod_arr
by (metis \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 calculation comp_assoc_assoc'(2) comp_ide_arr
hseqE ideD(1) ide_cod local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(5)
w' w\<^sub>r')
finally show ?thesis by simp
qed
ultimately show "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
using \<gamma> by blast
qed
moreover have "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>')
\<Longrightarrow> \<gamma>' = \<gamma>"
proof -
fix \<gamma>'
assume \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>')"
show "\<gamma>' = \<gamma>"
proof -
let ?P\<^sub>r = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>"
let ?P\<^sub>s = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>"
let ?\<gamma>\<^sub>r' = "p\<^sub>1 \<star> \<gamma>'"
let ?\<gamma>\<^sub>s' = "p\<^sub>0 \<star> \<gamma>'"
let ?P\<^sub>t = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
have "hseq p\<^sub>0 \<gamma>'"
proof (intro hseqI)
show "\<guillemotleft>\<gamma>' : src \<theta> \<rightarrow> src p\<^sub>0\<guillemotright>"
using \<gamma>'
by (metis hseqE hseqI' in_hhom_def uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) src_hcomp'
src_vcomp leg0_simps(2) leg1_simps(3)
uw\<theta>w'\<theta>'\<beta>.uw\<theta>.\<theta>_simps(1) vseq_implies_hpar(1))
show "\<guillemotleft>p\<^sub>0 : src p\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>" by simp
qed
hence "hseq p\<^sub>1 \<gamma>'"
using hseq_char by simp
have "\<guillemotleft>?\<gamma>\<^sub>r' : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright>"
using \<gamma>' by auto
moreover have "\<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"
proof -
text \<open>
Note that @{term \<theta>\<^sub>r} is the composite of ``everything to the right''
of @{term "\<rho> \<star> ?w\<^sub>r"}, and similarly for @{term \<theta>\<^sub>r'}.
We can factor @{term \<theta>\<^sub>r} as @{term "(s \<star> \<theta>) \<cdot> X w"}, where @{term "X w"}
is a composite of @{term \<sigma>} and @{term \<phi>}. We can similarly factor @{term \<theta>\<^sub>r'}
as @{term "(s \<star> \<theta>') \<cdot> X w'"}.
Then @{term "\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r') = (s \<star> \<theta>') \<cdot> X w' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"},
which equals @{term "(s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> ?\<gamma>\<^sub>r') \<cdot> X w = \<theta>\<^sub>r"}.
\<close>
let ?X = "\<lambda>w. (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
have "\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r') = (s \<star> \<theta>') \<cdot> ?X w' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"
using \<theta>\<^sub>r'_def comp_assoc by simp
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> ?X w"
proof -
have "(s \<star> \<theta>') \<cdot> ((s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>') =
(s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot>
\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>')"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>')) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using assoc'_naturality [of r\<^sub>0 p\<^sub>1 \<gamma>'] comp_assoc
by (metis \<gamma>' \<open>\<guillemotleft>p\<^sub>1 \<star> \<gamma>' : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>\<close> \<rho>.T0.antipar(1)
\<rho>.leg0_in_hom(2) r\<^sub>0s\<^sub>1.leg1_simps(4-6)
r\<^sub>0s\<^sub>1.base_simps(2) hcomp_in_vhomE in_homE trg_hcomp')
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>')) \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = r\<^sub>0s\<^sub>1.\<phi> \<star> \<gamma>'"
using \<gamma>' interchange [of r\<^sub>0s\<^sub>1.\<phi> "r\<^sub>0 \<star> p\<^sub>1" w' \<gamma>'] comp_arr_dom comp_cod_arr
by auto
also have "... = ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
using \<gamma>' interchange \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr
by (metis comp_arr_ide r\<^sub>0s\<^sub>1.\<phi>_simps(1,5) seqI'
uw\<theta>w'\<theta>'\<beta>.uw\<theta>.w_in_hom(2) w)
finally have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') =
((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
((\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using \<gamma>' assoc_naturality [of s\<^sub>1 p\<^sub>0 \<gamma>'] comp_assoc
by (metis \<sigma>.leg1_simps(2) \<sigma>.leg1_simps(3,5-6) r\<^sub>0s\<^sub>1.leg0_simps(4-5)
hcomp_in_vhomE hseqE in_homE uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1)
leg0_in_hom(2) leg1_simps(3))
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>') = \<sigma> \<star> p\<^sub>0 \<star> \<gamma>'"
using \<gamma>' interchange [of \<sigma> s\<^sub>1 "p\<^sub>0 \<star> w'" "p\<^sub>0 \<star> \<gamma>'"]
whisker_left \<open>hseq p\<^sub>0 \<gamma>'\<close>comp_arr_dom comp_cod_arr
by auto
also have "... = ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>') \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
using \<gamma>' interchange [of "s \<star> s\<^sub>0" \<sigma> "p\<^sub>0 \<star> \<gamma>'" "p\<^sub>0 \<star> w"]
whisker_left comp_arr_dom comp_cod_arr \<open>hseq p\<^sub>0 \<gamma>'\<close>
by auto
finally have "(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>') =
((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>') \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> ((s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') \<cdot>
\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using \<gamma>' assoc_naturality [of s s\<^sub>0 "p\<^sub>0 \<star> \<gamma>'"] \<open>hseq p\<^sub>0 \<gamma>'\<close> by auto
also have "... = (s \<star> \<theta>') \<cdot> ((s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot>
\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (s \<star> \<theta>') \<cdot> ((s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])) \<cdot>
\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
proof -
have "(s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') =
(s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
proof -
have "(s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') =
s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] \<cdot> (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')"
proof -
have "seq \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')"
proof
(* It seems to be too time-consuming for auto to solve these. *)
show "\<guillemotleft>s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>' : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0 \<star> p\<^sub>0 \<star> w'\<guillemotright>"
using \<gamma>'
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] : s\<^sub>0 \<star> p\<^sub>0 \<star> w' \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w'\<guillemotright>"
by auto
qed
thus ?thesis
using w w' \<gamma>' whisker_left by simp
qed
also have "... = s \<star> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> assoc'_naturality [of s\<^sub>0 p\<^sub>0 \<gamma>'] by fastforce
also have "... = (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
proof -
have "seq ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
proof
(* Same here. *)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w] : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w\<guillemotright>"
by auto
show "\<guillemotleft>(s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w'\<guillemotright>"
using \<gamma>' by (intro hcomp_in_vhom, auto)
qed
thus ?thesis
using w w' \<gamma>' whisker_left by simp
qed
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = (s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> ?X w"
- using comp_assoc by simp
+ using comp_assoc by presburger
finally show ?thesis by simp
qed
also have "... = \<theta>\<^sub>r"
using \<theta>\<^sub>r_def \<gamma>' uw\<theta>w'\<theta>'\<beta>.uw\<theta>.\<theta>_simps(1) whisker_left \<sigma>.ide_base comp_assoc
by simp
finally show ?thesis by simp
qed
moreover have "\<beta>\<^sub>r = r\<^sub>1 \<star> ?\<gamma>\<^sub>r'"
proof -
have "\<beta>\<^sub>r = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
using \<beta>\<^sub>r_def \<gamma>' by simp
also have "... = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> (r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>')"
using \<gamma>' assoc'_naturality
by (metis \<rho>.leg1_simps(5-6) r\<^sub>0s\<^sub>1.leg1_simps(5-6)
hcomp_in_vhomE hseqE in_homE uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) leg1_in_hom(2))
also have "... = (\<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w']) \<cdot> (r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>')"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>'"
using comp_cod_arr
by (metis (no_types, lifting) \<beta>\<^sub>r \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 arrI calculation
comp_assoc_assoc'(1) comp_ide_arr ide_hcomp hseq_char'
ideD(1) seq_if_composable hcomp_simps(2) leg1_simps(2) w' w\<^sub>r')
finally show ?thesis by simp
qed
ultimately have P\<^sub>r': "?P\<^sub>r ?\<gamma>\<^sub>r'"
by simp
have eq\<^sub>r: "\<gamma>\<^sub>r = ?\<gamma>\<^sub>r'"
using 1 \<gamma>\<^sub>r P\<^sub>r' by blast
have "\<guillemotleft>?\<gamma>\<^sub>s' : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright>"
using \<gamma>' by auto
moreover have "\<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> ?\<gamma>\<^sub>s')"
using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> \<sigma>.leg0_simps(2,4-5) \<sigma>.leg1_simps(3) \<theta>\<^sub>s'_def \<theta>\<^sub>s_def
assoc'_naturality hseqE in_homE comp_assoc r\<^sub>0s\<^sub>1.leg0_simps(4-5)
r\<^sub>0s\<^sub>1.p\<^sub>0_simps
by metis
moreover have "\<beta>\<^sub>s = s\<^sub>1 \<star> ?\<gamma>\<^sub>s'"
proof -
have "\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] =
\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>')) \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
using eq\<^sub>r comp_assoc by simp
also have "... = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>')) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
proof -
have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>') = ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
using \<gamma>' assoc'_naturality \<open>hseq p\<^sub>1 \<gamma>'\<close>
by (metis \<rho>.leg0_simps(2,4-5) \<rho>.leg1_simps(3)
r\<^sub>0s\<^sub>1.leg1_simps(5-6) hseqE in_homE leg1_simps(2))
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>')) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
proof -
have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = r\<^sub>0s\<^sub>1.\<phi> \<star> \<gamma>'"
using \<gamma>' interchange [of r\<^sub>0s\<^sub>1.\<phi> "r\<^sub>0 \<star> p\<^sub>1" w' \<gamma>']
comp_arr_dom comp_cod_arr
by auto
also have "... = ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
using \<gamma>' interchange \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr
by (metis in_homE r\<^sub>0s\<^sub>1.\<phi>_simps(1,5))
finally have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') =
((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (s\<^sub>1 \<star> ?\<gamma>\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
\<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
proof -
have "\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') = (s\<^sub>1 \<star> ?\<gamma>\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w]"
using \<gamma>' assoc_naturality [of s\<^sub>1 p\<^sub>0 \<gamma>'] \<open>hseq p\<^sub>0 \<gamma>'\<close> by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = s\<^sub>1 \<star> ?\<gamma>\<^sub>s'"
proof -
have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] = cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) hseqI' comp_assoc_assoc'
by simp
text \<open>Here the fact that \<open>\<phi>\<close> is a retraction is used.\<close>
moreover have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = cod \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_arr_inv'
whisker_right [of w r\<^sub>0s\<^sub>1.\<phi> "inv r\<^sub>0s\<^sub>1.\<phi>"]
by simp
moreover have "cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = inv r\<^sub>0s\<^sub>1.\<phi> \<star> w"
using \<beta>\<^sub>s_def \<beta>\<^sub>s
by (meson arrI comp_cod_arr seqE)
ultimately show ?thesis
using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr comp_assoc_assoc'
whisker_left [of s\<^sub>1 "p\<^sub>0 \<star> \<gamma>'" "p\<^sub>0 \<star> w"] whisker_left [of p\<^sub>0]
by auto
qed
finally show ?thesis
using \<beta>\<^sub>s_def by simp
qed
ultimately have P\<^sub>s': "?P\<^sub>s ?\<gamma>\<^sub>s'"
by simp
have eq\<^sub>s: "\<gamma>\<^sub>s = ?\<gamma>\<^sub>s'"
using 2 \<gamma>\<^sub>s P\<^sub>s' by blast
have "?P\<^sub>t \<gamma>'"
using \<gamma>' comp_cod_arr \<open>\<guillemotleft>p\<^sub>0 \<star> \<gamma>' : p\<^sub>0 \<star> w \<Rightarrow> p\<^sub>0 \<star> w'\<guillemotright>\<close> eq\<^sub>r eq\<^sub>s by auto
thus "\<gamma>' = \<gamma>"
using 3 \<gamma> by blast
qed
qed
ultimately show ?thesis by blast
qed
qed
qed
end
sublocale composite_tabulation_in_maps \<subseteq>
tabulation V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
using composite_is_tabulation by simp
sublocale composite_tabulation_in_maps \<subseteq>
tabulation_in_maps V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
using T0.is_map \<rho>.leg1_is_map \<rho>.T0.antipar(2) composable \<rho>.leg1_is_map \<rho>.T0.antipar
apply unfold_locales
apply simp
apply (intro left_adjoints_compose)
by auto
subsection "The Classifying Category of Maps"
text \<open>
\sloppypar
We intend to show that if \<open>B\<close> is a bicategory of spans, then \<open>B\<close> is biequivalent to
\<open>Span(Maps(B))\<close>, for a specific category \<open>Maps(B)\<close> derived from \<open>B\<close>.
The category \<open>Maps(B)\<close> is constructed in this section as the ``classifying category'' of
maps of \<open>B\<close>, which has the same objects as \<open>B\<close> and which has as 1-cells the isomorphism classes
of maps of \<open>B\<close>. We show that, if \<open>B\<close> is a bicategory of spans, then \<open>Maps(B)\<close> has pullbacks.
\<close>
locale maps_category =
B: bicategory_of_spans
begin
no_notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
notation B.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
notation B.isomorphic (infix "\<cong>\<^sub>B" 50)
notation B.iso_class ("\<lbrakk>_\<rbrakk>\<^sub>B")
text \<open>
I attempted to modularize the construction here, by refactoring ``classifying category''
out as a separate locale, but it ended up causing extra work because to apply it we
first need to obtain the full sub-bicategory of 2-cells between maps, then construct its
classifying category, and then we have to re-prove everything about it, to get rid of
any mention of the sub-bicategory construction. So the construction is being done
here as a ``one-off'' special case construction, with the necessary properties proved
just once.
\<close>
text \<open>
The ``hom-categories'' of \<open>Maps(C)\<close> have as arrows the isomorphism classes of maps of \<open>B\<close>.
\<close>
abbreviation Hom
where "Hom a b \<equiv> {F. \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B}"
lemma in_HomD:
assumes "F \<in> Hom a b"
shows "F \<noteq> {}"
and "B.is_iso_class F"
and "f \<in> F \<Longrightarrow> B.ide f"
and "f \<in> F \<Longrightarrow> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
and "f \<in> F \<Longrightarrow> B.is_left_adjoint f"
and "f \<in> F \<Longrightarrow> F = \<lbrakk>f\<rbrakk>\<^sub>B"
proof -
show "F \<noteq> {}"
using assms B.ide_in_iso_class B.left_adjoint_is_ide B.iso_class_is_nonempty by auto
show 1: "B.is_iso_class F"
using assms B.is_iso_classI B.left_adjoint_is_ide by fastforce
show "f \<in> F \<Longrightarrow> B.ide f"
using assms 1 B.iso_class_memb_is_ide by blast
obtain f' where f': "\<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f' \<and> F = \<lbrakk>f'\<rbrakk>\<^sub>B"
using assms by auto
show "f \<in> F \<Longrightarrow> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
using assms f' B.iso_class_def B.isomorphic_implies_hpar by auto
show "f \<in> F \<Longrightarrow> B.is_left_adjoint f"
using assms f' B.iso_class_def B.left_adjoint_preserved_by_iso [of f'] by auto
show "f \<in> F \<Longrightarrow> F = \<lbrakk>f\<rbrakk>\<^sub>B"
by (metis B.adjoint_pair_antipar(1) f' B.ide_in_iso_class B.is_iso_classI
B.iso_class_elems_isomorphic B.iso_class_eqI)
qed
definition Comp
where "Comp G F \<equiv> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h)}"
lemma in_CompI [intro]:
assumes "B.is_iso_class F" and "B.is_iso_class G"
and "f \<in> F" and "g \<in> G" and "g \<star> f \<cong>\<^sub>B h"
shows "h \<in> Comp G F"
unfolding Comp_def
using assms by auto
lemma in_CompE [elim]:
assumes "h \<in> Comp G F"
and "\<And>f g. \<lbrakk> B.is_iso_class F; B.is_iso_class G; f \<in> F; g \<in> G; g \<star> f \<cong>\<^sub>B h \<rbrakk> \<Longrightarrow> T"
shows T
using assms Comp_def by auto
lemma is_iso_class_Comp:
assumes "Comp G F \<noteq> {}"
shows "B.is_iso_class (Comp G F)"
proof -
obtain h where h: "h \<in> Comp G F"
using assms by auto
have ide_h: "B.ide h"
using h Comp_def B.isomorphic_implies_hpar(2) by auto
obtain f g where fg: "B.is_iso_class F \<and> B.is_iso_class G \<and> f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
using h Comp_def by auto
have "Comp G F = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<and> B.ide (g \<star> f)"
proof (intro conjI)
show "B.ide (g \<star> f)"
using fg B.iso_class_memb_is_ide B.isomorphic_implies_ide(1) by auto
show "Comp G F = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
proof
show "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<subseteq> Comp G F"
unfolding Comp_def B.iso_class_def
using fg by auto
show "Comp G F \<subseteq> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
proof
fix h'
assume h': "h' \<in> Comp G F"
obtain f' g' where f'g': "f' \<in> F \<and> g' \<in> G \<and> g' \<star> f' \<cong>\<^sub>B h'"
using h' Comp_def by auto
have 1: "f' \<cong>\<^sub>B f \<and> g' \<cong>\<^sub>B g"
using f'g' fg B.iso_class_elems_isomorphic by auto
moreover have "B.ide f \<and> B.ide f' \<and> B.ide g \<and> B.ide g'"
using 1 B.isomorphic_implies_hpar by auto
ultimately have "g' \<star> f' \<cong>\<^sub>B g \<star> f"
using f'g' fg B.hcomp_isomorphic_ide B.hcomp_ide_isomorphic
B.isomorphic_transitive B.isomorphic_implies_hpar
by (meson B.hseqE B.ideD(1))
hence "h' \<cong>\<^sub>B g \<star> f"
using f'g' B.isomorphic_symmetric B.isomorphic_transitive by blast
thus "h' \<in> B.iso_class (g \<star> f)"
using B.iso_class_def B.isomorphic_symmetric by simp
qed
qed
qed
thus ?thesis
using assms B.is_iso_class_def B.ide_in_iso_class by auto
qed
lemma Comp_is_extensional:
assumes "Comp G F \<noteq> {}"
shows "B.is_iso_class F" and "B.is_iso_class G"
and "F \<noteq> {}" and "G \<noteq> {}"
using assms Comp_def by auto
lemma Comp_eqI [intro]:
assumes "h \<in> Comp G F" and "h' \<in> Comp G' F'" and "h \<cong>\<^sub>B h'"
shows "Comp G F = Comp G' F'"
proof -
obtain f g where fg: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
using assms comp_def by auto
obtain f' g' where f'g': "f' \<in> F' \<and> g' \<in> G' \<and> g' \<star> f' \<cong>\<^sub>B h'"
using assms by auto
have "h \<in> Comp G F \<inter> Comp G' F'"
by (meson IntI assms in_CompE in_CompI B.isomorphic_symmetric B.isomorphic_transitive)
hence "Comp G F \<inter> Comp G' F' \<noteq> {}"
by auto
thus ?thesis
using assms is_iso_class_Comp
by (metis empty_iff B.iso_class_eq)
qed
lemma Comp_eq_iso_class_memb:
assumes "h \<in> Comp G F"
shows "Comp G F = \<lbrakk>h\<rbrakk>\<^sub>B"
proof
show "Comp G F \<subseteq> \<lbrakk>h\<rbrakk>\<^sub>B"
proof
fix h'
assume h': "h' \<in> Comp G F"
obtain f g where fg: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
using assms by auto
obtain f' g' where f'g': "f' \<in> F \<and> g' \<in> G \<and> g' \<star> f' \<cong>\<^sub>B h'"
using h' by auto
have "f \<cong>\<^sub>B f' \<and> g \<cong>\<^sub>B g'"
using assms fg f'g' in_HomD(6) B.iso_class_elems_isomorphic by auto
moreover have "B.ide f \<and> B.ide f' \<and> B.ide g \<and> B.ide g'"
using assms fg f'g' in_HomD [of F] in_HomD [of G]
by (meson calculation B.isomorphic_implies_ide(1) B.isomorphic_implies_ide(2))
moreover have "src g = trg f \<and> src g = trg f' \<and> src g' = trg f \<and> src g' = trg f'"
using fg f'g'
by (metis B.seq_if_composable calculation(1) B.ideD(1)
B.isomorphic_implies_hpar(1) B.isomorphic_implies_hpar(3) B.not_arr_null)
ultimately have "g \<star> f \<cong>\<^sub>B g' \<star> f'"
using fg f'g' B.hcomp_ide_isomorphic B.hcomp_isomorphic_ide B.isomorphic_transitive
by metis
thus "h' \<in> \<lbrakk>h\<rbrakk>\<^sub>B"
using fg f'g' B.isomorphic_symmetric B.isomorphic_transitive B.iso_class_def [of h]
by blast
qed
show "\<lbrakk>h\<rbrakk>\<^sub>B \<subseteq> Comp G F"
proof (unfold B.iso_class_def Comp_def)
obtain f g where 1: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
using assms in_HomD Comp_def
by (meson in_CompE)
show "{h'. B.isomorphic h h'} \<subseteq>
{h. B.is_iso_class F \<and> B.is_iso_class G \<and> (\<exists>f g. f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h)}"
using assms 1 B.isomorphic_transitive by blast
qed
qed
interpretation concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
proof
show "\<And>a. a \<in> Collect B.obj \<Longrightarrow> \<lbrakk>a\<rbrakk>\<^sub>B \<in> Hom a a"
by (metis (mono_tags, lifting) B.ide_in_hom(1) mem_Collect_eq B.objE
B.obj_is_self_adjoint(1))
show "\<And>a b c F G. \<lbrakk> a \<in> Collect B.obj; b \<in> Collect B.obj; c \<in> Collect B.obj;
F \<in> Hom a b; G \<in> Hom b c \<rbrakk> \<Longrightarrow> Comp G F \<in> Hom a c"
proof -
fix a b c F G
assume a: "a \<in> Collect B.obj" and b: "b \<in> Collect B.obj" and c: "c \<in> Collect B.obj"
and F: "F \<in> Hom a b" and G: "G \<in> Hom b c"
obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
using F by blast
obtain g where g: "\<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> B.is_left_adjoint g \<and> G = \<lbrakk>g\<rbrakk>\<^sub>B"
using G by blast
have "{h. B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)} =
\<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
proof
show "{h. B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}
\<subseteq> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
proof
fix h
assume "h \<in> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}"
hence h: "B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)"
by simp
show "h \<in> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
proof -
obtain f' g' where f'g': "g' \<in> G \<and> f' \<in> F \<and> g' \<star> f' \<cong>\<^sub>B h"
using h by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> B.iso \<phi>"
using f f'g' F B.iso_class_def by auto
obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : g \<Rightarrow>\<^sub>B g'\<guillemotright> \<and> B.iso \<psi>"
using g f'g' G B.iso_class_def by auto
have 1: "\<guillemotleft>\<psi> \<star> \<phi> : g \<star> f \<Rightarrow>\<^sub>B g' \<star> f'\<guillemotright>"
using f g \<phi> \<psi> by auto
moreover have "B.iso (\<psi> \<star> \<phi>)"
using f g \<phi> \<psi> 1 B.iso_hcomp by auto
ultimately show ?thesis
using f'g' B.iso_class_def B.isomorphic_def by auto
qed
qed
show "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<subseteq> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}"
using f g B.iso_class_def B.isomorphic_reflexive B.left_adjoint_is_ide B.is_iso_classI
by blast
qed
hence 1: "\<And>gf. gf \<in> B.iso_class (g \<star> f) \<Longrightarrow>
B.is_iso_class F \<and> B.is_iso_class G \<and>
(\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B gf)"
by blast
show "Comp G F \<in> Hom a c"
proof -
have gf: "B.is_left_adjoint (g \<star> f)"
by (meson f g B.hseqE B.hseqI B.left_adjoints_compose)
obtain gf' where gf': "B.adjoint_pair (g \<star> f) gf'"
using gf by blast
hence "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B = Comp G F"
using 1 Comp_eq_iso_class_memb B.ide_in_iso_class B.left_adjoint_is_ide by blast
thus ?thesis
using f g gf' by blast
qed
qed
show "\<And>a b F. \<lbrakk> a \<in> Collect B.obj; F \<in> Hom a b \<rbrakk> \<Longrightarrow> Comp F \<lbrakk>a\<rbrakk>\<^sub>B = F"
proof -
fix a b F
assume a: "a \<in> Collect B.obj"
assume F: "F \<in> Hom a b"
obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
using F by auto
have *: "\<And>f'. f' \<in> F \<Longrightarrow> \<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f' \<and> f \<cong>\<^sub>B f'"
using f B.iso_class_def by force
show "Comp F \<lbrakk>a\<rbrakk>\<^sub>B = F"
proof
show "Comp F \<lbrakk>a\<rbrakk>\<^sub>B \<subseteq> F"
proof
fix h
assume "h \<in> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
hence h: "\<exists>f' a'. f' \<in> F \<and> a' \<in> \<lbrakk>a\<rbrakk>\<^sub>B \<and> f' \<star> a' \<cong>\<^sub>B h"
unfolding Comp_def by auto
obtain f' a' where f'a': "f' \<in> F \<and> a' \<in> \<lbrakk>a\<rbrakk>\<^sub>B \<and> f' \<star> a' \<cong>\<^sub>B h"
using h by auto
have "B.isomorphic f h"
proof -
have "B.isomorphic f (f \<star> a)"
using f B.iso_runit' [of f] B.isomorphic_def B.left_adjoint_is_ide
by blast
also have "f \<star> a \<cong>\<^sub>B f' \<star> a"
using f f'a' B.iso_class_def B.hcomp_isomorphic_ide
apply (elim conjE B.in_hhomE) by auto
also have "f' \<star> a \<cong>\<^sub>B f' \<star> a'"
using f'a' * [of f'] B.iso_class_def B.hcomp_ide_isomorphic by auto
also have "f' \<star> a' \<cong>\<^sub>B h"
using f'a' by simp
finally show ?thesis by blast
qed
thus "h \<in> F"
using f B.iso_class_def by simp
qed
show "F \<subseteq> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
proof
fix h
assume h: "h \<in> F"
have "f \<in> F"
using f B.iso_class_def B.right_adjoint_determines_left_up_to_iso by auto
moreover have "a \<in> B.iso_class a"
using a B.iso_class_def B.isomorphic_reflexive by auto
moreover have "f \<star> a \<cong>\<^sub>B h"
proof -
have "f \<star> a \<cong>\<^sub>B f"
using f B.iso_runit [of f] B.isomorphic_def B.left_adjoint_is_ide by blast
also have "f \<cong>\<^sub>B h"
using h * by simp
finally show ?thesis by blast
qed
ultimately show "h \<in> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
unfolding Comp_def
using a f F B.is_iso_classI B.left_adjoint_is_ide by auto
qed
qed
qed
show "\<And>a b F. \<lbrakk> b \<in> Collect B.obj; F \<in> Hom a b \<rbrakk> \<Longrightarrow> Comp \<lbrakk>b\<rbrakk>\<^sub>B F = F"
proof -
fix a b F
assume b: "b \<in> Collect B.obj"
assume F: "F \<in> Hom a b"
obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
using F by auto
have *: "\<And>f'. f' \<in> F \<Longrightarrow> \<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f' \<and> f \<cong>\<^sub>B f'"
using f B.iso_class_def by force
show "Comp \<lbrakk>b\<rbrakk>\<^sub>B F = F"
proof
show "Comp \<lbrakk>b\<rbrakk>\<^sub>B F \<subseteq> F"
proof
fix h
assume "h \<in> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
hence h: "\<exists>b' f'. b' \<in> \<lbrakk>b\<rbrakk>\<^sub>B \<and> f' \<in> F \<and> b' \<star> f' \<cong>\<^sub>B h"
unfolding Comp_def by auto
obtain b' f' where b'f': "b' \<in> \<lbrakk>b\<rbrakk>\<^sub>B \<and> f' \<in> F \<and> b' \<star> f' \<cong>\<^sub>B h"
using h by auto
have "f \<cong>\<^sub>B h"
proof -
have "f \<cong>\<^sub>B b \<star> f"
using f B.iso_lunit' [of f] B.isomorphic_def B.left_adjoint_is_ide
by blast
also have "... \<cong>\<^sub>B b \<star> f'"
using f b'f' B.iso_class_def B.hcomp_ide_isomorphic
by (elim conjE B.in_hhomE, auto)
also have "... \<cong>\<^sub>B b' \<star> f'"
using b'f' * [of f'] B.iso_class_def B.hcomp_isomorphic_ide by auto
also have "... \<cong>\<^sub>B h"
using b'f' by simp
finally show ?thesis by blast
qed
thus "h \<in> F"
using f B.iso_class_def by simp
qed
show "F \<subseteq> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
proof
fix h
assume h: "h \<in> F"
have "f \<in> F"
using f B.iso_class_def B.right_adjoint_determines_left_up_to_iso by auto
moreover have "b \<in> B.iso_class b"
using b B.iso_class_def B.isomorphic_reflexive by auto
moreover have "b \<star> f \<cong>\<^sub>B h"
proof -
have "b \<star> f \<cong>\<^sub>B f"
using f B.iso_lunit [of f] B.isomorphic_def B.left_adjoint_is_ide
by blast
also have "f \<cong>\<^sub>B h"
using h * by simp
finally show ?thesis by blast
qed
ultimately show "h \<in> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
unfolding Comp_def
using b f F B.is_iso_classI B.left_adjoint_is_ide by auto
qed
qed
qed
show "\<And>a b c d F G H.
\<lbrakk> a \<in> Collect B.obj; b \<in> Collect B.obj; c \<in> Collect B.obj; d \<in> Collect B.obj;
F \<in> Hom a b; G \<in> Hom b c; H \<in> Hom c d \<rbrakk> \<Longrightarrow>
Comp H (Comp G F) = Comp (Comp H G) F"
proof -
fix a b c d F G H
assume F: "F \<in> Hom a b" and G: "G \<in> Hom b c" and H: "H \<in> Hom c d"
show "Comp H (Comp G F) = Comp (Comp H G) F"
proof
show "Comp H (Comp G F) \<subseteq> Comp (Comp H G) F"
proof
fix x
assume x: "x \<in> Comp H (Comp G F)"
obtain f g h gf
where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> gf \<in> Comp G F \<and> g \<star> f \<cong>\<^sub>B gf \<and> h \<star> gf \<cong>\<^sub>B x"
using x unfolding Comp_def by blast
have hgf: "B.ide f \<and> B.ide g \<and> B.ide h"
using 1 F G H B.isomorphic_implies_hpar in_HomD B.left_adjoint_is_ide
by (metis (mono_tags, lifting))
have "h \<star> g \<star> f \<cong>\<^sub>B x"
proof -
have "h \<star> g \<star> f \<cong>\<^sub>B h \<star> gf"
using 1 hgf B.hcomp_ide_isomorphic
by (metis (full_types) B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
B.isomorphic_symmetric B.seq_if_composable)
also have "h \<star> gf \<cong>\<^sub>B x"
using 1 by simp
finally show ?thesis by blast
qed
moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
using 1 hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def
by (metis B.hseq_char B.ideD(1-3) B.isomorphic_implies_hpar(1)
B.trg_hcomp' calculation)
moreover have hg: "\<guillemotleft>h \<star> g : b \<rightarrow>\<^sub>B d\<guillemotright>"
using G H 1 in_HomD(4) by blast
moreover have "h \<star> g \<in> Comp H G"
unfolding Comp_def
using 1 hgf F G H in_HomD [of F a b] in_HomD [of G b c] in_HomD [of H c d]
B.isomorphic_reflexive B.hcomp_ide_isomorphic B.hseqI'
by (metis (no_types, lifting) B.hseqE B.hseqI mem_Collect_eq)
ultimately show "x \<in> Comp (Comp H G) F"
using 1 F G H hgf B.is_iso_class_def is_iso_class_Comp [of H G]
B.isomorphic_reflexive [of "h \<star> g"]
apply (intro in_CompI)
apply auto[7]
apply blast
apply simp
by (meson B.isomorphic_symmetric B.isomorphic_transitive)
qed
show "Comp (Comp H G) F \<subseteq> Comp H (Comp G F)"
proof
fix x
assume x: "x \<in> Comp (Comp H G) F"
obtain f g h hg
where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> hg \<in> Comp H G \<and> h \<star> g \<cong>\<^sub>B hg \<and> hg \<star> f \<cong>\<^sub>B x"
using x unfolding Comp_def by blast
have hgf: "B.ide f \<and> B.ide g \<and> B.ide h \<and> src h = trg g \<and> src g = trg f"
using 1 F G H in_HomD B.left_adjoint_is_ide
by (metis (no_types, lifting) B.hseq_char' B.ideD(1) B.ide_dom
B.in_homE B.isomorphic_def B.isomorphic_symmetric B.seqI'
B.seq_if_composable B.src_dom B.src_hcomp' B.vseq_implies_hpar(1))
have 2: "(h \<star> g) \<star> f \<cong>\<^sub>B x"
proof -
have "(h \<star> g) \<star> f \<cong>\<^sub>B hg \<star> f"
using 1 F G H hgf
by (simp add: B.hcomp_isomorphic_ide)
also have "hg \<star> f \<cong>\<^sub>B x"
using 1 by simp
finally show ?thesis by blast
qed
moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
using hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def by auto
moreover have "g \<star> f \<in> Comp G F"
using 1 F G hgf B.isomorphic_reflexive by blast
ultimately show "x \<in> Comp H (Comp G F)"
using 1 hgf is_iso_class_Comp [of G F] B.isomorphic_reflexive [of "g \<star> f"]
apply (intro in_CompI)
apply auto[6]
apply simp
apply auto[1]
by (meson B.isomorphic_symmetric B.isomorphic_transitive)
qed
qed
qed
qed
lemma is_concrete_category:
shows "concrete_category (Collect B.obj) Hom B.iso_class (\<lambda>_ _ _. Comp)"
..
sublocale concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
using is_concrete_category by simp
- notation comp (infixr "\<odot>" 55)
+ abbreviation comp (infixr "\<odot>" 55)
+ where "comp \<equiv> COMP"
notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
lemma Map_memb_in_hhom:
assumes "\<guillemotleft>F : A \<rightarrow> B\<guillemotright>" and "f \<in> Map F"
shows "\<guillemotleft>f : Dom A \<rightarrow>\<^sub>B Dom B\<guillemotright>"
proof -
have "\<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright>"
using assms arr_char [of F] in_HomD [of "Map F" "Dom F" "Cod F"] by blast
moreover have "Dom F = Dom A"
using assms by auto
moreover have "Cod F = Dom B"
using assms by auto
ultimately show ?thesis by simp
qed
lemma MkArr_in_hom':
assumes "B.is_left_adjoint f" and "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
shows "\<guillemotleft>MkArr a b \<lbrakk>f\<rbrakk>\<^sub>B : MkIde a \<rightarrow> MkIde b\<guillemotright>"
using assms MkArr_in_hom by blast
text \<open>
The isomorphisms in \<open>Maps(B)\<close> are the isomorphism classes of equivalence maps in \<open>B\<close>.
\<close>
lemma iso_char:
shows "iso F \<longleftrightarrow> arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
proof
assume F: "iso F"
have "\<And>f. f \<in> Map F \<Longrightarrow> B.equivalence_map f"
proof -
fix f
assume f: "f \<in> Map F"
obtain G where G: "inverse_arrows F G"
using F by auto
obtain g where g: "g \<in> Map G"
using G arr_char [of G] in_HomD(1) by blast
have f: "f \<in> Map F \<and> \<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright> \<and> B.ide f \<and> B.is_left_adjoint f"
by (metis (mono_tags, lifting) F iso_is_arr is_concrete_category
concrete_category.arr_char f in_HomD(2,4-5) B.iso_class_memb_is_ide)
have g: "g \<in> Map G \<and> \<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright> \<and> B.ide g \<and> B.is_left_adjoint g"
by (metis (no_types, lifting) F G Cod_cod Cod_dom arr_inv cod_inv dom_inv
inverse_unique iso_is_arr is_concrete_category concrete_category.Map_in_Hom
g in_HomD(2,4-5) B.iso_class_memb_is_ide)
have "src (g \<star> f) \<cong>\<^sub>B g \<star> f"
proof -
have "g \<star> f \<in> Map (G \<odot> F)"
proof -
have 1: "f \<in> Map F \<and> g \<in> Map G \<and> g \<star> f \<cong>\<^sub>B g \<star> f"
using F G f g B.isomorphic_reflexive by force
have 2: "Dom G = Cod F \<and> Cod G = Dom F"
using F G arr_char
by (metis (no_types, lifting) Cod.simps(1) Cod_dom arr_inv
cod_char comp_inv_arr dom_inv inverse_unique
iso_is_arr is_concrete_category concrete_category.Cod_comp)
have "g \<star> f \<in> Comp (Map G) (Map F)"
using 1 F iso_is_arr Map_in_Hom [of F] in_HomD(2)
apply (intro in_CompI, auto)
proof -
show "B.is_iso_class (Map G)"
using G iso_is_arr iso_inv_iso Map_in_Hom [of G] in_HomD(2) [of "Map G"] by blast
qed
thus ?thesis
using F G f g comp_char [of G F] by auto
qed
moreover have "Dom F \<in> Map (G \<odot> F)"
by (metis (no_types, lifting) F G Map_dom comp_inv_arr iso_is_arr
g B.ide_in_iso_class B.in_hhomE B.objE)
moreover have "Map (G \<odot> F) = \<lbrakk>Dom F\<rbrakk>\<^sub>B"
by (simp add: F G comp_inv_arr iso_is_arr)
moreover have "Dom F = src (g \<star> f)"
using f g by fastforce
ultimately show ?thesis
using f g B.iso_class_elems_isomorphic B.is_iso_classI
by (metis B.hseqI B.ide_src)
qed
moreover have "f \<star> g \<cong>\<^sub>B trg f"
proof -
have "f \<star> g \<in> Map (F \<odot> G)"
proof -
have 1: "f \<in> Map F \<and> g \<in> Map G \<and> f \<star> g \<cong>\<^sub>B f \<star> g"
using F G f g B.isomorphic_reflexive by force
have 2: "Dom G = Cod F \<and> Cod G = Dom F"
using F G arr_char
by (metis (no_types, lifting) Cod.simps(1) Cod_dom arr_inv
cod_char comp_inv_arr dom_inv inverse_unique
iso_is_arr is_concrete_category concrete_category.Cod_comp)
hence "f \<star> g \<in> Comp (Map F) (Map G)"
using 1 F iso_is_arr Map_in_Hom [of F] in_HomD(2)
apply (intro in_CompI, auto)
proof -
show "B.is_iso_class (Map G)"
using G iso_is_arr iso_inv_iso Map_in_Hom [of G] in_HomD(2) [of "Map G"] by blast
qed
thus ?thesis
using F G f g comp_char [of F G] by auto
qed
moreover have "Cod F \<in> Map (F \<odot> G)"
by (metis (no_types, lifting) F G Map_cod comp_arr_inv dom_inv
inverse_unique iso_is_arr g B.ide_in_iso_class B.in_hhomE B.src.preserves_ide)
moreover have "Map (F \<odot> G) = \<lbrakk>Cod F\<rbrakk>\<^sub>B"
by (metis (no_types, lifting) F G Map_cod comp_arr_inv dom_inv
inverse_unique iso_is_arr)
moreover have "Cod F = trg (f \<star> g)"
using f g by fastforce
ultimately show ?thesis
using B.iso_class_elems_isomorphic
by (metis f g B.is_iso_classI B.in_hhomE B.src.preserves_ide)
qed
ultimately show "B.equivalence_map f"
using f g B.equivalence_mapI by fastforce
qed
thus "arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
using F by blast
next
assume F: "arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
show "iso F"
proof -
obtain f where f: "f \<in> Map F"
using F arr_char in_HomD(1) by blast
have f_in_hhom: "\<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright>"
using f F arr_char in_HomD(4) [of "Map F" "Dom F" "Cod F" f] by simp
have "Map F = B.iso_class f"
using f F arr_char in_HomD(6) [of "Map F" "Dom F" "Cod F" f] by simp
obtain g \<eta> \<epsilon>' where \<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
using f F B.equivalence_map_def by auto
interpret \<epsilon>': equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
using \<epsilon>' by auto
obtain \<epsilon> where \<epsilon>: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using f F \<epsilon>'.ide_right \<epsilon>'.antipar \<epsilon>'.unit_in_hom \<epsilon>'.unit_is_iso B.equivalence_map_def
B.equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
by auto
interpret \<epsilon>: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using \<epsilon> by simp
have g_in_hhom: "\<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright>"
using \<epsilon>.ide_right \<epsilon>.antipar f_in_hhom by auto
have fg: "B.equivalence_pair f g"
using B.equivalence_pair_def \<epsilon>.equivalence_in_bicategory_axioms by auto
have g: "\<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright> \<and> B.is_left_adjoint g \<and> \<lbrakk>g\<rbrakk>\<^sub>B = \<lbrakk>g\<rbrakk>\<^sub>B"
using \<epsilon>'.dual_equivalence B.equivalence_is_left_adjoint B.equivalence_map_def
g_in_hhom
by blast
have F_as_MkArr: "F = MkArr (Dom F) (Cod F) \<lbrakk>f\<rbrakk>\<^sub>B"
using F MkArr_Map \<open>Map F = B.iso_class f\<close> by fastforce
have F_in_hom: "in_hom F (MkIde (Dom F)) (MkIde (Cod F))"
using F arr_char dom_char cod_char
by (intro in_homI, auto)
let ?G = "MkArr (Cod F) (Dom F) \<lbrakk>g\<rbrakk>\<^sub>B"
have "arr ?G"
using MkArr_in_hom' g by blast
hence G_in_hom: "\<guillemotleft>?G : MkIde (Cod F) \<rightarrow> MkIde (Dom F)\<guillemotright>"
using arr_char MkArr_in_hom by simp
have "inverse_arrows F ?G"
proof
show "ide (?G \<odot> F)"
proof -
have "?G \<odot> F = dom F"
proof (intro arr_eqI)
show 1: "seq ?G F"
using F_in_hom G_in_hom by blast
show "arr (dom F)"
using F_in_hom ide_dom by fastforce
show "Dom (?G \<odot> F) = Dom (dom F)"
using F_in_hom G_in_hom 1 comp_char by auto
show "Cod (?G \<odot> F) = Cod (dom F)"
using F_in_hom G_in_hom 1 comp_char by auto
show "Map (?G \<odot> F) = Map (dom F)"
proof -
have "Map (?G \<odot> F) = Comp \<lbrakk>g\<rbrakk>\<^sub>B \<lbrakk>f\<rbrakk>\<^sub>B"
using 1 comp_char [of ?G F] `Map F = B.iso_class f` by simp
also have "... = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
proof -
have "g \<star> f \<in> Comp \<lbrakk>g\<rbrakk>\<^sub>B \<lbrakk>f\<rbrakk>\<^sub>B"
by (metis \<epsilon>.ide_left \<epsilon>.ide_right \<epsilon>.unit_in_vhom \<epsilon>.unit_simps(3) B.arrI
B.ide_cod B.ide_in_iso_class in_CompI B.is_iso_classI
B.isomorphic_reflexive)
thus ?thesis
using Comp_eq_iso_class_memb F_in_hom G_in_hom arr_char arr_char
`Map F = B.iso_class f`
by auto
qed
also have "... = \<lbrakk>src f\<rbrakk>\<^sub>B"
using \<epsilon>.unit_in_hom \<epsilon>.unit_is_iso B.isomorphic_def B.iso_class_def
B.isomorphic_symmetric
by (intro B.iso_class_eqI, blast)
also have "... = \<lbrakk>Dom F\<rbrakk>\<^sub>B"
using \<epsilon>.ide_left f_in_hhom B.ide_in_iso_class B.in_hhomE B.src.preserves_ide
B.isomorphic_reflexive
by (intro B.iso_class_eqI, fastforce)
also have "... = Map (dom F)"
using F_in_hom dom_char by auto
finally show ?thesis by blast
qed
qed
thus ?thesis
using F by simp
qed
show "ide (F \<odot> ?G)"
proof -
have "F \<odot> ?G = cod F"
proof (intro arr_eqI)
show 1: "seq F ?G"
using F_in_hom G_in_hom by blast
show "arr (cod F)"
using F_in_hom ide_cod by fastforce
show "Dom (F \<odot> ?G) = Dom (cod F)"
using F_in_hom G_in_hom 1 comp_char by auto
show "Cod (F \<odot> ?G) = Cod (cod F)"
using F_in_hom G_in_hom 1 comp_char by auto
show "Map (F \<odot> ?G) = Map (cod F)"
proof -
have "Map (F \<odot> ?G) = Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
using 1 comp_char [of F ?G] `Map F = \<lbrakk>f\<rbrakk>\<^sub>B` by simp
also have "... = \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
proof -
have "f \<star> g \<in> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
by (metis \<epsilon>.antipar(1) \<epsilon>.ide_left \<epsilon>.ide_right B.ide_hcomp
B.ide_in_iso_class in_CompI B.is_iso_classI B.isomorphic_reflexive)
thus ?thesis
using Comp_eq_iso_class_memb F_in_hom G_in_hom arr_char arr_char
`Map F = \<lbrakk>f\<rbrakk>\<^sub>B`
by auto
qed
also have "... = \<lbrakk>trg f\<rbrakk>\<^sub>B"
proof -
have "trg f \<in> \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
using \<epsilon>.counit_in_hom \<epsilon>.counit_is_iso B.isomorphic_def B.iso_class_def
B.isomorphic_symmetric
by blast
thus ?thesis
using B.iso_class_eqI
by (metis \<epsilon>.antipar(1) \<epsilon>.ide_left \<epsilon>.ide_right B.ide_hcomp
B.ide_in_iso_class B.is_iso_classI B.iso_class_elems_isomorphic)
qed
also have "... = \<lbrakk>Cod F\<rbrakk>\<^sub>B"
using f_in_hhom by auto
also have "... = Map (cod F)"
using F_in_hom dom_char by auto
finally show ?thesis by blast
qed
qed
thus ?thesis
using F by simp
qed
qed
thus ?thesis by auto
qed
qed
lemma iso_char':
shows "iso F \<longleftrightarrow> arr F \<and> (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
proof -
have "arr F \<Longrightarrow> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f) \<longleftrightarrow>
(\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
proof
assume F: "arr F"
show "(\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f) \<Longrightarrow>
(\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
using F arr_char in_HomD(1) by blast
show "(\<exists>f. f \<in> Map F \<and> B.equivalence_map f) \<Longrightarrow>
(\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
by (metis (no_types, lifting) F is_concrete_category concrete_category.arr_char
B.equivalence_map_preserved_by_iso in_HomD(2) B.iso_class_elems_isomorphic)
qed
thus ?thesis
using iso_char by blast
qed
text \<open>
The following mapping takes a map in \<open>B\<close> to the corresponding arrow of \<open>Maps(B)\<close>.
\<close>
abbreviation CLS ("\<lbrakk>\<lbrakk>_\<rbrakk>\<rbrakk>")
where "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<equiv> MkArr (src f) (trg f) \<lbrakk>f\<rbrakk>\<^sub>B"
lemma ide_CLS_obj:
assumes "B.obj a"
shows "ide \<lbrakk>\<lbrakk>a\<rbrakk>\<rbrakk>"
by (simp add: assms)
lemma CLS_in_hom:
assumes "B.is_left_adjoint f"
shows "\<guillemotleft>\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> : \<lbrakk>\<lbrakk>src f\<rbrakk>\<rbrakk> \<rightarrow> \<lbrakk>\<lbrakk>trg f\<rbrakk>\<rbrakk>\<guillemotright>"
using assms B.left_adjoint_is_ide MkArr_in_hom MkArr_in_hom' by simp
lemma CLS_eqI:
assumes "B.ide f"
shows "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> \<longleftrightarrow> f \<cong>\<^sub>B g"
by (metis arr.inject assms B.ide_in_iso_class B.iso_class_def B.iso_class_eqI
B.isomorphic_implies_hpar(3) B.isomorphic_implies_hpar(4) B.isomorphic_symmetric
mem_Collect_eq)
lemma CLS_hcomp:
assumes "B.ide f" and "B.ide g" and "src f = trg g"
shows "\<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) (Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B)"
proof -
have "\<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
using assms B.left_adjoint_is_ide by simp
moreover have "\<lbrakk>f \<star> g\<rbrakk>\<^sub>B = Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
proof
show "\<lbrakk>f \<star> g\<rbrakk>\<^sub>B \<subseteq> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
by (metis assms(1-2) B.ide_in_iso_class in_CompI B.is_iso_classI
B.iso_class_def mem_Collect_eq subsetI)
show "Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B \<subseteq> \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
by (metis Comp_eq_iso_class_memb \<open>\<lbrakk>f \<star> g\<rbrakk>\<^sub>B \<subseteq> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B\<close>
assms(1-3) B.ide_hcomp B.ide_in_iso_class subset_iff)
qed
ultimately show ?thesis by simp
qed
lemma comp_CLS:
assumes "B.is_left_adjoint f" and "B.is_left_adjoint g" and "f \<star> g \<cong>\<^sub>B h"
shows "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h\<rbrakk>\<rbrakk>"
proof -
have hseq_fg: "B.hseq f g"
using assms B.isomorphic_implies_hpar(1) by simp
have "seq \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk>"
using assms hseq_fg CLS_in_hom [of f] CLS_in_hom [of g]
apply (elim B.hseqE) by auto
hence "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) (Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B)"
using comp_char [of "CLS f" "CLS g"] by simp
also have "... = \<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk>"
using assms hseq_fg CLS_hcomp
apply (elim B.hseqE)
using B.adjoint_pair_antipar(1) by auto
also have "... = \<lbrakk>\<lbrakk>h\<rbrakk>\<rbrakk>"
using assms B.isomorphic_symmetric
by (simp add: assms(3) B.iso_class_eqI B.isomorphic_implies_hpar(3)
B.isomorphic_implies_hpar(4))
finally show ?thesis by simp
qed
text \<open>
The following mapping that takes an arrow of \<open>Maps(B)\<close> and chooses some
representative map in \<open>B\<close>.
\<close>
definition REP
where "REP F \<equiv> if arr F then SOME f. f \<in> Map F else B.null"
lemma REP_in_Map:
assumes "arr A"
shows "REP A \<in> Map A"
proof -
have "Map A \<noteq> {}"
using assms arr_char in_HomD(1) by blast
thus ?thesis
using assms REP_def someI_ex [of "\<lambda>f. f \<in> Map A"] by auto
qed
lemma REP_in_hhom [intro]:
assumes "in_hom F A B"
shows "\<guillemotleft>REP F : src (REP A) \<rightarrow>\<^sub>B src (REP B)\<guillemotright>"
and "B.is_left_adjoint (REP F)"
proof -
have "Map F \<noteq> {}"
using assms in_hom_char arr_char null_char in_HomD(1) [of "Map F" "Dom F" "Cod F"]
by blast
hence 1: "REP F \<in> Map F"
using assms REP_def someI_ex [of "\<lambda>f. f \<in> Map F"] by auto
hence 2: "B.arr (REP F)"
using assms 1 in_hom_char [of F A B] B.iso_class_def Map_memb_in_hhom B.in_hhom_def
by blast
hence "\<guillemotleft>REP F : Dom A \<rightarrow>\<^sub>B Dom B\<guillemotright>"
using assms 1 in_hom_char [of F A B] Map_memb_in_hhom by auto
thus "\<guillemotleft>REP F : src (REP A) \<rightarrow>\<^sub>B src (REP B)\<guillemotright>"
using assms
by (metis (no_types, lifting) Map_memb_in_hhom ideD(1)
in_homI in_hom_char REP_in_Map B.in_hhom_def)
have "REP F \<in> \<lbrakk>REP F\<rbrakk>\<^sub>B"
using assms 1 2 arr_char [of F] in_HomD(6) B.ide_in_iso_class B.iso_class_memb_is_ide
in_hom_char
by blast
thus "B.is_left_adjoint (REP F)"
using assms 1 2 arr_char in_HomD(5) [of "Map F" "Dom F" "Cod F" "REP F"]
by auto
qed
lemma ide_REP:
assumes "arr A"
shows "B.ide (REP A)"
using assms REP_in_hhom(2) B.adjoint_pair_antipar(1) by blast
lemma REP_simps [simp]:
assumes "arr A"
shows "B.ide (REP A)"
and "src (REP A) = Dom A" and "trg (REP A) = Cod A"
and "B.dom (REP A) = REP A" and "B.cod (REP A) = REP A"
proof -
show "B.ide (REP A)"
using assms ide_REP by blast
show "src (REP A) = Dom A"
using assms REP_in_hhom
by (metis (no_types, lifting) Map_memb_in_hhom Dom_dom in_homI
REP_in_Map B.in_hhom_def)
show "trg (REP A) = Cod A"
using assms REP_in_hhom
by (metis (no_types, lifting) Map_memb_in_hhom Dom_cod in_homI
REP_in_Map B.in_hhom_def)
show "B.dom (REP A) = REP A"
using assms in_homI REP_in_hhom(2) B.adjoint_pair_antipar(1) B.ideD(2)
by blast
show "B.cod (REP A) = REP A"
using assms in_homI REP_in_hhom(2) B.adjoint_pair_antipar(1) B.ideD(3)
by blast
qed
lemma isomorphic_REP_src:
assumes "ide A"
shows "REP A \<cong>\<^sub>B src (REP A)"
using assms
by (metis (no_types, lifting) ideD(1) ide_char REP_in_Map ide_REP
REP_simps(2) B.is_iso_classI B.ide_in_iso_class B.iso_class_elems_isomorphic
B.src.preserves_ide)
lemma isomorphic_REP_trg:
assumes "ide A"
shows "REP A \<cong>\<^sub>B trg (REP A)"
using assms ide_char isomorphic_REP_src by auto
lemma CLS_REP:
assumes "arr F"
shows "\<lbrakk>\<lbrakk>REP F\<rbrakk>\<rbrakk> = F"
by (metis (mono_tags, lifting) MkArr_Map
is_concrete_category REP_in_Map REP_simps(2) REP_simps(3) assms
concrete_category.Map_in_Hom in_HomD(6))
lemma REP_CLS:
assumes "B.is_left_adjoint f"
shows "REP \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<cong>\<^sub>B f"
by (metis (mono_tags, lifting) CLS_in_hom Map.simps(1) in_homE REP_in_Map
assms B.iso_class_def B.isomorphic_symmetric mem_Collect_eq)
lemma isomorphic_hcomp_REP:
assumes "seq F G"
shows "REP F \<star> REP G \<cong>\<^sub>B REP (F \<odot> G)"
proof -
have 1: "Dom F = Cod G"
using assms seq_char by simp
have 2: "Map F = B.iso_class (REP F)"
using assms seq_char arr_char REP_in_Map in_HomD(6) by meson
have 3: "Map G = B.iso_class (REP G)"
using assms seq_char arr_char REP_in_Map
in_HomD(6) [of "Map G" "Dom G" "Cod G" "REP G"]
by auto
have "Map (F \<odot> G) = Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
- using assms comp_def seq_char null_char Comp_def
+ using assms seq_char null_char
by (metis (no_types, lifting) CLS_REP Map.simps(1) Map_comp)
have "Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B = \<lbrakk>REP F \<star> REP G\<rbrakk>\<^sub>B"
proof -
have "REP F \<star> REP G \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
proof -
have "REP F \<in> Map F \<and> REP G \<in> Map G"
using assms seq_char REP_in_Map by auto
moreover have "REP F \<star> REP G \<cong>\<^sub>B REP F \<star> REP G"
using assms seq_char 2 B.isomorphic_reflexive by auto
ultimately show ?thesis
using assms 1 2 3 B.iso_class_def B.is_iso_class_def
by (intro in_CompI, auto)
qed
moreover have "\<lbrakk>REP F\<rbrakk>\<^sub>B \<in> Hom (Cod G) (Cod F)"
using assms 1 2 arr_char [of F] by auto
moreover have "\<lbrakk>REP G\<rbrakk>\<^sub>B \<in> Hom (Dom G) (Cod G)"
using assms 1 3 arr_char [of G] by auto
ultimately show ?thesis
using Comp_eq_iso_class_memb assms arr_char arr_char REP_in_Map
by (simp add: Comp_def)
qed
moreover have "REP (F \<odot> G) \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
proof -
have "Map (F \<odot> G) = Comp (Map F) (Map G)"
using assms 1 comp_char [of F G] by simp
thus ?thesis
using assms 1 2 3 REP_in_Map [of "F \<odot> G"] by simp
qed
ultimately show ?thesis
using B.iso_class_def by simp
qed
text \<open>
We now show that \<open>Maps(B)\<close> has pullbacks. For this we need to exhibit
functions \<open>PRJ\<^sub>0\<close> and \<open>PRJ\<^sub>1\<close> that produce the legs of the pullback of a cospan \<open>(H, K)\<close>
and verify that they have the required universal property. These are obtained by
choosing representatives \<open>h\<close> and \<open>k\<close> of \<open>H\<close> and \<open>K\<close>, respectively, and then taking
\<open>PRJ\<^sub>0 = CLS (tab\<^sub>0 (k\<^sup>* \<star> h))\<close> and \<open>PRJ\<^sub>1 = CLS (tab\<^sub>1 (k\<^sup>* \<star> h))\<close>. That these constitute a
pullback in \<open>Maps(B)\<close> follows from the fact that \<open>tab\<^sub>0 (k\<^sup>* \<star> h)\<close> and \<open>tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
form a pseudo-pullback of \<open>(h, k)\<close> in the underlying bicategory.
For our purposes here, it is not sufficient simply to show that \<open>Maps(B)\<close> has pullbacks
and then to treat it as an abstract ``category with pullbacks'' where the pullbacks
are chosen arbitrarily. Instead, we have to retain the connection between a pullback
in Maps and the tabulation of \<open>k\<^sup>* \<star> h\<close> that is ultimately used to obtain it. If we don't
do this, then it becomes problematic to define the compositor of a pseudofunctor from
the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>, because the components will go from the
apex of a composite span (obtained by pullback) to the apex of a tabulation (chosen
arbitrarily using \<open>BS2\<close>) and these need not be in agreement with each other.
\<close>
definition PRJ\<^sub>0
where "PRJ\<^sub>0 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>0 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
definition PRJ\<^sub>1
where "PRJ\<^sub>1 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>1 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
interpretation elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
proof
show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>0 K H = null"
unfolding PRJ\<^sub>0_def by auto
show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>1 K H = null"
unfolding PRJ\<^sub>1_def by auto
show "\<And>H K. cospan K H \<Longrightarrow> commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
proof -
fix H K
assume HK: "cospan K H"
define h where "h = REP H"
define k where "k = REP K"
have h: "h \<in> Map H"
using h_def HK REP_in_Map by blast
have k: "k \<in> Map K"
using k_def HK REP_in_Map by blast
have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
apply auto
by (metis (no_types, lifting) HK Dom_cod)
interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
using 1 by (unfold_locales, auto)
interpret k: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg k
using 1 by (unfold_locales, auto)
interpret hk: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h k
using 1 by (unfold_locales, auto)
let ?f = "B.tab\<^sub>0 (k\<^sup>* \<star> h)"
let ?g = "B.tab\<^sub>1 (k\<^sup>* \<star> h)"
have span: "span \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
using dom_char CLS_in_hom [of ?f] CLS_in_hom [of ?g] by auto
have seq: "seq H \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
using HK seq_char hk.leg0_is_map CLS_in_hom h_def hk.p\<^sub>0_simps hk.satisfies_T0
by fastforce
have seq': "seq K \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
using HK k arr_char dom_char cod_char in_HomD(5) hk.leg1_is_map CLS_in_hom
by (metis (no_types, lifting) Cod.simps(1) seq_char REP_simps(2)
hk.p\<^sub>1_simps k_def span)
show "commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
proof
show "cospan K H"
using HK by simp
show "dom K = cod (PRJ\<^sub>1 K H)"
using seq' PRJ\<^sub>1_def HK h_def k_def by auto
show "span (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
unfolding PRJ\<^sub>0_def PRJ\<^sub>1_def using HK span h_def k_def by simp
show "K \<odot> PRJ\<^sub>1 K H = H \<odot> PRJ\<^sub>0 K H"
proof -
have iso: "h \<star> ?f \<cong>\<^sub>B k \<star> ?g"
using hk.\<phi>_uniqueness B.isomorphic_symmetric B.isomorphic_def by blast
have *: "Comp (Map H) \<lbrakk>?f\<rbrakk>\<^sub>B = Comp (Map K) \<lbrakk>?g\<rbrakk>\<^sub>B"
proof (intro Comp_eqI)
show "h \<star> ?f \<in> Comp (Map H) \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
proof (unfold Comp_def)
have "B.is_iso_class \<lbrakk>?f\<rbrakk>\<^sub>B"
by (simp add: B.is_iso_classI)
moreover have "B.is_iso_class (Map H)"
using CLS_REP HK Map.simps(1) B.is_iso_classI h.ide_left h_def
by (metis (no_types, lifting))
moreover have "?f \<in> \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
by (simp add: B.ide_in_iso_class(1))
moreover have "\<guillemotleft>?f : src (B.tab\<^sub>0 (k\<^sup>* \<star> h)) \<rightarrow>\<^sub>B Dom H\<guillemotright>"
using seq seq_char by simp
moreover have "h \<in> Map H"
by fact
moreover have "\<guillemotleft>h : Dom H \<rightarrow>\<^sub>B Cod H\<guillemotright>"
by (simp add: HK h_def)
moreover have "h \<star> ?f \<cong>\<^sub>B h \<star> ?f"
using B.isomorphic_reflexive by auto
ultimately show "h \<star> B.tab\<^sub>0 (k\<^sup>* \<star> h)
\<in> {h'. B.is_iso_class \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
B.is_iso_class (Map H) \<and>
(\<exists>f g. f \<in> \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
g \<in> Map H \<and> g \<star> f \<cong>\<^sub>B h')}"
by auto
qed
show "k \<star> ?g \<in> Comp (Map K) \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
proof (unfold Comp_def)
have "B.is_iso_class \<lbrakk>?g\<rbrakk>\<^sub>B"
by (simp add: B.is_iso_classI)
moreover have "B.is_iso_class (Map K)"
by (metis (no_types, lifting) CLS_REP HK Map.simps(1)
B.is_iso_classI k.ide_left k_def)
moreover have "?g \<in> \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
by (simp add: B.ide_in_iso_class(1))
moreover have "\<guillemotleft>?g : src (B.tab\<^sub>1 (k\<^sup>* \<star> h)) \<rightarrow>\<^sub>B Dom K\<guillemotright>"
using seq seq_char B.in_hhom_def seq' by auto
moreover have "k \<in> Map K"
by fact
moreover have "\<guillemotleft>k : Dom K \<rightarrow>\<^sub>B Cod K\<guillemotright>"
by (simp add: HK k_def)
moreover have "k \<star> ?g \<cong>\<^sub>B k \<star> ?g"
using B.isomorphic_reflexive iso B.isomorphic_implies_hpar(2) by auto
ultimately show "k \<star> B.tab\<^sub>1 (k\<^sup>* \<star> h)
\<in> {h'. B.is_iso_class \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
B.is_iso_class (Map K) \<and>
(\<exists>f g. f \<in> \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
g \<in> Map K \<and> g \<star> f \<cong>\<^sub>B h')}"
by auto
qed
show "h \<star> ?f \<cong>\<^sub>B k \<star> ?g"
using iso by simp
qed
have "K \<odot> PRJ\<^sub>1 K H = K \<odot> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
unfolding PRJ\<^sub>1_def using HK h_def k_def by simp
also have "... = MkArr (src ?g) (Cod K) (Comp (Map K) \<lbrakk>?g\<rbrakk>\<^sub>B)"
using seq' comp_char [of K "\<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"] by simp
also have "... = MkArr (src ?f) (Cod H) (Comp (Map H) \<lbrakk>?f\<rbrakk>\<^sub>B)"
using * HK cod_char by auto
also have "... = comp H \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
using seq comp_char [of H "\<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"] by simp
also have "... = comp H (PRJ\<^sub>0 K H)"
unfolding PRJ\<^sub>0_def using HK h_def k_def by simp
finally show ?thesis by simp
qed
qed
qed
show "\<And>H K U V. commutative_square K H V U \<Longrightarrow>
\<exists>!E. comp (PRJ\<^sub>1 K H) E = V \<and> comp (PRJ\<^sub>0 K H) E = U"
proof -
fix H K U V
assume cs: "commutative_square K H V U"
have HK: "cospan K H"
using cs by auto
(* TODO: Is there any way to avoid this repetition? *)
define h where "h = REP H"
define k where "k = REP K"
have h: "h \<in> Map H"
using h_def HK REP_in_Map by blast
have k: "k \<in> Map K"
using k_def HK REP_in_Map by blast
have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
apply auto
by (metis (no_types, lifting) HK Dom_cod)
interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
using 1 by (unfold_locales, auto)
interpret k: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg k
using 1 by (unfold_locales, auto)
interpret hk: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h k
using 1 by (unfold_locales, auto)
let ?f = "B.tab\<^sub>0 (k\<^sup>* \<star> h)"
let ?g = "B.tab\<^sub>1 (k\<^sup>* \<star> h)"
have seq_HU: "seq H U"
using cs by auto
have seq_KV: "seq K V"
using cs by auto
let ?u = "REP U"
let ?v = "REP V"
have u: "B.ide ?u"
using ide_REP seq_HU by auto
have v: "B.ide ?v"
using ide_REP seq_KV by auto
have u_is_map: "B.is_left_adjoint ?u"
using u seq_HU REP_in_Map arr_char [of U]
in_HomD(5) [of "Map U" "Dom U" "Cod U" ?u]
by auto
have v_is_map: "B.is_left_adjoint ?v"
using v seq_KV REP_in_Map arr_char [of V]
in_HomD(5) [of "Map V" "Dom V" "Cod V" ?v]
by auto
have *: "h \<star> ?u \<cong>\<^sub>B k \<star> ?v"
proof -
have "h \<star> ?u \<cong>\<^sub>B REP (H \<odot> U)"
proof -
have "h \<star> ?u \<cong>\<^sub>B REP H \<star> ?u"
proof -
have "h \<cong>\<^sub>B REP H"
using h h_def HK arr_char REP_in_Map B.iso_class_elems_isomorphic
in_HomD(5) [of "Map H" "Dom H" "Cod H" h] B.isomorphic_reflexive
by auto
thus ?thesis
using h_def seq_HU B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
by (simp add: seq_char)
qed
also have "... \<cong>\<^sub>B REP (H \<odot> U)"
using seq_HU isomorphic_hcomp_REP isomorphic_def by blast
finally show ?thesis by blast
qed
also have "... \<cong>\<^sub>B REP (K \<odot> V)"
using seq_HU cs B.isomorphic_reflexive by auto
also have "... \<cong>\<^sub>B (k \<star> ?v)"
proof -
have "... \<cong>\<^sub>B REP K \<star> ?v"
using seq_KV isomorphic_hcomp_REP B.isomorphic_def B.isomorphic_symmetric
by blast
also have "... \<cong>\<^sub>B k \<star> ?v"
proof -
have "k \<cong>\<^sub>B REP K"
using k k_def HK arr_char REP_in_Map B.iso_class_elems_isomorphic
in_HomD(5) [of "Map K" "Dom K" "Cod K" k] B.isomorphic_reflexive
by auto
thus ?thesis
using k_def seq_KV B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
by (simp add: seq_char)
qed
finally show ?thesis by blast
qed
finally show ?thesis by blast
qed
have hseq_hu: "src h = trg ?u"
using * B.isomorphic_implies_hpar
by (meson B.hseqE B.ideD(1))
have hseq_kv: "src k = trg ?v"
using * B.isomorphic_implies_hpar
by (meson B.hseqE B.ideD(1))
obtain w where w: "B.is_left_adjoint w \<and> ?f \<star> w \<cong>\<^sub>B ?u \<and> ?v \<cong>\<^sub>B (?g \<star> w)"
using * u_is_map v_is_map hk.has_pseudo_pullback [of ?u ?v] B.isomorphic_symmetric
by blast
have w_in_hom: "\<guillemotleft>w : src ?u \<rightarrow>\<^sub>B src ?f\<guillemotright> \<and> B.ide w"
using w B.left_adjoint_is_ide B.src_cod B.trg_cod B.isomorphic_def
apply (intro conjI B.in_hhomI)
apply auto
apply (metis B.ideD(1) B.isomorphic_implies_hpar(3) B.isomorphic_implies_ide(1)
B.hcomp_simps(1))
by (metis B.hseqE B.ideD(1) B.isomorphic_implies_hpar(1))
let ?W = "CLS w"
have W: "\<guillemotleft>?W : dom U \<rightarrow> dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>\<guillemotright>"
proof
show "arr ?W"
using w CLS_in_hom by blast
thus "dom ?W = dom U"
using w_in_hom dom_char REP_in_hhom(1) CLS_in_hom
by (metis (no_types, lifting) Dom.simps(1) commutative_squareE
dom_char REP_simps(2) cs B.in_hhomE)
show "cod ?W = dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
proof -
have "src ?f = trg w"
by (metis (lifting) B.in_hhomE w_in_hom)
thus ?thesis
using CLS_in_hom [of ?f] CLS_in_hom [of w] hk.satisfies_T0 w by fastforce
qed
qed
show "\<exists>!E. PRJ\<^sub>1 K H \<odot> E = V \<and> PRJ\<^sub>0 K H \<odot> E = U"
proof -
have "PRJ\<^sub>1 K H \<odot> ?W = V \<and> PRJ\<^sub>0 K H \<odot> ?W = U"
proof -
have "\<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<odot> ?W = U"
using w w_in_hom u CLS_in_hom comp_CLS
B.isomorphic_symmetric CLS_REP hk.leg0_is_map
by (metis (mono_tags, lifting) commutative_square_def cs)
moreover have "\<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<odot> ?W = V"
using w w_in_hom v CLS_in_hom comp_CLS
B.isomorphic_symmetric CLS_REP hk.leg1_is_map
by (metis (mono_tags, lifting) commutative_square_def cs)
ultimately show ?thesis
using HK h_def k_def PRJ\<^sub>0_def PRJ\<^sub>1_def by auto
qed
moreover have
"\<And>W'. PRJ\<^sub>1 K H \<odot> W' = V \<and> PRJ\<^sub>0 K H \<odot> W' = U \<Longrightarrow> W' = ?W"
proof -
fix W'
assume "PRJ\<^sub>1 K H \<odot> W' = V \<and> PRJ\<^sub>0 K H \<odot> W' = U"
hence W': "\<guillemotleft>W' : dom U \<rightarrow> dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>\<guillemotright> \<and> \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<odot> W' = U \<and> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<odot> W' = V"
using PRJ\<^sub>0_def PRJ\<^sub>1_def HK h_def k_def apply simp
using cs arr_iff_in_hom by blast
let ?w' = "REP W'"
have w': "B.ide ?w'"
using W' ide_REP by auto
have fw'_iso_u: "?f \<star> ?w' \<cong>\<^sub>B ?u"
proof -
have "?f \<star> ?w' \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<star> ?w'"
by (metis (no_types, lifting) Cod.simps(1) in_hom_char
REP_CLS REP_simps(3) W W' B.hcomp_isomorphic_ide hk.satisfies_T0
B.in_hhomE B.isomorphic_symmetric w' w_in_hom)
also have "REP \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<star> ?w' \<cong>\<^sub>B ?u"
using W' isomorphic_hcomp_REP cs by blast
finally show ?thesis by blast
qed
have gw'_iso_v: "?g \<star> ?w' \<cong>\<^sub>B ?v"
proof -
have "?g \<star> ?w' \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<star> ?w'"
proof -
have "?g \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
using REP_CLS B.isomorphic_symmetric hk.leg1_is_map by blast
moreover have "B.ide (REP W')"
using W' by auto
moreover have "src ?f = trg ?w'"
using w_in_hom W W' in_hom_char arr_char B.in_hhom_def
by (meson fw'_iso_u B.hseqE B.ideD(1) B.isomorphic_implies_ide(1))
ultimately show ?thesis
using B.hcomp_isomorphic_ide by simp
qed
also have "... \<cong>\<^sub>B ?v"
using W' isomorphic_hcomp_REP cs by blast
finally show ?thesis by blast
qed
show "W' = ?W"
proof -
have "W' = \<lbrakk>\<lbrakk>?w'\<rbrakk>\<rbrakk>"
using w' W' CLS_REP by auto
also have "... = ?W"
proof -
have "?w' \<cong>\<^sub>B w"
using * w W' hk.has_pseudo_pullback(2) u_is_map v_is_map
B.isomorphic_symmetric fw'_iso_u gw'_iso_v
by blast
thus ?thesis
using CLS_eqI B.iso_class_eqI w' by blast
qed
finally show ?thesis by blast
qed
qed
ultimately show ?thesis by auto
qed
qed
qed
lemma is_elementary_category_with_pullbacks:
shows "elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1"
..
lemma is_category_with_pullbacks:
shows "category_with_pullbacks comp"
..
sublocale elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
using is_elementary_category_with_pullbacks by simp
end
text \<open>
Here we relate the projections of the chosen pullbacks in \<open>Maps(B)\<close> to the
projections associated with the chosen tabulations in \<open>B\<close>.
\<close>
context composite_tabulation_in_maps
begin
interpretation Maps: maps_category V H \<a> \<i> src trg
..
interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0
using \<rho>.leg0_is_map \<sigma>.leg1_is_map composable by (unfold_locales, auto)
lemma prj_char:
shows "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
and "Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
proof -
- have "Maps.arr (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
+ have "Maps.arr (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
using \<sigma>.leg1_in_hom Maps.CLS_in_hom \<sigma>.leg1_is_map Maps.arr_char by auto
- moreover have "Maps.arr (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
+ moreover have "Maps.arr (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
using Maps.CLS_in_hom composable r\<^sub>0s\<^sub>1.k_is_map by fastforce
- moreover have "Maps.cod (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>) =
- Maps.cod (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
+ moreover have "Maps.cod (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>) =
+ Maps.cod (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
unfolding Maps.arr_char
using \<sigma>.leg1_in_hom \<rho>.leg0_in_hom
by (simp add: Maps.cod_char calculation(1) calculation(2))
ultimately have "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> =
- \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
- Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk> \<and>
+ \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
+ Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk> \<and>
Maps.PRJ\<^sub>1 (Maps.CLS r\<^sub>0) (Maps.CLS s\<^sub>1) =
- \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
- Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk>"
+ \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
+ Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk>"
unfolding Maps.PRJ\<^sub>0_def Maps.PRJ\<^sub>1_def
using Maps.CLS_in_hom \<sigma>.leg1_is_map \<rho>.leg0_is_map composable by simp
- moreover have "r\<^sub>0\<^sup>* \<star> s\<^sub>1 \<cong> (Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
- Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
- proof -
- have "r\<^sub>0 \<cong> Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
+ moreover have "r\<^sub>0\<^sup>* \<star> s\<^sub>1 \<cong> (Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
+ Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
+ proof -
+ have "r\<^sub>0 \<cong> Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
using Maps.REP_CLS composable isomorphic_symmetric r\<^sub>0s\<^sub>1.k_is_map by fastforce
- hence 3: "isomorphic r\<^sub>0\<^sup>* (Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>*"
+ hence 3: "isomorphic r\<^sub>0\<^sup>* (Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>*"
using \<rho>.leg0_is_map
by (simp add: isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint)
- moreover have 4: "s\<^sub>1 \<cong> Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
+ moreover have 4: "s\<^sub>1 \<cong> Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
using Maps.REP_CLS isomorphic_symmetric r\<^sub>0s\<^sub>1.h_is_map by fastforce
ultimately show ?thesis
proof -
have 1: "src r\<^sub>0\<^sup>* = trg s\<^sub>1"
- using \<rho>.T0.antipar(2) r\<^sub>0s\<^sub>1.cospan by presburger
+ using \<rho>.T0.antipar(2) r\<^sub>0s\<^sub>1.cospan by argo
have 2: "ide s\<^sub>1"
by simp
- have "src (Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* = trg s\<^sub>1"
+ have "src (Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* = trg s\<^sub>1"
by (metis 3 \<rho>.T0.antipar(2) isomorphic_implies_hpar(3) r\<^sub>0s\<^sub>1.cospan)
thus ?thesis
using 1 2
by (meson 3 4 hcomp_ide_isomorphic hcomp_isomorphic_ide isomorphic_implies_ide(2)
isomorphic_transitive)
qed
qed
ultimately have 1: "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk> \<and>
Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
using r\<^sub>0s\<^sub>1.isomorphic_implies_same_tab by simp
show "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
using 1 by simp
show "Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
using 1 by simp
qed
end
context identity_in_bicategory_of_spans
begin
interpretation Maps: maps_category V H \<a> \<i> src trg ..
interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
notation isomorphic (infix "\<cong>" 50)
text \<open>
A 1-cell \<open>r\<close> in a bicategory of spans is a map if and only if the ``input leg''
\<open>tab\<^sub>0 r\<close> of the chosen tabulation of \<open>r\<close> is an equivalence map.
Since a tabulation of \<open>r\<close> is unique up to equivalence, and equivalence maps compose,
the result actually holds if ``chosen tabulation'' is replaced by ``any tabulation''.
\<close>
lemma is_map_iff_tab\<^sub>0_is_equivalence:
shows "is_left_adjoint r \<longleftrightarrow> equivalence_map (tab\<^sub>0 r)"
proof
assume 1: "equivalence_map (tab\<^sub>0 r)"
have 2: "equivalence_pair (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>*"
proof -
obtain g' \<eta>' \<epsilon>' where \<eta>'\<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) g' \<eta>' \<epsilon>'"
using 1 equivalence_map_def by auto
have "adjoint_pair (tab\<^sub>0 r) g'"
using \<eta>'\<epsilon>' equivalence_pair_def equivalence_pair_is_adjoint_pair by blast
moreover have "adjoint_pair (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>*"
using T0.adjunction_in_bicategory_axioms adjoint_pair_def by auto
ultimately have "g' \<cong> (tab\<^sub>0 r)\<^sup>*"
using left_adjoint_determines_right_up_to_iso by simp
thus ?thesis
using \<eta>'\<epsilon>' equivalence_pair_def equivalence_pair_isomorphic_right by blast
qed
obtain \<eta>' \<epsilon>' where \<eta>'\<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>* \<eta>' \<epsilon>'"
using 2 equivalence_pair_def by auto
interpret \<eta>'\<epsilon>': equivalence_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close> \<open>(tab\<^sub>0 r)\<^sup>*\<close> \<eta>' \<epsilon>'
using \<eta>'\<epsilon>' by auto
have "is_left_adjoint (tab\<^sub>0 r)\<^sup>*"
using 2 equivalence_pair_is_adjoint_pair equivalence_pair_symmetric by blast
hence "is_left_adjoint (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*)"
using left_adjoints_compose by simp
thus "is_left_adjoint r"
using yields_isomorphic_representation isomorphic_def left_adjoint_preserved_by_iso'
by meson
next
assume 1: "is_left_adjoint r"
have 2: "is_left_adjoint (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*)"
using 1 yields_isomorphic_representation left_adjoint_preserved_by_iso'
isomorphic_symmetric isomorphic_def
by meson
hence "is_left_adjoint (tab\<^sub>0 r)\<^sup>*"
using is_ide BS4 [of "tab\<^sub>1 r" "(tab\<^sub>0 r)\<^sup>*"] by auto
hence "is_left_adjoint ((tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>0 r) \<and> is_left_adjoint (tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
using left_adjoints_compose T0.antipar by simp
hence 3: "iso \<eta> \<and> iso \<epsilon>"
using BS3 [of "src (tab\<^sub>0 r)" "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>0 r" \<eta> \<eta>]
BS3 [of "tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*" "trg (tab\<^sub>0 r)" \<epsilon> \<epsilon>]
T0.unit_in_hom T0.counit_in_hom obj_is_self_adjoint
by auto
hence "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>* \<eta> \<epsilon>"
apply unfold_locales by auto
thus "equivalence_map (tab\<^sub>0 r)"
using equivalence_map_def by blast
qed
text \<open>
The chosen tabulation (and indeed, any other tabulation, which is equivalent)
of an object is symmetric in the sense that its two legs are isomorphic.
\<close>
lemma obj_has_symmetric_tab:
assumes "obj r"
shows "tab\<^sub>0 r \<cong> tab\<^sub>1 r"
proof -
have "tab\<^sub>0 r \<cong> r \<star> tab\<^sub>0 r"
proof -
have "trg (tab\<^sub>0 r) = r"
using assms by auto
moreover have "\<guillemotleft>\<l>\<^sup>-\<^sup>1[tab\<^sub>0 r] : tab\<^sub>0 r \<Rightarrow> trg (tab\<^sub>0 r) \<star> tab\<^sub>0 r\<guillemotright> \<and> iso \<l>\<^sup>-\<^sup>1[tab\<^sub>0 r]"
using assms by simp
ultimately show ?thesis
unfolding isomorphic_def by metis
qed
also have "... \<cong> tab\<^sub>1 r"
proof -
have "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
using tab_in_hom by simp
moreover have "is_left_adjoint (r \<star> tab\<^sub>0 r)"
using assms left_adjoints_compose obj_is_self_adjoint by simp
ultimately show ?thesis
using BS3 [of "tab\<^sub>1 r" "r \<star> tab\<^sub>0 r" tab tab] isomorphic_symmetric isomorphic_def
by auto
qed
finally show ?thesis by simp
qed
text \<open>
The chosen tabulation of \<open>r\<close> determines a span in \<open>Maps(B)\<close>.
\<close>
lemma determines_span:
assumes "ide r"
shows "span_in_category Maps.comp \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>\<rparr>"
using assms Maps.CLS_in_hom [of "tab\<^sub>0 r"] Maps.CLS_in_hom [of "tab\<^sub>1 r"]
tab\<^sub>0_in_hom tab\<^sub>1_in_hom
apply unfold_locales by fastforce
end
subsection "Arrows of Tabulations in Maps"
text \<open>
Here we consider the situation of two tabulations: a tabulation \<open>\<rho>\<close> of \<open>r\<close>
and a tabulation \<open>\<sigma>\<close> of \<open>s\<close>, both ``legs'' of each tabulation being maps,
together with an arbitrary 2-cell \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close>.
The 2-cell \<open>\<mu>\<close> at the base composes with the tabulation \<open>\<rho>\<close> to yield a 2-cell
\<open>\<Delta> = (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>\<close> ``over'' s. By property \<open>T1\<close> of tabulation \<open>\<sigma>\<close>, this induces a map
from the apex of \<open>\<rho>\<close> to the apex of \<open>\<sigma>\<close>, which together with the other data
forms a triangular prism whose sides commute up to (unique) isomorphism.
\<close>
text \<open>
$$
\xymatrix{
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^<-1>\sigma} & \\
&{\rm trg}~s && {\rm src}~s \ar[ll]^{s} \\
& \rrtwocell\omit{^\mu} &&\\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar@ {.>}[uuur]^<>(0.3){{\rm chine}} \dtwocell\omit{^\rho}& \\
{\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r \ar[ll]^{r} \ar@ {=}[uuur]
}
$$
\<close>
locale arrow_of_tabulations_in_maps =
bicategory_of_spans V H \<a> \<i> src trg +
\<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
\<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and \<rho> :: 'a
and r\<^sub>0 :: 'a
and r\<^sub>1 :: 'a
and s :: 'a
and \<sigma> :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a
and \<mu> :: 'a +
assumes in_hom: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
begin
abbreviation (input) \<Delta>
where "\<Delta> \<equiv> (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>"
lemma \<Delta>_in_hom [intro]:
shows "\<guillemotleft>\<Delta> : src \<rho> \<rightarrow> trg \<sigma>\<guillemotright>"
and "\<guillemotleft>\<Delta> : r\<^sub>1 \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>"
proof -
show "\<guillemotleft>\<Delta> : r\<^sub>1 \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>"
using in_hom hseqI' \<rho>.leg0_in_hom(2) \<rho>.tab_in_vhom' by auto
thus "\<guillemotleft>\<Delta> : src \<rho> \<rightarrow> trg \<sigma>\<guillemotright>"
by (metis \<rho>.tab_simps(3) \<rho>.base_in_hom(2) \<sigma>.tab_simps(3) \<sigma>.base_in_hom(2) arrI in_hom
seqI' vcomp_in_hhom vseq_implies_hpar(1-2))
qed
lemma \<Delta>_simps [simp]:
shows "arr \<Delta>"
and "src \<Delta> = src \<rho>" and "trg \<Delta> = trg \<sigma>"
and "dom \<Delta> = r\<^sub>1" and "cod \<Delta> = s \<star> r\<^sub>0"
using \<Delta>_in_hom by auto
abbreviation is_induced_map
where "is_induced_map w \<equiv> \<sigma>.is_induced_by_cell w r\<^sub>0 \<Delta>"
text \<open>
The following is an equivalent restatement, in elementary terms, of the conditions
for being an induced map.
\<close>
abbreviation (input) is_induced_map'
where "is_induced_map' w \<equiv>
ide w \<and>
(\<exists>\<nu> \<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
\<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>)"
lemma is_induced_map_iff:
shows "is_induced_map w \<longleftrightarrow> is_induced_map' w"
proof
assume w: "is_induced_map' w"
show "is_induced_map w"
proof
have 1: "dom \<Delta> = r\<^sub>1"
by auto
interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg
r\<^sub>0 \<open>dom \<Delta>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w
proof -
have "arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w"
using w apply unfold_locales by auto
thus "arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s \<sigma> s\<^sub>0 s\<^sub>1 w"
using 1 by simp
qed
show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s\<^sub>0 s\<^sub>1 w"
using w.arrow_of_spans_of_maps_axioms by auto
show "\<sigma>.composite_cell w w.the_\<theta> \<cdot> w.the_\<nu> = \<Delta>"
proof -
obtain \<theta> \<nu>
where \<theta>\<nu>: "\<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
\<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>"
using w w.the_\<theta>_props(1) by auto
have "(s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu> = \<Delta>"
using \<theta>\<nu> by argo
moreover have "\<theta> = w.the_\<theta> \<and> \<nu> = w.the_\<nu>"
using \<theta>\<nu> 1 w.the_\<nu>_props(1) w.leg0_uniquely_isomorphic w.leg1_uniquely_isomorphic
by auto
ultimately show ?thesis
using comp_assoc by simp
qed
qed
next
assume w: "is_induced_map w"
show "is_induced_map' w"
proof -
interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w
using w in_hom hseqI' by auto
interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w
..
have "dom \<Delta> = r\<^sub>1" by auto
thus ?thesis
using w comp_assoc w.the_\<nu>_props(1) w.the_\<nu>_props(2) w.uw\<theta> by metis
qed
qed
lemma exists_induced_map:
shows "\<exists>w. is_induced_map w"
proof -
obtain w \<theta> \<nu>
where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
\<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>"
using \<Delta>_in_hom \<rho>.ide_leg0 \<sigma>.T1 comp_assoc
by (metis in_homE)
thus ?thesis
using is_induced_map_iff by blast
qed
lemma induced_map_unique:
assumes "is_induced_map w" and "is_induced_map w'"
shows "w \<cong> w'"
using assms \<sigma>.induced_map_unique by blast
definition chine
where "chine \<equiv> SOME w. is_induced_map w"
lemma chine_is_induced_map:
shows "is_induced_map chine"
unfolding chine_def
using exists_induced_map someI_ex [of is_induced_map] by simp
lemma chine_in_hom [intro]:
shows "\<guillemotleft>chine : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>"
and "\<guillemotleft>chine: chine \<Rightarrow> chine\<guillemotright>"
proof -
show "\<guillemotleft>chine : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>"
using chine_is_induced_map
by (metis \<Delta>_simps(1) \<Delta>_simps(4) \<rho>.leg1_simps(3) \<sigma>.ide_base \<sigma>.ide_leg0 \<sigma>.leg0_simps(3)
\<sigma>.tab_simps(2) arrow_of_spans_of_maps.is_ide arrow_of_spans_of_maps.the_\<nu>_simps(2)
assoc_simps(2) hseqE in_hhom_def seqE src_vcomp vseq_implies_hpar(1))
show "\<guillemotleft>chine: chine \<Rightarrow> chine\<guillemotright>"
using chine_is_induced_map
by (meson arrow_of_spans_of_maps.is_ide ide_in_hom(2))
qed
lemma chine_simps [simp]:
shows "arr chine" and "ide chine"
and "src chine = src r\<^sub>0" and "trg chine = src s\<^sub>0"
and "dom chine = chine" and "cod chine = chine"
using chine_in_hom apply auto
by (meson arrow_of_spans_of_maps.is_ide chine_is_induced_map)
end
sublocale arrow_of_tabulations_in_maps \<subseteq>
arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 chine
using chine_is_induced_map is_induced_map_iff
by (unfold_locales, auto)
sublocale arrow_of_tabulations_in_maps \<subseteq>
arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 chine
..
context arrow_of_tabulations_in_maps
begin
text \<open>
The two factorizations of the composite 2-cell \<open>\<Delta>\<close> amount to a naturality condition.
\<close>
lemma \<Delta>_naturality:
shows "(\<mu> \<star> r\<^sub>0) \<cdot> \<rho> = (s \<star> the_\<theta>) \<cdot> \<a>[s, s\<^sub>0, chine] \<cdot> (\<sigma> \<star> chine) \<cdot> the_\<nu>"
using chine_is_induced_map is_induced_map_iff
by (metis leg0_uniquely_isomorphic(2) leg1_uniquely_isomorphic(2) the_\<nu>_props(1) uw\<theta>)
lemma induced_map_preserved_by_iso:
assumes "is_induced_map w" and "isomorphic w w'"
shows "is_induced_map w'"
proof -
interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w
using assms in_hom hseqI' by auto
interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w
..
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow> w'\<guillemotright> \<and> iso \<phi>"
using assms(2) isomorphic_def by auto
show ?thesis
proof
interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<Delta>\<close> s\<^sub>0 s\<^sub>1 w'
proof
show "is_left_adjoint r\<^sub>0"
by (simp add: \<rho>.satisfies_T0)
show "is_left_adjoint (dom \<Delta>)"
by (simp add: \<rho>.leg1_is_map)
show "ide w'" using assms by force
show "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
- proof -
- have "\<guillemotleft>w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>) : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
- using \<phi> w.the_\<theta>_props \<sigma>.leg0_in_hom(2) assms(2) comp_in_hom_simp' hcomp_in_vhom
- inv_in_hom isomorphic_implies_hpar(4) w.the_\<theta>_simps(4) w.w_simps(4)
- by presburger
- thus ?thesis by auto
- qed
+ using \<phi> w.the_\<theta>_props \<sigma>.leg0_in_hom(2) assms(2) comp_in_hom_simp' hcomp_in_vhom
+ inv_in_hom isomorphic_implies_hpar(4) w.the_\<theta>_simps(4) w.w_simps(4)
+ by metis
have "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
proof (intro conjI)
show "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
using \<phi> w.the_\<nu>_props
by (intro comp_in_homI, auto)
thus "iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
using \<phi> w.the_\<nu>_props
by (meson \<sigma>.ide_leg1 arrI iso_hcomp hseqE ide_is_iso isos_compose seqE)
qed
hence "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>"
by auto
thus "\<exists>\<nu>. \<guillemotleft>\<nu> : dom \<Delta> \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>"
using in_hom hseqI' by auto
qed
interpret w': arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg
r\<^sub>0 \<open>dom \<Delta>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w'
..
show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s\<^sub>0 s\<^sub>1 w'"
using w'.arrow_of_spans_of_maps_axioms in_hom hseqI' by auto
show "\<sigma>.composite_cell w' w'.the_\<theta> \<cdot> w'.the_\<nu> = \<Delta>"
proof -
have 1: "w'.the_\<theta> = w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)"
proof -
have "\<guillemotleft>w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>) : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
using w.the_\<theta>_props \<phi>
by (intro comp_in_homI, auto)
moreover have "\<guillemotleft>w'.the_\<theta> : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
using w'.the_\<theta>_props by simp
ultimately show ?thesis
using w'.leg0_uniquely_isomorphic(2) by blast
qed
moreover have "w'.the_\<nu> = (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
proof -
have "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : dom \<Delta> \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
using w.the_\<nu>_props \<phi>
by (intro comp_in_homI, auto)
moreover have "iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
using w.the_\<nu>_props \<phi> iso_hcomp
by (meson \<sigma>.ide_leg1 arrI calculation hseqE ide_is_iso isos_compose seqE)
ultimately show ?thesis
using w'.the_\<nu>_props w'.leg1_uniquely_isomorphic(2) by blast
qed
ultimately have "\<sigma>.composite_cell w' w'.the_\<theta> \<cdot> w'.the_\<nu> =
\<sigma>.composite_cell w' (w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)) \<cdot> (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
by simp
also have "... = (s \<star> w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot>
(\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (s \<star> w.the_\<theta>) \<cdot> ((s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot>
(\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>)) \<cdot> w.the_\<nu>"
using 1 comp_assoc w'.the_\<theta>_simps(1) whisker_left
by auto
also have "... = (s \<star> w.the_\<theta>) \<cdot> (\<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)) \<cdot> w.the_\<nu>"
proof -
have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) =
\<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)"
proof -
have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) =
\<a>[s, s\<^sub>0, w] \<cdot> ((s \<star> s\<^sub>0) \<star> inv \<phi>) \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>)"
proof -
have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] = \<a>[s, s\<^sub>0, w] \<cdot> ((s \<star> s\<^sub>0) \<star> inv \<phi>)"
using assms \<phi> assoc_naturality [of s s\<^sub>0 "inv \<phi>"] w.w_simps(4)
by (metis \<sigma>.leg0_simps(2-5) \<sigma>.base_simps(2-4) arr_inv cod_inv dom_inv
in_homE trg_cod)
thus ?thesis using comp_assoc by metis
qed
also have "... = \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>)"
proof -
have "((s \<star> s\<^sub>0) \<star> inv \<phi>) \<cdot> (\<sigma> \<star> w') = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>)"
using \<phi> comp_arr_dom comp_cod_arr in_hhom_def
interchange [of "s \<star> s\<^sub>0" \<sigma> "inv \<phi>" w']
interchange [of \<sigma> s\<^sub>1 w "inv \<phi>"]
by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)"
proof -
have "(\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>) = \<sigma> \<star> w"
proof -
have "(\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>) = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi> \<cdot> \<phi>)"
using \<phi> whisker_left in_hhom_def by auto
also have "... = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> w)"
using \<phi> comp_inv_arr' by auto
also have "... = \<sigma> \<star> w"
using whisker_right [of w \<sigma> s\<^sub>1] comp_arr_dom in_hhom_def by auto
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = \<Delta>"
using assms(1) comp_assoc w.is_ide w.the_\<nu>_props(1) w.the_\<theta>_props(1) by simp
finally show ?thesis
using comp_assoc by auto
qed
qed
qed
end
text \<open>
In the special case that \<open>\<mu>\<close> is an identity 2-cell, the induced map from the apex of \<open>\<rho>\<close>
to the apex of \<open>\<sigma>\<close> is an equivalence map.
\<close>
locale identity_arrow_of_tabulations_in_maps =
arrow_of_tabulations_in_maps +
assumes is_ide: "ide \<mu>"
begin
lemma r_eq_s:
shows "r = s"
using is_ide by (metis ide_char in_hom in_homE)
lemma \<Delta>_eq_\<rho>:
shows "\<Delta> = \<rho>"
by (meson \<Delta>_simps(1) comp_ide_arr ide_hcomp hseq_char' ide_u is_ide seqE
seq_if_composable)
lemma chine_is_equivalence:
shows "equivalence_map chine"
proof -
obtain w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
where e: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
\<guillemotleft>w : src s\<^sub>0 \<rightarrow> src r\<^sub>0\<guillemotright> \<and> \<guillemotleft>w' : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright> \<and>
\<guillemotleft>\<theta> : r\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : s\<^sub>1 \<Rightarrow> r\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
\<sigma> = (s \<star> \<theta>) \<cdot> \<a>[s, r\<^sub>0, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> \<and>
\<guillemotleft>\<theta>' : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu>' : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
\<rho> = (s \<star> \<theta>') \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> \<nu>'"
using r_eq_s \<sigma>.apex_unique_up_to_equivalence [of \<rho> r\<^sub>0 r\<^sub>1] \<rho>.tabulation_axioms by blast
have w': "equivalence_map w'"
using e equivalence_map_def by auto
hence "is_induced_map w'"
using e r_eq_s \<Delta>_eq_\<rho> is_induced_map_iff comp_assoc equivalence_map_is_ide by metis
hence "isomorphic chine w'"
using induced_map_unique chine_is_induced_map by simp
thus ?thesis
using w' equivalence_map_preserved_by_iso isomorphic_symmetric by blast
qed
end
text \<open>
The following gives an interpretation of @{locale arrow_of_tabulations_in_maps}
in the special case that the tabulations are those that we have chosen for the
domain and codomain of the underlying 2-cell \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close>.
In this case, we can recover \<open>\<mu>\<close> from \<open>\<Delta>\<close> via adjoint transpose.
\<close>
locale arrow_in_bicategory_of_spans =
bicategory_of_spans V H \<a> \<i> src trg +
r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r +
s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and s :: 'a
and \<mu> :: 'a +
assumes in_hom: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
begin
abbreviation (input) r\<^sub>0 where "r\<^sub>0 \<equiv> tab\<^sub>0 r"
abbreviation (input) r\<^sub>1 where "r\<^sub>1 \<equiv> tab\<^sub>1 r"
abbreviation (input) s\<^sub>0 where "s\<^sub>0 \<equiv> tab\<^sub>0 s"
abbreviation (input) s\<^sub>1 where "s\<^sub>1 \<equiv> tab\<^sub>1 s"
lemma is_arrow_of_tabulations_in_maps:
shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 s s.tab s\<^sub>0 s\<^sub>1 \<mu>"
using in_hom by (unfold_locales, auto)
end
sublocale identity_in_bicategory_of_spans \<subseteq> arrow_in_bicategory_of_spans V H \<a> \<i> src trg r r r
apply unfold_locales using is_ide by auto
context arrow_in_bicategory_of_spans
begin
interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 s s.tab s\<^sub>0 s\<^sub>1 \<mu>
using is_arrow_of_tabulations_in_maps by simp
interpretation r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 r r.tab r\<^sub>0 r\<^sub>1 r
using r.is_arrow_of_tabulations_in_maps by simp
lemma \<mu>_in_terms_of_\<Delta>:
shows "\<mu> = r.T0.trnr\<^sub>\<epsilon> (cod \<mu>) \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
proof -
have \<mu>: "arr \<mu>"
using in_hom by auto
have "\<mu> \<cdot> r.T0.trnr\<^sub>\<epsilon> r r.tab = r.T0.trnr\<^sub>\<epsilon> s \<Delta>"
proof -
have "\<mu> \<cdot> r.T0.trnr\<^sub>\<epsilon> r r.tab =
(\<mu> \<cdot> \<r>[r]) \<cdot> (r \<star> r.\<epsilon>) \<cdot> \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
- unfolding r.T0.trnr\<^sub>\<epsilon>_def using comp_assoc by simp
+ unfolding r.T0.trnr\<^sub>\<epsilon>_def using comp_assoc by presburger
also have "... = \<r>[s] \<cdot> ((\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>)) \<cdot>
\<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
using \<mu> runit_naturality comp_assoc
by (metis in_hom in_homE)
also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> ((\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot>
\<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*]) \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
proof -
have "(\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>) = \<mu> \<star> r.\<epsilon>"
using \<mu> interchange comp_arr_dom comp_cod_arr
by (metis in_hom in_homE r.T0.counit_simps(1) r.T0.counit_simps(3) r.u_simps(3)
src_dom)
also have "... = (s \<star> r.\<epsilon>) \<cdot> (\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
using in_hom interchange [of s \<mu> r.\<epsilon> "tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*"]
comp_arr_dom comp_cod_arr r.T0.counit_simps(1) r.T0.counit_simps(2)
by auto
finally have "(\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>) = (s \<star> r.\<epsilon>) \<cdot> (\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
by blast
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot>
((\<mu> \<star> tab\<^sub>0 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
proof -
have "(\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot> \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] =
\<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot> ((\<mu> \<star> tab\<^sub>0 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
using \<mu> assoc_naturality [of \<mu> "tab\<^sub>0 r" "(tab\<^sub>0 r)\<^sup>*"] hseqI'
by (metis ide_char in_hom in_homE r.T0.antipar(1) r.T0.ide_right r.u_simps(3)
src_dom u_simps(2) u_simps(4-5))
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot>
((\<mu> \<star> tab\<^sub>0 r) \<cdot> r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
using \<mu> whisker_right hseqI' \<Delta>_simps(1) by auto
also have "... = r.T0.trnr\<^sub>\<epsilon> s \<Delta>"
unfolding r.T0.trnr\<^sub>\<epsilon>_def by simp
finally show ?thesis by blast
qed
thus ?thesis
using \<mu> r.yields_isomorphic_representation invert_side_of_triangle(2)
by (metis in_hom in_homE seqI')
qed
end
subsubsection "Vertical Composite"
locale vertical_composite_of_arrows_of_tabulations_in_maps =
bicategory_of_spans V H \<a> \<i> src trg +
\<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
\<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 +
\<tau>: tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 +
\<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 \<mu> +
\<pi>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<pi>
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and \<rho> :: 'a
and r\<^sub>0 :: 'a
and r\<^sub>1 :: 'a
and s :: 'a
and \<sigma> :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a
and t :: 'a
and \<tau> :: 'a
and t\<^sub>0 :: 'a
and t\<^sub>1 :: 'a
and \<mu> :: 'a
and \<pi> :: 'a
begin
text \<open>
$$
\xymatrix{
&&& {\rm src}~\tau \ar[dl]_{t_1} \ar[dr]^{t_0} \dtwocell\omit{^<-1>\tau} & \\
&&{\rm trg}~t && {\rm src}~t \ar[ll]^{s} \\
&& \rrtwocell\omit{^\pi} && \\
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \ar[uuur]^<>(0.3){\pi.{\rm chine}} \dtwocell\omit{^<-1>\sigma} & \\
&{\rm trg}~s \ar@ {=}[uuur] && {\rm src}~s \ar[ll]^{s} \ar@ {=}[uuur] \\
& \rrtwocell\omit{^\mu} &&\\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar[uuur]^<>(0.3){\mu.{\rm chine}} \dtwocell\omit{^\rho} & \\
{\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r \ar[ll]^{r} \ar@ {=}[uuur]
}
$$
\<close>
notation isomorphic (infix "\<cong>" 50)
interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<open>\<pi> \<cdot> \<mu>\<close>
using \<mu>.in_hom \<pi>.in_hom by (unfold_locales, blast)
lemma is_arrow_of_tabulations_in_maps:
shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 (\<pi> \<cdot> \<mu>)"
..
lemma chine_char:
shows "chine \<cong> \<pi>.chine \<star> \<mu>.chine"
proof -
have "is_induced_map (\<pi>.chine \<star> \<mu>.chine)"
proof -
let ?f = "\<mu>.chine"
have f: "\<guillemotleft>?f : src \<rho> \<rightarrow> src \<sigma>\<guillemotright> \<and> is_left_adjoint ?f \<and> ide ?f \<and> \<mu>.is_induced_map ?f"
using \<mu>.chine_is_induced_map \<mu>.is_map by auto
let ?g = "\<pi>.chine"
have g: "\<guillemotleft>?g : src \<sigma> \<rightarrow> src \<tau>\<guillemotright> \<and> is_left_adjoint ?g \<and> ide ?g \<and> \<pi>.is_induced_map ?g"
using \<pi>.chine_is_induced_map \<pi>.is_map by auto
let ?\<theta> = "\<mu>.the_\<theta> \<cdot> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
let ?\<nu> = "\<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
have \<theta>: "\<guillemotleft>?\<theta> : t\<^sub>0 \<star> ?g \<star> ?f \<Rightarrow> r\<^sub>0\<guillemotright>"
using f g \<pi>.the_\<theta>_props \<mu>.the_\<theta>_props
by (intro comp_in_homI hcomp_in_vhom, auto+)
have \<nu>: "\<guillemotleft>?\<nu> : r\<^sub>1 \<Rightarrow> t\<^sub>1 \<star> ?g \<star> ?f\<guillemotright>"
using f g \<pi>.the_\<theta>_props \<mu>.the_\<theta>_props
by (intro comp_in_homI hcomp_in_vhom, auto)
interpret gf: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 t\<^sub>0 t\<^sub>1 \<open>?g \<star> ?f\<close>
proof
show "ide (?g \<star> ?f)" by simp
show "\<exists>\<theta>. \<guillemotleft>\<theta> : t\<^sub>0 \<star> ?g \<star> ?f \<Rightarrow> r\<^sub>0\<guillemotright>"
using \<theta> by auto
show "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> t\<^sub>1 \<star> ?g \<star> ?f\<guillemotright> \<and> iso \<nu>"
using \<nu> \<mu>.the_\<nu>_props \<mu>.the_\<theta>_props \<pi>.the_\<nu>_props \<pi>.the_\<theta>_props hseqI' isos_compose
by auto
qed
show ?thesis
proof (intro conjI)
have \<theta>_eq: "?\<theta> = gf.the_\<theta>"
using \<theta> gf.the_\<theta>_props gf.leg0_uniquely_isomorphic by auto
have \<nu>_eq: "?\<nu> = gf.the_\<nu>"
using \<nu> gf.the_\<nu>_props gf.leg1_uniquely_isomorphic by auto
have A: "src ?g = trg ?f"
using f g by fastforce
show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) t\<^sub>0 t\<^sub>1 (?g \<star> ?f)"
using gf.arrow_of_spans_of_maps_axioms by simp
have "((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot> gf.the_\<nu> = \<Delta>"
proof -
have "\<Delta> = (\<pi> \<star> r\<^sub>0) \<cdot> (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>"
using whisker_right comp_assoc
by (metis \<Delta>_simps(1) hseqE ide_u seqE)
also have "... = ((\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>)) \<cdot> \<a>[s, s\<^sub>0, ?f] \<cdot> (\<sigma> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
using \<mu>.\<Delta>_naturality comp_assoc by simp
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> ((\<pi> \<star> s\<^sub>0 \<star> ?f) \<cdot> \<a>[s, s\<^sub>0, ?f]) \<cdot> (\<sigma> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
proof -
have "(\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>) = \<pi> \<star> \<mu>.the_\<theta>"
using f comp_arr_dom comp_cod_arr \<mu>.the_\<theta>_props \<pi>.in_hom
interchange [of \<pi> s r\<^sub>0 \<mu>.the_\<theta>]
by auto
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<pi> \<star> s\<^sub>0 \<star> ?f)"
using f comp_arr_dom comp_cod_arr \<mu>.the_\<theta>_props \<pi>.in_hom
interchange [of t \<pi> \<mu>.the_\<theta> "s\<^sub>0 \<star> ?f"]
by auto
finally have "(\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>) = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<pi> \<star> s\<^sub>0 \<star> ?f)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot> (((\<pi> \<star> s\<^sub>0) \<star> ?f) \<cdot> (\<sigma> \<star> ?f)) \<cdot> \<mu>.the_\<nu>"
proof -
have "(\<pi> \<star> s\<^sub>0 \<star> ?f) \<cdot> \<a>[s, s\<^sub>0, ?f] = \<a>[t, s\<^sub>0, ?f] \<cdot> ((\<pi> \<star> s\<^sub>0) \<star> ?f)"
using f assoc_naturality [of \<pi> s\<^sub>0 ?f] \<pi>.in_hom by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot> (\<pi>.\<Delta> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
using whisker_right comp_assoc by simp
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot>
((t \<star> \<pi>.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g] \<cdot> (\<tau> \<star> ?g) \<cdot> \<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
using \<pi>.\<Delta>_naturality by simp
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot>
(((t \<star> \<pi>.the_\<theta>) \<star> ?f) \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) \<cdot> ((\<tau> \<star> ?g) \<star> ?f) \<cdot>
(\<pi>.the_\<nu> \<star> ?f)) \<cdot> \<mu>.the_\<nu>"
using f g \<pi>.the_\<theta>_props \<pi>.the_\<nu>_props whisker_right
by (metis \<pi>.\<Delta>_simps(1) \<pi>.\<Delta>_naturality seqE)
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<a>[t, s\<^sub>0, ?f] \<cdot>
((t \<star> \<pi>.the_\<theta>) \<star> ?f)) \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) \<cdot> ((\<tau> \<star> ?g) \<star> ?f) \<cdot>
(\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot>
(\<a>[t, t\<^sub>0 \<star> ?g, ?f] \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f)) \<cdot>
((\<tau> \<star> ?g) \<star> ?f) \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
using f \<pi>.the_\<theta>_props assoc_naturality [of t "\<pi>.the_\<theta>" ?f] \<pi>.\<theta>_simps(3) comp_assoc
by auto
also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot>
(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<a>[t \<star> t\<^sub>0, ?g, ?f] \<cdot>
((\<tau> \<star> ?g) \<star> ?f)) \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
proof -
have "seq \<a>[t, t\<^sub>0, ?g \<star> ?f] \<a>[t \<star> t\<^sub>0, ?g, ?f]"
using f g by fastforce
moreover have "inv (t \<star> \<a>[t\<^sub>0, ?g, ?f]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
using f g by simp
moreover have "iso (t \<star> \<a>[t\<^sub>0, ?g, ?f])"
using f g by simp
have "\<a>[t, t\<^sub>0 \<star> ?g, ?f] \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) =
(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> \<a>[t \<star> t\<^sub>0, ?g, ?f]"
proof -
have "seq \<a>[t, t\<^sub>0, ?g \<star> ?f] \<a>[t \<star> t\<^sub>0, ?g, ?f]"
using f g by fastforce
moreover have "inv (t \<star> \<a>[t\<^sub>0, ?g, ?f]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
using f g by simp
moreover have "iso (t \<star> \<a>[t\<^sub>0, ?g, ?f])"
using f g by simp
ultimately show ?thesis
using A f g pentagon hseqI' invert_side_of_triangle(1)
by (metis \<pi>.w_simps(4) \<tau>.ide_base \<tau>.ide_leg0 \<tau>.leg0_simps(3))
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f)) \<cdot>
(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f) \<cdot>
\<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
using f g assoc_naturality [of \<tau> ?g ?f] comp_assoc by simp
also have "... = (t \<star> \<mu>.the_\<theta> \<cdot> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot>
\<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot>
(\<tau> \<star> ?g \<star> ?f) \<cdot> \<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
proof -
have 1: "seq \<mu>.the_\<theta> ((\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f])"
using \<theta>_eq by auto
hence "t \<star> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f] =
(t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f])"
using whisker_left \<tau>.ide_base by blast
thus ?thesis
using 1 whisker_left \<tau>.ide_base comp_assoc by presburger
qed
also have "... = ((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot> gf.the_\<nu>"
using \<theta>_eq \<nu>_eq by (simp add: comp_assoc)
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
thus "((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot>
arrow_of_spans_of_maps.the_\<nu> (\<cdot>) (\<star>) (dom ((\<pi> \<cdot> \<mu> \<star> r\<^sub>0) \<cdot> \<rho>)) t\<^sub>1 (?g \<star> ?f) =
\<Delta>"
by simp
qed
qed
thus ?thesis
using chine_is_induced_map induced_map_unique by simp
qed
end
sublocale vertical_composite_of_arrows_of_tabulations_in_maps \<subseteq>
arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 "\<pi> \<cdot> \<mu>"
using is_arrow_of_tabulations_in_maps by simp
subsubsection "Horizontal Composite"
locale horizontal_composite_of_arrows_of_tabulations_in_maps =
bicategory_of_spans V H \<a> \<i> src trg +
\<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
\<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 +
\<tau>: tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 +
\<mu>: tabulation_in_maps V H \<a> \<i> src trg u \<mu> u\<^sub>0 u\<^sub>1 +
\<rho>\<sigma>: composite_tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 +
\<tau>\<mu>: composite_tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 u \<mu> u\<^sub>0 u\<^sub>1 +
\<omega>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<omega> +
\<chi>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 u \<mu> u\<^sub>0 u\<^sub>1 \<chi>
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and \<rho> :: 'a
and r\<^sub>0 :: 'a
and r\<^sub>1 :: 'a
and s :: 'a
and \<sigma> :: 'a
and s\<^sub>0 :: 'a
and s\<^sub>1 :: 'a
and t :: 'a
and \<tau> :: 'a
and t\<^sub>0 :: 'a
and t\<^sub>1 :: 'a
and u :: 'a
and \<mu> :: 'a
and u\<^sub>0 :: 'a
and u\<^sub>1 :: 'a
and \<omega> :: 'a
and \<chi> :: 'a
begin
text \<open>
$$
\xymatrix{
&&& {\rm src}~t_0u_1.\phi \ar[dl]_{\tau\mu.p_1} \ar[dr]^{\tau\mu.p_0} \ddtwocell\omit{^{t_0u_1.\phi}} \\
&& {\rm src}~\tau \ar[dl]_{t_1} \ar[dr]^<>(0.4){t_0} \dtwocell\omit{^<-1>\tau}
&& {\rm src}~\mu \ar[dl]_{u_1} \ar[dr]^{u_0} \dtwocell\omit{^<-1>\mu} & \\
& {\rm trg}~t && {\rm src}~t = {\rm trg}~u \ar[ll]^{t}
&& {\rm src}~u \ar[ll]^{u} \\
& \xtwocell[r]{}\omit{^\omega}
& {\rm src}~r_0s_1.\phi \ar[uuur]_<>(0.2){{\rm chine}}
\ar[dl]^{\rho\sigma.p_1} \ar[dr]_{\rho\sigma.p_0\hspace{20pt}} \ddtwocell\omit{^{r_0s_1.\phi}}
& \rrtwocell\omit{^\chi} && \\
& {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar[uuur]^<>(0.4){\omega.{\rm chine}} \dtwocell\omit{^\rho}
&& {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \ar[uuur]^<>(0.4){\chi.{\rm chine}} \dtwocell\omit{^<-1>\sigma} & \\
{\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} \ar@ {=}[uuur]
&& {\rm src}~s \ar[ll]^{s} \ar@ {=}[uuur] \\
}
$$
\<close>
notation isomorphic (infix "\<cong>" 50)
interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<close>
\<open>t \<star> u\<close> \<tau>\<mu>.tab \<open>u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0\<close> \<open>t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1\<close> \<open>\<omega> \<star> \<chi>\<close>
using \<rho>\<sigma>.composable \<omega>.in_hom \<chi>.in_hom hseqI'
by (unfold_locales, auto)
lemma is_arrow_of_tabulations_in_maps:
shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
(r \<star> s) \<rho>\<sigma>.tab (s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1)
(t \<star> u) \<tau>\<mu>.tab (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) (\<omega> \<star> \<chi>)"
..
sublocale arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<close>
\<open>t \<star> u\<close> \<tau>\<mu>.tab \<open>u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0\<close> \<open>t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1\<close> \<open>\<omega> \<star> \<chi>\<close>
using is_arrow_of_tabulations_in_maps by simp
interpretation Maps: maps_category V H \<a> \<i> src trg ..
notation Maps.comp (infixr "\<odot>" 55)
interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg s\<^sub>1 r\<^sub>0
using \<rho>.leg0_is_map \<sigma>.leg1_is_map \<rho>\<sigma>.composable apply unfold_locales by auto
interpretation r\<^sub>0s\<^sub>1: arrow_of_tabulations_in_maps \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
\<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close> r\<^sub>0s\<^sub>1.tab r\<^sub>0s\<^sub>1.p\<^sub>0 r\<^sub>0s\<^sub>1.p\<^sub>1
\<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close> r\<^sub>0s\<^sub>1.tab r\<^sub>0s\<^sub>1.p\<^sub>0 r\<^sub>0s\<^sub>1.p\<^sub>1
\<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>
using r\<^sub>0s\<^sub>1.is_arrow_of_tabulations_in_maps by simp
interpretation t\<^sub>0u\<^sub>1: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg u\<^sub>1 t\<^sub>0
using \<tau>.leg0_is_map \<mu>.leg1_is_map \<tau>\<mu>.composable apply unfold_locales by auto
interpretation t\<^sub>0u\<^sub>1: arrow_of_tabulations_in_maps \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
\<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close> t\<^sub>0u\<^sub>1.tab t\<^sub>0u\<^sub>1.p\<^sub>0 t\<^sub>0u\<^sub>1.p\<^sub>1
\<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close> t\<^sub>0u\<^sub>1.tab t\<^sub>0u\<^sub>1.p\<^sub>0 t\<^sub>0u\<^sub>1.p\<^sub>1
\<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close>
using t\<^sub>0u\<^sub>1.is_arrow_of_tabulations_in_maps by simp
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
text \<open>
The following lemma states that the rectangular faces of the ``top prism'' commute
up to isomorphism. This was not already proved in @{locale composite_tabulation_in_maps},
because there we did not consider any composite structure of the ``source'' 2-cell.
There are common elements, though to the proof that the composite of tabulations is
a tabulation and the present lemma.
The proof idea is to use property \<open>T2\<close> of the ``base'' tabulations to establish the
existence of the desired isomorphisms. The proofs have to be carried out in
sequence, starting from the ``output'' side, because the arrow \<open>\<beta>\<close> required in the
hypotheses of \<open>T2\<close> depends, for the ``input'' tabulation, on the isomorphism constructed
for the ``output'' tabulation.
\<close>
lemma prj_chine:
shows "\<tau>\<mu>.p\<^sub>0 \<star> chine \<cong> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
and "\<tau>\<mu>.p\<^sub>1 \<star> chine \<cong> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
proof -
have 1: "arrow_of_spans_of_maps V H \<a> \<i> src trg
(s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1) (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) chine \<and>
(((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<tau>\<mu>.tab \<star> chine)) \<cdot> the_\<nu> =
((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab"
using chine_is_induced_map by simp
let ?u\<^sub>\<tau> = "u \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
let ?w\<^sub>\<tau> = "\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
let ?w\<^sub>\<tau>' = "\<tau>\<mu>.p\<^sub>1 \<star> chine"
have u\<^sub>\<tau>: "ide ?u\<^sub>\<tau>"
using \<chi>.u_simps(3) by auto
have w\<^sub>\<tau>: "ide ?w\<^sub>\<tau> \<and> is_left_adjoint ?w\<^sub>\<tau>"
by (simp add: \<omega>.is_map \<rho>.T0.antipar(1) left_adjoints_compose)
have w\<^sub>\<tau>': "ide ?w\<^sub>\<tau>' \<and> is_left_adjoint ?w\<^sub>\<tau>'"
by (simp add: is_map left_adjoints_compose)
let ?\<theta>\<^sub>\<tau> = "\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot> (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
let ?\<theta>\<^sub>\<tau>' = "(u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
let ?\<beta>\<^sub>\<tau> = "\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
have \<theta>\<^sub>\<tau>: "\<guillemotleft>?\<theta>\<^sub>\<tau> : t\<^sub>0 \<star> ?w\<^sub>\<tau> \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
using \<rho>.T0.antipar(1) \<omega>.the_\<theta>_in_hom \<chi>.u_simps(3)
apply (intro comp_in_homI, auto)
by (intro hcomp_in_vhom, auto)
have \<theta>\<^sub>\<tau>': "\<guillemotleft>?\<theta>\<^sub>\<tau>' : t\<^sub>0 \<star> ?w\<^sub>\<tau>' \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
proof (intro comp_in_homI)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] : t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine \<Rightarrow> (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
using t\<^sub>0u\<^sub>1.p\<^sub>1_simps assoc'_in_hom by simp
show "\<guillemotleft>t\<^sub>0u\<^sub>1.\<phi> \<star> chine : (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
using \<tau>.T0.antipar(1)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>(\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine : (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine : ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> (u \<star> u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
using assoc_in_hom by auto
show "\<guillemotleft>\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] : (u \<star> u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> u \<star> (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
by auto
show "\<guillemotleft>u \<star> the_\<theta> : u \<star> (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
by (intro hcomp_in_vhom, auto)
qed
have \<beta>\<^sub>\<tau>: "\<guillemotleft>?\<beta>\<^sub>\<tau> : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
proof (intro comp_in_homI)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> (t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
using \<rho>.T0.antipar(1) by auto
show "\<guillemotleft>inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1 : (t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
using \<omega>.the_\<nu>_props \<rho>.T0.antipar(1)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>the_\<nu> : r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
using the_\<nu>_in_hom(2) by simp
show "\<guillemotleft>\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] : (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
using t\<^sub>0u\<^sub>1.p\<^sub>1_simps assoc_in_hom by simp
qed
define LHS where "LHS = (t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)"
have LHS: "\<guillemotleft>LHS : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
proof (unfold LHS_def, intro comp_in_homI)
show "\<guillemotleft>\<tau> \<star> ?w\<^sub>\<tau> : t\<^sub>1 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t \<star> t\<^sub>0) \<star> ?w\<^sub>\<tau>\<guillemotright>"
using \<rho>.T0.antipar(1)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] : (t \<star> t\<^sub>0) \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>\<guillemotright>"
using \<rho>.T0.antipar(1) by auto
show "\<guillemotleft>t \<star> ?\<theta>\<^sub>\<tau> : t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
proof -
have "src t = trg (t\<^sub>0 \<star> \<omega>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>1)"
by (metis \<chi>.u_simps(3) \<mu>.ide_base \<sigma>.ide_leg0 \<sigma>.leg1_simps(3) \<tau>\<mu>.composable
\<theta>\<^sub>\<tau> arrI assoc_simps(3) r\<^sub>0s\<^sub>1.ide_u r\<^sub>0s\<^sub>1.p\<^sub>0_simps trg_vcomp vconn_implies_hpar(2))
thus ?thesis
using \<theta>\<^sub>\<tau> by blast
qed
qed
define RHS where "RHS = ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> ?\<beta>\<^sub>\<tau>"
have RHS: "\<guillemotleft>RHS : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
unfolding RHS_def
proof
show "\<guillemotleft>?\<beta>\<^sub>\<tau> : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
using \<beta>\<^sub>\<tau> by simp
show "\<guillemotleft>(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') : t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
proof
show "\<guillemotleft>\<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') : t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
using \<tau>.T0.antipar(1) by fastforce
show "\<guillemotleft>t \<star> ?\<theta>\<^sub>\<tau>' : t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
using w\<^sub>\<tau>' \<theta>\<^sub>\<tau>' \<tau>.leg0_simps(2) \<tau>.leg0_simps(3) hseqI' ideD(1) t\<^sub>0u\<^sub>1.p\<^sub>1_simps
trg_hcomp' \<tau>.base_in_hom(2) hcomp_in_vhom
by presburger
qed
qed
have eq: "LHS = RHS"
proof -
have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) = \<Delta>"
proof -
text \<open>
Here we use \<open>\<omega>.\<Delta>_naturality\<close> to replace @{term \<omega>.chine}
in favor of @{term \<omega>}.
We have to bring @{term \<omega>.the_\<nu>}, @{term \<tau>}, and @{term \<omega>.the_\<theta>} together,
with @{term \<rho>\<sigma>.p\<^sub>1} on the right.
\<close>
have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
(t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
\<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot>
(\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
unfolding LHS_def
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
(t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
\<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
\<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
(t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
(t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1])"
using whisker_left \<tau>.ide_base \<theta>\<^sub>\<tau> arrI seqE
by (metis (full_types))
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
(t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
\<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "(\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
\<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1)"
using assoc_naturality
by (metis \<omega>.w_simps(2-6) \<rho>.leg1_simps(3) \<rho>\<sigma>.leg1_simps(2) \<tau>.tab_simps(1)
\<tau>.tab_simps(2,4-5) hseqE r\<^sub>0s\<^sub>1.leg1_simps(5) r\<^sub>0s\<^sub>1.leg1_simps(6))
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
((t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
(\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
(\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot>
\<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
\<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "seq \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
by (simp add: \<rho>.T0.antipar(1))
moreover have "inv (t \<star> \<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
using \<rho>.T0.antipar(1) inv_hcomp [of t "\<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"] by simp
ultimately show ?thesis
using pentagon \<rho>.T0.antipar(1) iso_hcomp
invert_side_of_triangle(1)
[of "\<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
"t \<star> \<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
"\<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1)"]
by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (((t \<star> \<omega>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
(\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot>
(\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "(t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((t \<star> \<omega>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>1)"
using assoc_naturality [of t \<omega>.the_\<theta> \<rho>\<sigma>.p\<^sub>1] \<omega>.\<theta>_simps(3) \<rho>\<sigma>.leg1_simps(2) hseq_char
by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
using whisker_right \<rho>.T0.antipar(1) \<omega>.\<Delta>_simps(1) \<omega>.\<Delta>_naturality comp_assoc
by fastforce
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> ((t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0 = (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)"
using whisker_left whisker_right \<rho>.T0.antipar(1)
by (metis (full_types) \<chi>.\<Delta>_simps(1) \<tau>.ide_base \<theta>\<^sub>\<tau> arrI r\<^sub>0s\<^sub>1.ide_u seqE)
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "(t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0) =
t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0)"
using hseqI' \<chi>.in_hom whisker_left by auto
also have "... = t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]"
using assoc_naturality [of \<chi> s\<^sub>0 \<rho>\<sigma>.p\<^sub>0] \<chi>.in_hom by auto
also have "... = (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0])"
proof -
have "seq (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]"
using hseqI' \<chi>.in_hom
apply (intro seqI hseqI)
apply auto
proof -
show "\<guillemotleft>\<chi> : src u \<rightarrow> trg \<chi>\<guillemotright>"
by (metis \<chi>.\<Delta>_simps(1) \<chi>.u_simps(3) hseqE in_hhom_def seqE)
show "dom (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) = s \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
by (metis \<Delta>_simps(1) \<chi>.in_hom hcomp_simps(1,3) hseq_char in_homE seqE
u_simps(4))
qed
thus ?thesis
using whisker_left by simp
qed
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
(\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
using whisker_right comp_assoc by simp
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
(\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
using assoc_naturality [of \<omega> r\<^sub>0 \<rho>\<sigma>.p\<^sub>1] \<omega>.in_hom \<rho>.T0.antipar(1) comp_assoc
by fastforce
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> ((t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "(t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1) = \<omega> \<star> r\<^sub>0s\<^sub>1.\<phi>"
using comp_cod_arr comp_arr_dom \<omega>.in_hom interchange comp_ide_arr
by (metis \<tau>.base_in_hom(2) \<tau>.ide_base r\<^sub>0s\<^sub>1.\<phi>_simps(1) r\<^sub>0s\<^sub>1.\<phi>_simps(4) seqI')
also have "... = (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>)"
using r\<^sub>0s\<^sub>1.\<phi>_in_hom comp_cod_arr comp_arr_dom \<omega>.in_hom interchange
by (metis in_homE)
finally have "(t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1) = (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
((t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
(\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
using whisker_left \<rho>.T0.antipar(1) \<rho>\<sigma>.composable \<chi>.in_hom hseqI' comp_assoc by auto
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
(\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "(t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) =
\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)"
proof -
have "\<guillemotleft>(\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) : s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> u \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
using \<omega>.in_hom \<chi>.in_hom hseqI'
apply (intro comp_in_homI hcomp_in_vhom, auto)
by auto
thus ?thesis
by (metis (no_types) \<omega>.in_hom comp_arr_dom comp_cod_arr in_homE
interchange)
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
(\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) =
(\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0))"
proof -
have "seq (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (\<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0))"
using \<chi>.in_hom hseqI'
apply (intro seqI hseqI, auto)
proof -
show "\<guillemotleft>\<chi> : src u \<rightarrow> trg \<chi>\<guillemotright>"
using \<chi>.in_hom by auto
show "dom (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) = s \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
using \<chi>.in_hom hseqI' in_hom by fastforce
qed
thus ?thesis
using comp_arr_dom comp_cod_arr \<omega>.in_hom \<chi>.in_hom hseqI' interchange
by (metis in_homE)
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
(r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) =
((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0]"
using assoc_naturality \<omega>.in_hom \<chi>.in_hom
by (metis \<rho>\<sigma>.leg0_simps(3) assoc'_naturality hcomp_in_vhomE in_hom in_homE
u_simps(2) u_simps(4) u_simps(5))
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<Delta>"
using whisker_left hseqI' \<rho>\<sigma>.tab_def comp_assoc by simp
finally show ?thesis by auto
qed
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
proof -
text \<open>Now cancel @{term \<omega>.the_\<nu>} and its inverse.\<close>
have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
(t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
(\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
(t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
((\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
unfolding RHS_def
using comp_assoc by presburger
also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
(t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
(\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
(t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu>"
proof -
have "the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
((\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
((t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
using comp_inv_arr \<rho>.T0.antipar(1) comp_assoc_assoc' by simp
also have "... = the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
using comp_cod_arr hseqI' \<rho>.T0.antipar(1) by simp
also have "... = the_\<nu> \<cdot> (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1)"
using whisker_right [of \<rho>\<sigma>.p\<^sub>1] r\<^sub>0s\<^sub>1.ide_leg1 \<omega>.the_\<nu>_props(2) \<omega>.the_\<nu>_simps(4)
\<rho>.leg1_simps(2) comp_inv_arr'
by metis
also have "... = the_\<nu>"
using comp_arr_dom by simp
finally show ?thesis
using comp_assoc by simp
qed
text \<open>
Now reassociate to move @{term the_\<theta>} to the left and get other terms composed
with @{term chine}, where they can be reduced to @{term \<tau>\<mu>.tab}.
\<close>
also have "... = (\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
(t \<star> u \<star> the_\<theta>)) \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
(t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu>"
proof -
have "arr ((u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
using \<theta>\<^sub>\<tau>' by blast
moreover have "arr (\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
using calculation by blast
moreover have "arr ((\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
using calculation by blast
moreover have "arr (((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
using calculation by blast
moreover have "arr ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
using calculation by blast
ultimately
have "t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] =
(t \<star> u \<star> the_\<theta>) \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
(t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
- using \<theta>\<^sub>\<tau>' whisker_left hseqI' \<rho>.T0.antipar(1) seqE \<tau>.ide_base by presburger
- thus ?thesis
- using comp_assoc by simp
+ using whisker_left \<rho>.T0.antipar(1) \<tau>.ide_base by presburger
+ thus ?thesis
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
(t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
((\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot> \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> the_\<nu>"
using assoc'_naturality [of t u the_\<theta>] \<tau>\<mu>.composable \<theta>_simps(3) comp_assoc by auto
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
(t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
((t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
\<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
proof -
have "(\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot> \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] =
\<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine)"
using assoc_naturality
by (metis \<tau>.leg1_simps(3) \<tau>.tab_simps(1,2,4) \<tau>.tab_simps(5) \<tau>\<mu>.leg0_simps(2)
\<tau>\<mu>.leg1_simps(2) hseqE src_hcomp' t\<^sub>0u\<^sub>1.leg1_simps(3,5-6) w_simps(2)
w_simps(4-6))
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
(t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
((t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
proof -
have "(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
\<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] =
\<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine)"
using pentagon t\<^sub>0u\<^sub>1.p\<^sub>1_simps uw\<theta> \<tau>.T0.antipar(1) hseqI' iso_hcomp
comp_assoc_assoc'
invert_side_of_triangle(1)
[of "\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
"t \<star> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
"\<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine)"]
by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
proof -
have "(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] =
\<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine)"
using assoc_naturality [of t t\<^sub>0u\<^sub>1.\<phi> chine] t\<^sub>0u\<^sub>1.cospan by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
\<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
proof -
have "(t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine] =
\<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> ((t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0)) \<star> chine)"
using assoc_naturality [of t "\<mu> \<star> \<tau>\<mu>.p\<^sub>0" chine]
by (simp add: \<tau>\<mu>.composable hseqI')
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
\<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
proof -
have "(((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) =
((t \<star> ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0)) \<star> chine) \<cdot> ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine)"
using whisker_right whisker_left [of t "\<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]" "\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]"]
\<tau>\<mu>.composable hseqI' comp_assoc_assoc'
by simp
also have "... = (t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine"
using comp_cod_arr \<tau>\<mu>.composable hseqI' by simp
finally have "(((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) =
(t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine"
by simp
thus ?thesis
using comp_assoc by metis
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
\<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (((\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
(\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
proof -
have "((\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot>
((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) =
((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)"
using comp_inv_arr' comp_cod_arr \<tau>\<mu>.composable hseqI' comp_assoc_assoc'
whisker_right [of chine "\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0]" "\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0]"]
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
\<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine)) \<cdot> the_\<nu>"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot>
(\<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
(t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
\<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot>
(\<tau>\<mu>.tab \<star> chine) \<cdot> the_\<nu>"
proof -
have "(\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
(\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) =
\<tau>\<mu>.tab \<star> chine"
using uw\<theta> whisker_right [of chine] hseqI'
by (metis \<tau>\<mu>.tab_def \<tau>\<mu>.tab_in_vhom' arrI seqE)
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<tau>\<mu>.tab \<star> chine) \<cdot> the_\<nu>"
proof -
have "\<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
(t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, \<^bold>\<langle>u\<^bold>\<rangle>, (\<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, (\<^bold>\<langle>u\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
((\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, \<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>)\<rbrace>"
using \<a>'_def \<alpha>_def \<tau>\<mu>.composable by simp
also have "... = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using \<tau>\<mu>.composable
apply (intro E.eval_eqI) by simp_all
also have "... = \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]"
using \<a>'_def \<alpha>_def \<tau>\<mu>.composable by simp
finally show ?thesis by simp
qed
also have "... = \<Delta>"
using \<Delta>_naturality by simp
finally show ?thesis by simp
qed
finally have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
by blast
(*
* TODO: This is common enough that there should be "cancel_iso_left" and
* "cancel_iso_right" rules for doing it.
*)
hence "(LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
(RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
using u\<^sub>\<tau> r\<^sub>0s\<^sub>1.ide_u LHS RHS iso_is_section [of "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0]"] section_is_mono
monoE hseqI' \<tau>\<mu>.composable comp_assoc
by (metis (no_types, lifting) \<Delta>_simps(1) \<mu>.ide_base
\<open>\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, r\<^sub>0s\<^sub>1.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> r\<^sub>0s\<^sub>1.p\<^sub>1) =
((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab\<close>
\<tau>.ide_base hseq_char ideD(1) ide_u iso_assoc')
hence 1: "LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] = RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
using epiE LHS RHS iso_is_retraction retraction_is_epi hseqI' \<tau>\<mu>.composable
\<omega>.the_\<nu>_props iso_hcomp
by (metis \<Delta>_simps(1) \<omega>.the_\<nu>_simps(2)
\<open>((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab =
\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, r\<^sub>0s\<^sub>1.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> r\<^sub>0s\<^sub>1.p\<^sub>1)\<close>
\<rho>.leg1_simps(3) ide_is_iso local.comp_assoc r\<^sub>0s\<^sub>1.ide_leg1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps seqE)
show "LHS = RHS"
proof -
have "epi \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
using iso_is_retraction retraction_is_epi \<rho>.T0.antipar(1) by simp
moreover have "seq LHS \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
using LHS \<rho>.T0.antipar(1) by auto
moreover have "seq RHS \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
using RHS \<rho>.T0.antipar(1) by auto
ultimately show ?thesis
using epiE 1 by blast
qed
qed
have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)"
using LHS_def RHS_def u\<^sub>\<tau> w\<^sub>\<tau> w\<^sub>\<tau>' \<beta>\<^sub>\<tau> \<theta>\<^sub>\<tau> \<theta>\<^sub>\<tau>' eq \<tau>.T2 [of ?w\<^sub>\<tau> ?w\<^sub>\<tau>' ?\<theta>\<^sub>\<tau> ?u\<^sub>\<tau> ?\<theta>\<^sub>\<tau>' ?\<beta>\<^sub>\<tau>]
by fastforce
obtain \<gamma>\<^sub>\<tau> where \<gamma>\<^sub>\<tau>: "\<guillemotleft>\<gamma>\<^sub>\<tau> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
using 1 by auto
text \<open>
At this point we could show that @{term \<gamma>\<^sub>\<tau>} is invertible using \<open>BS3\<close>,
but we want to avoid using \<open>BS3\<close> if possible and we also want to
establish a characterization of @{term "inv \<gamma>\<^sub>\<tau>"}. So we show the invertibility of
@{term \<gamma>\<^sub>\<tau>} directly, using a few more applications of \<open>T2\<close>.
\<close>
have iso_\<beta>\<^sub>\<tau>: "iso ?\<beta>\<^sub>\<tau>"
using uw\<theta> \<beta>\<^sub>\<tau> the_\<nu>_props \<omega>.the_\<nu>_props iso_inv_iso hseqI'
iso_assoc' \<omega>.hseq_leg\<^sub>0 iso_inv_iso iso_hcomp
apply (intro isos_compose)
apply (metis \<omega>.is_ide \<rho>\<sigma>.leg1_simps(2) \<tau>.ide_leg1 \<tau>.leg1_simps(2)
\<tau>.leg1_simps(3) hseqE r\<^sub>0s\<^sub>1.ide_leg1 hcomp_simps(1) vconn_implies_hpar(3))
apply (metis \<rho>\<sigma>.leg1_simps(2) hseqE ide_is_iso r\<^sub>0s\<^sub>1.ide_leg1 src_inv
vconn_implies_hpar(1))
apply blast
apply blast
apply blast
apply (metis \<tau>.ide_leg1 \<tau>.leg1_simps(3) hseqE ide_char iso_assoc t\<^sub>0u\<^sub>1.ide_leg1
t\<^sub>0u\<^sub>1.p\<^sub>1_simps w\<^sub>\<tau>')
by blast
hence eq': "((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) =
((t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)) \<cdot> inv ?\<beta>\<^sub>\<tau>"
proof -
have "seq ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) ?\<beta>\<^sub>\<tau>"
using LHS RHS_def eq by blast
hence "(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') =
(((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> ?\<beta>\<^sub>\<tau>) \<cdot> inv ?\<beta>\<^sub>\<tau>"
by (meson invert_side_of_triangle(2) iso_\<beta>\<^sub>\<tau>)
thus ?thesis
- using LHS_def RHS_def eq by presburger
+ using LHS_def RHS_def eq by argo
qed
have 2: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> inv ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>)"
using u\<^sub>\<tau> w\<^sub>\<tau> w\<^sub>\<tau>' \<beta>\<^sub>\<tau> \<theta>\<^sub>\<tau> \<theta>\<^sub>\<tau>' eq' \<tau>.T2 [of ?w\<^sub>\<tau>' ?w\<^sub>\<tau> ?\<theta>\<^sub>\<tau>'?u\<^sub>\<tau> ?\<theta>\<^sub>\<tau> "inv ?\<beta>\<^sub>\<tau>"] iso_\<beta>\<^sub>\<tau> comp_assoc
by blast
obtain \<gamma>\<^sub>\<tau>' where
\<gamma>\<^sub>\<tau>': "\<guillemotleft>\<gamma>\<^sub>\<tau>' : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> inv ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
using 2 by auto
have "inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'"
proof
have "\<guillemotleft>\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright>"
using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' by auto
moreover have "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> = t\<^sub>1 \<star> ?w\<^sub>\<tau>"
using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left \<beta>\<^sub>\<tau> iso_\<beta>\<^sub>\<tau> comp_inv_arr'
by (metis (no_types, lifting) \<tau>.ide_leg1 calculation in_homE)
moreover have "?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
proof -
have "?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
using \<gamma>\<^sub>\<tau> by simp
also have "... = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>') \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
using \<gamma>\<^sub>\<tau>' comp_assoc by simp
also have "... = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left
by (metis (full_types) \<tau>.ide_leg0 seqI')
finally show ?thesis by simp
qed
moreover have
"\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>) \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>"
proof -
have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> ?w\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>)"
proof -
have "(t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>) =
((t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)) \<cdot> (t\<^sub>1 \<star> ?w\<^sub>\<tau>)"
by (metis LHS LHS_def comp_arr_dom in_homE)
thus ?thesis
using w\<^sub>\<tau> \<theta>\<^sub>\<tau> \<omega>.w_simps(4) \<tau>.leg1_in_hom(2) \<tau>.leg1_simps(3) hcomp_in_vhom ideD(1)
trg_hcomp' ide_in_hom(2) \<tau>.T2
by presburger
qed
thus "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>) \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>"
by (metis \<theta>\<^sub>\<tau> comp_arr_dom ide_in_hom(2) in_homE w\<^sub>\<tau>)
qed
ultimately have "\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> = ?w\<^sub>\<tau>"
by simp
thus "ide (\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
using w\<^sub>\<tau> by simp
have "\<guillemotleft>\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright>"
using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' by auto
moreover have "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = t\<^sub>1 \<star> ?w\<^sub>\<tau>'"
by (metis \<beta>\<^sub>\<tau> \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' \<tau>.ide_leg1 calculation comp_arr_inv' in_homE iso_\<beta>\<^sub>\<tau> whisker_left)
moreover have "?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
proof -
have "?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
using \<gamma>\<^sub>\<tau>' by simp
also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>) \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
using \<gamma>\<^sub>\<tau> comp_assoc by simp
also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left
by (metis (full_types) \<tau>.ide_leg0 seqI')
finally show ?thesis by simp
qed
moreover have "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)
\<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>'"
proof -
have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> ?w\<^sub>\<tau>' = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)"
proof -
have "(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') =
((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> (t\<^sub>1 \<star> ?w\<^sub>\<tau>')"
proof -
have 1: "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>')"
by (meson \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' \<tau>.ide_leg1 seqI' whisker_left)
have "((LHS \<cdot> inv ?\<beta>\<^sub>\<tau>) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>)) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>') = LHS \<cdot> inv ?\<beta>\<^sub>\<tau>"
- using LHS_def RHS_def \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' eq eq' by presburger
+ using LHS_def RHS_def \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' eq eq' by argo
thus ?thesis
unfolding LHS_def
using 1 by (simp add: calculation(2) eq' comp_assoc)
qed
thus ?thesis
using w\<^sub>\<tau>' \<theta>\<^sub>\<tau>' \<omega>.w_simps(4) \<tau>.leg1_in_hom(2) \<tau>.leg1_simps(3) hcomp_in_vhom ideD(1)
trg_hcomp' ide_in_hom(2) \<tau>.T2 \<tau>.T0.antipar(1) t\<^sub>0u\<^sub>1.base_simps(2)
t\<^sub>0u\<^sub>1.leg1_simps(4)
by presburger
qed
thus "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)
\<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>'"
by (metis \<theta>\<^sub>\<tau>' comp_arr_dom ide_in_hom(2) in_homE w\<^sub>\<tau>')
qed
ultimately have "\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = ?w\<^sub>\<tau>'"
by simp
thus "ide (\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
using w\<^sub>\<tau>' by simp
qed
thus "\<tau>\<mu>.p\<^sub>1 \<star> chine \<cong> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
using w\<^sub>\<tau> w\<^sub>\<tau>' \<gamma>\<^sub>\<tau> isomorphic_symmetric isomorphic_def by blast
have iso_\<gamma>\<^sub>\<tau>: "iso \<gamma>\<^sub>\<tau>"
using \<open>inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'\<close> by auto
have \<gamma>\<^sub>\<tau>'_eq: "\<gamma>\<^sub>\<tau>' = inv \<gamma>\<^sub>\<tau>"
using \<open>inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'\<close> inverse_unique by blast
let ?w\<^sub>\<mu> = "\<tau>\<mu>.p\<^sub>0 \<star> chine"
let ?w\<^sub>\<mu>' = "\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
let ?u\<^sub>\<mu> = "s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
let ?\<theta>\<^sub>\<mu> = "the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"
let ?\<theta>\<^sub>\<mu>' = "(\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
let ?\<beta>\<^sub>\<mu> = "\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot> (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot>
(inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
have w\<^sub>\<mu>: "ide ?w\<^sub>\<mu> \<and> is_left_adjoint ?w\<^sub>\<mu>"
using is_map left_adjoints_compose by simp
have w\<^sub>\<mu>': "ide ?w\<^sub>\<mu>' \<and> is_left_adjoint ?w\<^sub>\<mu>'"
using \<chi>.is_map left_adjoints_compose
by (simp add: is_map left_adjoints_compose)
have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>)"
proof -
have \<theta>\<^sub>\<mu>: "\<guillemotleft>?\<theta>\<^sub>\<mu> : u\<^sub>0 \<star> ?w\<^sub>\<mu> \<Rightarrow> ?u\<^sub>\<mu>\<guillemotright>"
by auto
have \<theta>\<^sub>\<mu>': "\<guillemotleft>?\<theta>\<^sub>\<mu>' : u\<^sub>0 \<star> ?w\<^sub>\<mu>' \<Rightarrow> ?u\<^sub>\<mu>\<guillemotright>"
by fastforce
have \<beta>\<^sub>\<mu>: "\<guillemotleft>?\<beta>\<^sub>\<mu> : u\<^sub>1 \<star> ?w\<^sub>\<mu> \<Rightarrow> u\<^sub>1 \<star> ?w\<^sub>\<mu>'\<guillemotright>"
proof (intro comp_in_homI)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] : u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0 \<star> chine \<Rightarrow> (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
by auto
show "\<guillemotleft>inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine : (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
using t\<^sub>0u\<^sub>1.\<phi>_in_hom(2) t\<^sub>0u\<^sub>1.\<phi>_uniqueness(2) by auto
show "\<guillemotleft>\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] : (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine\<guillemotright>"
using \<tau>.T0.antipar(1) by auto
show "\<guillemotleft>t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau> : t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine \<Rightarrow> t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
using \<gamma>\<^sub>\<tau> iso_\<gamma>\<^sub>\<tau> using \<tau>.T0.antipar(1) by auto
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] : t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
using \<rho>.T0.antipar(1) by auto
show "\<guillemotleft>\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1 : (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
using \<rho>.T0.antipar(1) by auto
show "\<guillemotleft>r\<^sub>0s\<^sub>1.\<phi> : r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
by auto
show "\<guillemotleft>\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0 : s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
by auto
show "\<guillemotleft>\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] : (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
by auto
qed
text \<open>
The proof of the equation below needs to make use of the equation
\<open>\<theta>\<^sub>\<tau>' = \<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')\<close> from the previous section. So the overall strategy is to
work toward an expression of the form \<open>\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')\<close> and perform the replacement
to eliminate \<open>\<gamma>\<^sub>\<tau>'\<close>.
\<close>
have eq\<^sub>\<mu>: "(u \<star> ?\<theta>\<^sub>\<mu>) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>) =
((u \<star> ?\<theta>\<^sub>\<mu>') \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>'] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>')) \<cdot> ?\<beta>\<^sub>\<mu>"
proof -
let ?LHS = "(u \<star> ?\<theta>\<^sub>\<mu>) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
let ?RHS = "((u \<star> ?\<theta>\<^sub>\<mu>') \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>'] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>')) \<cdot> ?\<beta>\<^sub>\<mu>"
have "?RHS = (u \<star> (\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
\<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
\<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0]) \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "u \<star> (\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] =
(u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])"
using whisker_left \<mu>.ide_base \<theta>\<^sub>\<mu>' by blast
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
(\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "seq (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])
(\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0))"
using hseqI'
by (intro seqI hseqI, auto)
moreover have "src u = trg \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
by simp
moreover have "inv (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) = u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
using hseqI' by simp
moreover have "iso (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])"
by simp
moreover have "iso \<a>[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
by simp
ultimately have "(u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0] =
\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
using pentagon hseqI' comp_assoc
invert_opposite_sides_of_square
[of "u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
"\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0)"
"\<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0]" "\<a>[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"]
inv_hcomp \<chi>.is_ide \<chi>.w_simps(3) \<chi>.w_simps(4) \<mu>.base_simps(2) \<mu>.ide_base
\<mu>.ide_leg0 \<mu>.leg0_simps(2) \<mu>.leg0_simps(3) \<sigma>.leg1_simps(3)
assoc'_eq_inv_assoc ide_hcomp r\<^sub>0s\<^sub>1.ide_u r\<^sub>0s\<^sub>1.p\<^sub>0_simps hcomp_simps(1)
by presburger
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
(\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "(u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] =
\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0)"
using assoc_naturality [of u \<chi>.the_\<theta> \<rho>\<sigma>.p\<^sub>0] \<chi>.\<theta>_simps(3) by auto
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
(\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) =
((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
using assoc'_naturality [of \<mu> \<chi>.chine \<rho>\<sigma>.p\<^sub>0] by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
((\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
(\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using comp_assoc by metis
also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
(\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "(\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0"
using comp_inv_arr' comp_cod_arr hseqI' by auto
thus ?thesis
using comp_assoc by simp
qed
also have "... = (\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
(\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "arr ((u \<star> \<chi>.the_\<theta>) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine] \<cdot> (\<mu> \<star> \<chi>.chine) \<cdot> \<chi>.the_\<nu>)"
using hseqI' \<chi>.\<theta>_simps(3)
by (intro seqI hseqI, auto)
hence "((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
(u \<star> \<chi>.the_\<theta>) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine] \<cdot> (\<mu> \<star> \<chi>.chine) \<cdot> \<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0"
using whisker_right hseqI' by simp
also have "... = (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0"
using \<chi>.\<Delta>_naturality by simp
finally have "((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
(\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>)) \<cdot>
\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using \<gamma>\<^sub>\<tau>' \<gamma>\<^sub>\<tau>'_eq by simp
also have "... = (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
(inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using comp_assoc by presburger
also have "... = (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
(inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] =
\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
proof -
have "((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
(inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] =
((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot>
(inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using comp_inv_arr' hseqI' \<tau>.T0.antipar(1) by auto
also have "... = ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using comp_cod_arr hseqI' t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
also have "... = (t\<^sub>0u\<^sub>1.\<phi> \<cdot> inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using whisker_right t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
also have "... = ((u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using comp_arr_inv' \<tau>.T0.antipar(1) hseqI' t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
also have "... = \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
using comp_cod_arr \<tau>.T0.antipar(1) hseqI' by simp
finally show ?thesis by simp
qed
thus ?thesis
using comp_assoc by simp
qed
also have "... = (u \<star> the_\<theta>) \<cdot> (\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
using assoc'_naturality [of \<mu> \<tau>\<mu>.p\<^sub>0 chine] comp_assoc by auto
also have "... = ((u \<star> the_\<theta>) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine])) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
using uw\<theta> pentagon comp_assoc inv_hcomp
invert_opposite_sides_of_square
[of "u \<star> \<a>[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"
"\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine)" "\<a>[u, u\<^sub>0, ?w\<^sub>\<mu>]"
"\<a>[u \<star> u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"]
\<mu>.base_simps(2) \<mu>.ide_base \<mu>.ide_leg0 \<mu>.leg0_simps(2) assoc'_eq_inv_assoc
ide_hcomp hseqI' hcomp_simps(1) t\<^sub>0u\<^sub>1.ide_u
by force
also have "... = (u \<star> the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
using whisker_left comp_assoc by simp
finally show ?thesis by simp
qed
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>)"
using w\<^sub>\<mu> w\<^sub>\<mu>' \<theta>\<^sub>\<mu> \<theta>\<^sub>\<mu>' \<beta>\<^sub>\<mu> eq\<^sub>\<mu> \<mu>.T2 [of ?w\<^sub>\<mu> ?w\<^sub>\<mu>' ?\<theta>\<^sub>\<mu> ?u\<^sub>\<mu> ?\<theta>\<^sub>\<mu>' ?\<beta>\<^sub>\<mu>] by fast
qed
obtain \<gamma>\<^sub>\<mu> where \<gamma>\<^sub>\<mu>: "\<guillemotleft>\<gamma>\<^sub>\<mu> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma>\<^sub>\<mu> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>\<^sub>\<mu>)"
using 1 by auto
show "?w\<^sub>\<mu> \<cong> ?w\<^sub>\<mu>'"
using w\<^sub>\<mu> w\<^sub>\<mu>' \<gamma>\<^sub>\<mu> BS3 [of ?w\<^sub>\<mu> ?w\<^sub>\<mu>' \<gamma>\<^sub>\<mu> \<gamma>\<^sub>\<mu>] isomorphic_def by auto
qed
lemma comp_L:
shows "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
and "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> =
- MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
+ Maps.MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
proof -
show "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)"
using \<omega>.is_map r\<^sub>0s\<^sub>1.leg1_is_map left_adjoints_compose r\<^sub>0s\<^sub>1.p\<^sub>1_simps by auto
thus ?thesis
using Maps.CLS_in_hom r\<^sub>0s\<^sub>1.leg1_is_map
apply (intro Maps.seqI')
apply blast
using Maps.CLS_in_hom [of t\<^sub>0] \<tau>.leg0_is_map \<rho>\<sigma>.leg1_in_hom by auto
qed
thus "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> =
- MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
+ Maps.MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
using Maps.comp_char by auto
qed
lemma comp_R:
shows "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
and "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> =
- MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
+ Maps.MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
proof -
show "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint (\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0)"
using \<chi>.is_map r\<^sub>0s\<^sub>1.leg0_is_map left_adjoints_compose [of \<chi>.chine \<rho>\<sigma>.p\<^sub>0] by simp
thus ?thesis
using Maps.CLS_in_hom \<mu>.leg1_is_map
apply (intro Maps.seqI')
apply blast
using Maps.CLS_in_hom [of u\<^sub>1] \<mu>.leg1_is_map by simp
qed
thus "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> =
- MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
+ Maps.MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
using Maps.comp_char by auto
qed
lemma comp_L_eq_comp_R:
shows "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
proof (intro Maps.arr_eqI)
show "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
using comp_L(1) by simp
show "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using comp_R(1) by simp
show "Maps.Dom (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Dom (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
by (metis (no_types, lifting) Maps.Dom.simps(1) \<omega>.w_simps(2) \<omega>.w_simps(3)
\<rho>.leg1_simps(3) \<rho>\<sigma>.leg1_in_hom(2) comp_L(2) comp_R(2) hcomp_in_vhomE hseqI'
r\<^sub>0s\<^sub>1.leg1_simps(3) hcomp_simps(1))
show "Maps.Cod (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Cod (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
by (metis Maps.Cod.simps(1) \<tau>\<mu>.composable comp_L(2) comp_R(2))
have A: "Maps.Map (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
using comp_L(1) Maps.comp_char by auto
have B: "Maps.Map (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>) = Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
using comp_R(1) Maps.comp_char by auto
have C: "Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk> = Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
proof (intro Maps.Comp_eqI)
show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<in> Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
proof (intro Maps.in_CompI)
show "is_iso_class \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
using prj_chine(2) is_iso_classI isomorphic_implies_hpar(2) by blast
show "is_iso_class \<lbrakk>t\<^sub>0\<rbrakk>"
using is_iso_classI by auto
show "\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<in> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
using ide_in_iso_class prj_chine(2) isomorphic_implies_hpar(2) by blast
show "t\<^sub>0 \<in> \<lbrakk>t\<^sub>0\<rbrakk>"
using ide_in_iso_class by simp
show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
using isomorphic_reflexive prj_chine(2) isomorphic_implies_hpar(2) by auto
qed
show "u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<in> Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
proof (intro Maps.in_CompI)
show "is_iso_class \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
using is_iso_classI by simp
show "is_iso_class \<lbrakk>u\<^sub>1\<rbrakk>"
using is_iso_classI by simp
show "\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<in> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
using ide_in_iso_class by simp
show "u\<^sub>1 \<in> iso_class u\<^sub>1"
using ide_in_iso_class by simp
show "u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
using isomorphic_reflexive isomorphic_implies_hpar(2) by auto
qed
show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
proof -
have "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1"
using assoc'_in_hom [of t\<^sub>0 \<omega>.chine \<rho>\<sigma>.p\<^sub>1] iso_assoc' isomorphic_def r\<^sub>0s\<^sub>1.p\<^sub>1_simps
by auto
also have "... \<cong> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1"
using \<omega>.leg0_uniquely_isomorphic hcomp_isomorphic_ide
by (simp add: \<rho>.T0.antipar(1))
also have "... \<cong> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0"
using isomorphic_def r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) by blast
also have "... \<cong> (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0"
using \<chi>.leg1_uniquely_isomorphic hcomp_isomorphic_ide by auto
also have "... \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
using assoc_in_hom [of u\<^sub>1 \<chi>.chine \<rho>\<sigma>.p\<^sub>0] iso_assoc isomorphic_def by auto
finally show ?thesis by simp
qed
qed
show "Maps.Map (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Map (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
using A B C by simp
qed
lemma csq:
shows "Maps.commutative_square \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
proof
show "Maps.cospan \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>"
using comp_L(1) comp_R(1) comp_L_eq_comp_R
by (metis (no_types, lifting) Maps.cod_comp Maps.seq_char)
show "Maps.span \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using comp_L(1) comp_R(1) comp_L_eq_comp_R
by (metis (no_types, lifting) Maps.dom_comp Maps.seq_char)
show "Maps.dom \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> = Maps.cod \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
using comp_L(1) by auto
show "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using comp_L_eq_comp_R by simp
qed
lemma CLS_chine:
shows "\<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = Maps.tuple \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
proof -
let ?T = "Maps.tuple \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
have "\<exists>!l. \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> l = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and> \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> l = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using csq \<tau>\<mu>.prj_char
Maps.universal [of "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"]
by simp
moreover have "\<lbrakk>\<lbrakk>\<tau>\<mu>.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> ?T = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and>
\<lbrakk>\<lbrakk>\<tau>\<mu>.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> ?T = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using csq \<tau>\<mu>.prj_char
Maps.prj_tuple [of "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"]
by simp
moreover have "\<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and>
\<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using prj_chine \<tau>\<mu>.leg0_is_map \<tau>\<mu>.leg1_is_map is_map t\<^sub>0u\<^sub>1.leg1_is_map
t\<^sub>0u\<^sub>1.satisfies_T0 Maps.comp_CLS
by blast
ultimately show "\<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = ?T" by auto
qed
end
subsection "Equivalence of B and Span(Maps(B))"
subsubsection "The Functor SPN"
text \<open>
We now define a function \<open>SPN\<close> on arrows and will ultimately show that it extends to a
biequivalence from the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>.
The idea is that \<open>SPN\<close> takes \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close> to the isomorphism class of an induced arrow
of spans from the chosen tabulation of \<open>r\<close> to the chosen tabulation of \<open>s\<close>.
To obtain this, we first use isomorphisms \<open>r.tab\<^sub>1 \<star> r.tab\<^sub>0\<^sup>* \<cong> r\<close> and \<open>s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>* \<cong> s\<close>
to transform \<open>\<mu>\<close> to \<open>\<guillemotleft>\<mu>' : r.tab\<^sub>1 \<star> r.tab\<^sub>0\<^sup>* \<Rightarrow> s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>*\<guillemotright>\<close>.
We then take the adjoint transpose of \<open>\<mu>'\<close> to obtain
\<open>\<guillemotleft>\<omega> : r.tab\<^sub>1 \<Rightarrow> (s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>*) \<star> r.tab\<^sub>0\<guillemotright>\<close>. The 2-cell \<open>\<omega>\<close> induces a map \<open>w\<close>
which is an arrow of spans from \<open>(r.tab\<^sub>0, r.tab\<^sub>1)\<close> to \<open>(s.tab\<^sub>0, s.tab\<^sub>1)\<close>.
We take the arrow of \<open>Span(Maps(B))\<close> defined by \<open>w\<close> as the value of \<open>SPN \<mu>\<close>.
Ensuring that \<open>SPN\<close> is functorial is a somewhat delicate point, which requires that all
the underlying definitions that have been set up are ``just so'', with no extra choices
other than those that are forced, and with the tabulation assigned to each 1-cell \<open>r\<close> in
the proper relationship with the canonical tabulation assigned to its chosen factorization
\<open>r = g \<star> f\<^sup>*\<close>.
\<close>
context bicategory_of_spans
begin
interpretation Maps: maps_category V H \<a> \<i> src trg ..
interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
no_notation Fun.comp (infixl "\<circ>" 55)
notation Span.vcomp (infixr "\<bullet>" 55)
notation Span.hcomp (infixr "\<circ>" 53)
notation Maps.comp (infixr "\<odot>" 55)
notation isomorphic (infix "\<cong>" 50)
definition spn
where "spn \<mu> \<equiv>
arrow_of_tabulations_in_maps.chine V H \<a> \<i> src trg
(tab_of_ide (dom \<mu>)) (tab\<^sub>0 (dom \<mu>)) (cod \<mu>)
(tab_of_ide (cod \<mu>)) (tab\<^sub>0 (cod \<mu>)) (tab\<^sub>1 (cod \<mu>)) \<mu>"
lemma is_induced_map_spn:
assumes "arr \<mu>"
shows "arrow_of_tabulations_in_maps.is_induced_map V H \<a> \<i> src trg
(tab_of_ide (dom \<mu>)) (tab\<^sub>0 (dom \<mu>)) (cod \<mu>)
(tab_of_ide (cod \<mu>)) (tab\<^sub>0 (cod \<mu>)) (tab\<^sub>1 (cod \<mu>))
\<mu> (spn \<mu>)"
proof -
interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
using assms by (unfold_locales, auto)
interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
\<open>cod \<mu>\<close> \<mu>.s.tab \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
\<mu>
using \<mu>.is_arrow_of_tabulations_in_maps by simp
show ?thesis
unfolding spn_def
using \<mu>.chine_is_induced_map by blast
qed
lemma spn_props:
assumes "arr \<mu>"
shows "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
and "is_left_adjoint (spn \<mu>)"
and "tab\<^sub>0 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>0 (dom \<mu>)"
and "tab\<^sub>1 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>1 (dom \<mu>)"
proof -
interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
using assms by (unfold_locales, auto)
interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
\<open>cod \<mu>\<close> \<mu>.s.tab \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
\<mu>
using \<mu>.is_arrow_of_tabulations_in_maps by simp
show "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
using spn_def by simp
show "is_left_adjoint (spn \<mu>)"
using spn_def by (simp add: \<mu>.is_map)
show "tab\<^sub>0 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>0 (dom \<mu>)"
using spn_def isomorphic_def \<mu>.leg0_uniquely_isomorphic(1) by auto
show "tab\<^sub>1 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>1 (dom \<mu>)"
using spn_def isomorphic_def isomorphic_symmetric
\<mu>.leg1_uniquely_isomorphic(1)
by auto
qed
lemma spn_in_hom [intro]:
assumes "arr \<mu>"
shows "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
and "\<guillemotleft>spn \<mu> : spn \<mu> \<Rightarrow> spn \<mu>\<guillemotright>"
using assms spn_props left_adjoint_is_ide by auto
lemma spn_simps [simp]:
assumes "arr \<mu>"
shows "is_left_adjoint (spn \<mu>)"
and "ide (spn \<mu>)"
and "src (spn \<mu>) = src (tab\<^sub>0 (dom \<mu>))"
and "trg (spn \<mu>) = src (tab\<^sub>0 (cod \<mu>))"
using assms spn_props left_adjoint_is_ide by auto
text \<open>
We need the next result to show that \<open>SPN\<close> is functorial; in particular,
that it takes \<open>\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>\<close> in the underlying bicategory to a 1-cell
in \<open>Span(Maps(B))\<close>. The 1-cells in \<open>Span(Maps(B))\<close> have objects of \<open>Maps(B)\<close>
as their chines, and objects of \<open>Maps(B)\<close> are isomorphism classes of objects in the
underlying bicategory \<open>B\<close>. So we need the induced map associated with \<open>r\<close> to be isomorphic
to an object.
\<close>
lemma spn_ide:
assumes "ide r"
shows "spn r \<cong> src (tab\<^sub>0 r)"
proof -
interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r
using assms by (unfold_locales, auto)
interpret r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> r
using r.is_arrow_of_tabulations_in_maps by simp
interpret tab: tabulation V H \<a> \<i> src trg r \<open>r.tab\<close> \<open>tab\<^sub>0 r\<close> \<open>dom r.tab\<close>
using assms r.tab_is_tabulation by simp
interpret tab: tabulation_in_maps V H \<a> \<i> src trg r \<open>r.tab\<close> \<open>tab\<^sub>0 r\<close> \<open>dom r.tab\<close>
by (unfold_locales, simp_all)
have "tab.is_induced_by_cell (spn r) (tab\<^sub>0 r) r.tab"
using spn_def comp_ide_arr r.chine_is_induced_map by auto
thus ?thesis
using tab.induced_map_unique [of "tab\<^sub>0 r" "r.tab" "spn r" "src r.s\<^sub>0"]
tab.apex_is_induced_by_cell
by (simp add: comp_assoc)
qed
text \<open>
The other key result we need to show that \<open>SPN\<close> is functorial is to show
that the induced map of a composite is isomorphic to the composite of
induced maps.
\<close>
lemma spn_hcomp:
assumes "seq \<tau> \<mu>" and "g \<cong> spn \<tau>" and "f \<cong> spn \<mu>"
shows "spn (\<tau> \<cdot> \<mu>) \<cong> g \<star> f"
proof -
interpret \<tau>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<tau>\<close> \<open>cod \<tau>\<close> \<tau>
using assms by (unfold_locales, auto)
interpret \<tau>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
\<open>cod \<tau>\<close> \<tau>.s.tab \<open>tab\<^sub>0 (cod \<tau>)\<close> \<open>tab\<^sub>1 (cod \<tau>)\<close>
\<tau>
using \<tau>.is_arrow_of_tabulations_in_maps by simp
interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>dom \<tau>\<close> \<mu>
using assms apply unfold_locales
apply auto[1]
by (elim seqE, auto)
interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
\<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
\<mu>
using \<mu>.is_arrow_of_tabulations_in_maps by simp
interpret \<tau>\<mu>: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
\<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
\<open>cod \<tau>\<close> \<tau>.s.tab \<open>tab\<^sub>0 (cod \<tau>)\<close> \<open>tab\<^sub>1 (cod \<tau>)\<close>
\<mu> \<tau>
..
have "g \<cong> \<tau>.chine"
using assms(2) spn_def by auto
moreover have "f \<cong> \<mu>.chine"
using assms(1) assms(3) spn_def by auto
moreover have "src g = trg f"
using calculation(1-2) isomorphic_implies_hpar(3-4) by auto
moreover have "src g = trg \<mu>.chine"
using calculation(1) isomorphic_implies_hpar(3) by auto
ultimately have "g \<star> f \<cong> \<tau>.chine \<star> \<mu>.chine"
using hcomp_ide_isomorphic hcomp_isomorphic_ide isomorphic_transitive
by (meson \<mu>.is_ide isomorphic_implies_ide(1))
also have "... \<cong> spn (\<tau> \<cdot> \<mu>)"
using spn_def \<tau>\<mu>.chine_char isomorphic_symmetric
by (metis \<tau>\<mu>.in_hom in_homE)
finally show ?thesis
using isomorphic_symmetric by simp
qed
abbreviation (input) SPN\<^sub>0
where "SPN\<^sub>0 r \<equiv> Span.mkIde \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
definition SPN
where "SPN \<mu> \<equiv> if arr \<mu> then
\<lparr>Chn = \<lbrakk>\<lbrakk>spn \<mu>\<rbrakk>\<rbrakk>,
Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>,
Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<rparr>
else Span.null"
lemma Dom_SPN [simp]:
assumes "arr \<mu>"
shows "Dom (SPN \<mu>) = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>"
using assms SPN_def by simp
lemma Cod_SPN [simp]:
assumes "arr \<mu>"
shows "Cod (SPN \<mu>) = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>"
using assms SPN_def by simp
text \<open>Now we have to show this does the right thing for us.\<close>
lemma SPN_in_hom:
assumes "arr \<mu>"
shows "Span.in_hom (SPN \<mu>) (SPN\<^sub>0 (dom \<mu>)) (SPN\<^sub>0 (cod \<mu>))"
proof
interpret Dom: span_in_category Maps.comp \<open>Dom (SPN \<mu>)\<close>
proof
interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close>
using assms by (unfold_locales, auto)
show "Maps.span (Leg0 (Dom (SPN \<mu>))) (Leg1 (Dom (SPN \<mu>)))"
using assms Maps.CLS_in_hom SPN_def
by (metis (no_types, lifting) Maps.in_homE bicategory_of_spans.Dom_SPN
bicategory_of_spans_axioms r.leg1_is_map r.leg1_simps(3) r.satisfies_T0
span_data.simps(1) span_data.simps(2))
qed
interpret Dom': span_in_category Maps.comp
\<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<close>
using assms Dom.span_in_category_axioms SPN_def by simp
- interpret Cod: span_in_category Maps.comp "Cod (SPN \<mu>)"
+ interpret Cod: span_in_category Maps.comp \<open>Cod (SPN \<mu>)\<close>
proof
interpret s: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod \<mu>\<close>
using assms by (unfold_locales, auto)
show "Maps.span (Leg0 (Cod (SPN \<mu>))) (Leg1 (Cod (SPN \<mu>)))"
using assms Maps.CLS_in_hom SPN_def
by (metis (no_types, lifting) bicategory_of_spans.Cod_SPN bicategory_of_spans_axioms
ide_dom s.base_simps(2) s.base_simps(3) s.determines_span span_in_category.is_span)
qed
interpret Cod': span_in_category Maps.comp
\<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<close>
using assms Cod.span_in_category_axioms SPN_def by simp
show 1: "Span.arr (SPN \<mu>)"
proof (unfold Span.arr_char)
show "arrow_of_spans Maps.comp (SPN \<mu>)"
proof (unfold_locales)
show "Maps.in_hom (Chn (SPN \<mu>)) Dom.apex Cod.apex"
unfolding SPN_def Maps.in_hom_char
using assms Dom'.apex_def Cod'.apex_def Dom'.is_span Cod'.is_span Maps.arr_char
by auto
show "Cod.leg0 \<odot> Chn (SPN \<mu>) = Dom.leg0"
unfolding SPN_def
using assms spn_props [of \<mu>] Maps.comp_CLS [of "tab\<^sub>0 (cod \<mu>)" "spn \<mu>"] by simp
show "Cod.leg1 \<odot> Chn (SPN \<mu>) = Dom.leg1"
unfolding SPN_def
using assms spn_props [of \<mu>] Maps.comp_CLS [of "tab\<^sub>1 (cod \<mu>)" "spn \<mu>"] by simp
qed
qed
show "Span.dom (SPN \<mu>) = SPN\<^sub>0 (dom \<mu>)"
using assms 1 Span.dom_char Dom'.apex_def SPN_def by simp
show "Span.cod (SPN \<mu>) = SPN\<^sub>0 (cod \<mu>)"
using assms 1 Span.cod_char Cod'.apex_def SPN_def by simp
qed
interpretation SPN: "functor" V Span.vcomp SPN
proof
show "\<And>\<mu>. \<not> arr \<mu> \<Longrightarrow> SPN \<mu> = Span.null"
unfolding SPN_def by simp
show 1: "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.arr (SPN \<mu>)"
using SPN_in_hom by auto
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.dom (SPN \<mu>) = SPN (dom \<mu>)"
proof -
fix \<mu>
assume \<mu>: "arr \<mu>"
- have 1: "Maps.arr (MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>)"
+ have 1: "Maps.arr (Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>)"
proof -
have "src (tab\<^sub>0 (dom \<mu>)) \<in> Collect obj"
using \<mu> by simp
moreover have "src \<mu> \<in> Collect obj"
using \<mu> by simp
moreover have "\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (local.dom \<mu>))) (src \<mu>)"
proof -
have "\<guillemotleft>tab\<^sub>0 (dom \<mu>) : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src \<mu>\<guillemotright>"
using \<mu> by simp
moreover have "is_left_adjoint (tab\<^sub>0 (dom \<mu>))"
using \<mu> tab\<^sub>0_simps [of "dom \<mu>"] by auto
ultimately show ?thesis by auto
qed
ultimately show ?thesis by simp
qed
have "\<lbrakk>spn (dom \<mu>)\<rbrakk> = \<lbrakk>src (tab\<^sub>0 (dom \<mu>))\<rbrakk>"
using \<mu> spn_ide iso_class_eqI by auto
hence "SPN (dom \<mu>) = SPN\<^sub>0 (dom \<mu>)"
unfolding SPN_def
using \<mu> 1 Maps.dom_char by simp
thus "Span.dom (SPN \<mu>) = SPN (dom \<mu>)"
using \<mu> SPN_in_hom by auto
qed
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.cod (SPN \<mu>) = SPN (cod \<mu>)"
proof -
fix \<mu>
assume \<mu>: "arr \<mu>"
- have 1: "Maps.arr (MkArr (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>)"
+ have 1: "Maps.arr (Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>)"
proof -
have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
using \<mu> by simp
moreover have "src \<mu> \<in> Collect obj"
using \<mu> by simp
moreover have "\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>)"
proof -
have "\<guillemotleft>tab\<^sub>0 (cod \<mu>) : src (tab\<^sub>0 (cod \<mu>)) \<rightarrow> src \<mu>\<guillemotright>"
using \<mu> by simp
moreover have "is_left_adjoint (tab\<^sub>0 (cod \<mu>))"
using \<mu> by simp
ultimately show ?thesis by auto
qed
ultimately show ?thesis by simp
qed
have "\<lbrakk>spn (cod \<mu>)\<rbrakk> = \<lbrakk>src (tab\<^sub>0 (cod \<mu>))\<rbrakk>"
using \<mu> spn_ide iso_class_eqI by auto
hence "SPN (cod \<mu>) = SPN\<^sub>0 (cod \<mu>)"
unfolding SPN_def
using \<mu> 1 Maps.dom_char by simp
thus "Span.cod (SPN \<mu>) = SPN (cod \<mu>)"
using \<mu> SPN_in_hom by auto
qed
show "\<And>\<nu> \<mu>. seq \<nu> \<mu> \<Longrightarrow> SPN (\<nu> \<cdot> \<mu>) = SPN \<nu> \<bullet> SPN \<mu>"
proof -
fix \<mu> \<nu>
assume seq: "seq \<nu> \<mu>"
have "Dom (SPN (\<nu> \<cdot> \<mu>)) = Dom (SPN \<nu> \<bullet> SPN \<mu>)"
using seq 1 Span.vcomp_def Span.arr_char
by (elim seqE, simp)
moreover have "Cod (SPN (\<nu> \<cdot> \<mu>)) = Cod (SPN \<nu> \<bullet> SPN \<mu>)"
using seq 1 Span.vcomp_def Span.arr_char
by (elim seqE, simp)
moreover have "Chn (SPN (\<nu> \<cdot> \<mu>)) = Chn (SPN \<nu> \<bullet> SPN \<mu>)"
proof -
have *: "\<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk> = Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
proof
show "\<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk> \<subseteq> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
proof
fix h
assume h: "h \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
show "h \<in> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
proof -
have 1: "spn \<nu> \<in> \<lbrakk>spn \<nu>\<rbrakk>"
using seq ide_in_iso_class by auto
moreover have 2: "spn \<mu> \<in> \<lbrakk>spn \<mu>\<rbrakk>"
using seq ide_in_iso_class by auto
moreover have "spn \<nu> \<star> spn \<mu> \<cong> h"
proof -
have "spn \<nu> \<star> spn \<mu> \<cong> spn (\<nu> \<cdot> \<mu>)"
using seq spn_hcomp 1 2 iso_class_def isomorphic_reflexive
isomorphic_symmetric
by simp
thus ?thesis
using h isomorphic_transitive iso_class_def by simp
qed
ultimately show ?thesis
unfolding Maps.Comp_def
by (metis (mono_tags, lifting) is_iso_classI spn_simps(2)
mem_Collect_eq seq seqE)
qed
qed
show "Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk> \<subseteq> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
proof
fix h
assume h: "h \<in> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
show "h \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
proof -
obtain f g where 1: "g \<in> \<lbrakk>spn \<nu>\<rbrakk> \<and> f \<in> \<lbrakk>spn \<mu>\<rbrakk> \<and> g \<star> f \<cong> h"
using h Maps.Comp_def [of "iso_class (spn \<nu>)" "iso_class (spn \<mu>)"]
iso_class_def iso_class_elems_isomorphic
by blast
have fg: "g \<cong> spn \<nu> \<and> f \<cong> spn \<mu> \<and> g \<star> f \<cong> h"
proof -
have "spn \<nu> \<in> \<lbrakk>spn \<nu>\<rbrakk> \<and> spn \<mu> \<in> \<lbrakk>spn \<mu>\<rbrakk>"
using seq ide_in_iso_class by auto
thus ?thesis
using 1 iso_class_elems_isomorphic isomorphic_symmetric is_iso_classI
by (meson spn_simps(2) seq seqE)
qed
have "g \<star> f \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
using seq fg 1 spn_hcomp iso_class_def isomorphic_symmetric by simp
thus ?thesis
using fg isomorphic_transitive iso_class_def by blast
qed
qed
qed
have "Chn (SPN \<nu> \<bullet> SPN \<mu>) =
- MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk> \<odot>
- MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"
+ Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk> \<odot>
+ Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"
using 1 seq SPN_def Span.vcomp_def Span.arr_char
apply (elim seqE)
apply simp
by (metis (no_types, lifting) seq vseq_implies_hpar(1) vseq_implies_hpar(2))
- also have "... = MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))
- (Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>)"
- proof -
- have "Maps.seq (MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
- (MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)"
+ also have "... = Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))
+ (Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>)"
+ proof -
+ have "Maps.seq (Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
+ (Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)"
proof
- show "Maps.in_hom (MkArr (src (tab\<^sub>0 (local.dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)
+ show "Maps.in_hom (Maps.MkArr (src (tab\<^sub>0 (local.dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)
(Maps.MkIde (src (tab\<^sub>0 (dom \<mu>))))
(Maps.MkIde (src (tab\<^sub>0 (cod \<mu>))))"
proof -
have "src (tab\<^sub>0 (dom \<mu>)) \<in> Collect obj"
using in_hhom_def seq by auto
moreover have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
using seq by auto
moreover have "\<lbrakk>spn \<mu>\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>)))"
using spn_props
by (metis (mono_tags, lifting) mem_Collect_eq seq seqE)
ultimately show ?thesis
using Maps.MkArr_in_hom by simp
qed
- show "Maps.in_hom (MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
+ show "Maps.in_hom (Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
(Maps.MkIde (src (tab\<^sub>0 (cod \<mu>))))
(Maps.MkIde (src (tab\<^sub>0 (cod \<nu>))))"
proof -
have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
using in_hhom_def seq by auto
moreover have "src (tab\<^sub>0 (cod \<nu>)) \<in> Collect obj"
using seq by auto
moreover have "\<lbrakk>spn \<nu>\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))"
using spn_props
by (metis (mono_tags, lifting) mem_Collect_eq seq seqE)
ultimately show ?thesis
using Maps.MkArr_in_hom by simp
qed
qed
thus ?thesis
using Maps.comp_char
- [of "MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>"
- "MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"]
+ [of "Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>"
+ "Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"]
by simp
qed
- also have "... = MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
+ also have "... = Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
using * by simp
also have "... = Chn (SPN (\<nu> \<cdot> \<mu>))"
using seq SPN_def Span.vcomp_def
by (elim seqE, simp)
finally show ?thesis by simp
qed
ultimately show "SPN (\<nu> \<cdot> \<mu>) = SPN \<nu> \<bullet> SPN \<mu>" by simp
qed
qed
lemma SPN_is_functor:
shows "functor V Span.vcomp SPN"
..
interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
proof
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.isomorphic (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
proof -
fix \<mu>
assume \<mu>: "arr \<mu>"
let ?src = "Maps.MkIde (src \<mu>)"
have src: "Maps.ide ?src"
using \<mu> by simp
interpret src: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>src \<mu>\<close>
using \<mu> by (unfold_locales, auto)
interpret src: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>src \<mu>\<close> src.tab \<open>tab\<^sub>0 (src \<mu>)\<close> \<open>tab\<^sub>1 (src \<mu>)\<close>
\<open>src \<mu>\<close> src.tab \<open>tab\<^sub>0 (src \<mu>)\<close> \<open>tab\<^sub>1 (src \<mu>)\<close>
\<open>src \<mu>\<close>
using src.is_arrow_of_tabulations_in_maps by simp
interpret src: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>\<close>
using src by (unfold_locales, simp)
- let ?tab\<^sub>0 = "MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
+ let ?tab\<^sub>0 = "Maps.MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
have tab\<^sub>0_src: "\<guillemotleft>tab\<^sub>0 (src \<mu>) : src (tab\<^sub>0 (src \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
is_left_adjoint (tab\<^sub>0 (src \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
using \<mu> by simp
have tab\<^sub>0: "Maps.arr ?tab\<^sub>0"
using \<mu> Maps.arr_MkArr tab\<^sub>0_src by blast
- let ?tab\<^sub>1 = "MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
+ let ?tab\<^sub>1 = "Maps.MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
have tab\<^sub>1_src: "\<guillemotleft>tab\<^sub>1 (src \<mu>) : src (tab\<^sub>0 (src \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
is_left_adjoint (tab\<^sub>1 (src \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
using \<mu> by simp
have tab\<^sub>1: "Maps.arr ?tab\<^sub>1"
using \<mu> Maps.arr_MkArr tab\<^sub>1_src by blast
interpret tab: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<close>
using tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char by (unfold_locales, simp)
have "src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>0 (src \<mu>)"
using \<mu> iso_lunit isomorphic_def
by (metis lunit_in_hom(2) src.ide_u src.u_simps(3) src_src)
hence "src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>1 (src \<mu>)"
using \<mu> src.obj_has_symmetric_tab isomorphic_transitive by blast
have "\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)"
using \<mu> tab\<^sub>0_src by blast
have "\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)"
proof -
have "\<guillemotleft>src \<mu> : src \<mu> \<rightarrow> src \<mu>\<guillemotright> \<and> is_left_adjoint (src \<mu>) \<and> \<lbrakk>src \<mu>\<rbrakk> = \<lbrakk>src \<mu>\<rbrakk>"
using \<mu> obj_is_self_adjoint by simp
thus ?thesis by auto
qed
interpret SPN_src: arrow_of_spans Maps.comp \<open>SPN (src \<mu>)\<close>
using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
have SPN_src: "SPN (src \<mu>) =
- \<lparr>Chn = MkArr (src (tab\<^sub>0 (src \<mu>))) (src (tab\<^sub>0 (src \<mu>))) \<lbrakk>spn (src \<mu>)\<rbrakk>,
+ \<lparr>Chn = Maps.MkArr (src (tab\<^sub>0 (src \<mu>))) (src (tab\<^sub>0 (src \<mu>))) \<lbrakk>spn (src \<mu>)\<rbrakk>,
Dom = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<rparr>"
unfolding SPN_def using \<mu> by simp
interpret src_SPN: arrow_of_spans Maps.comp \<open>Span.src (SPN \<mu>)\<close>
using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
have src_SPN: "Span.src (SPN \<mu>) =
\<lparr>Chn = ?src,
Dom = \<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>,
Cod = \<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>\<rparr>"
proof -
- let ?tab\<^sub>0_dom = "MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
+ let ?tab\<^sub>0_dom = "Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
have "Maps.arr ?tab\<^sub>0_dom"
proof -
have "\<guillemotleft>tab\<^sub>0 (dom \<mu>) : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
is_left_adjoint (tab\<^sub>0 (dom \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
using \<mu> by simp
thus ?thesis
using \<mu> Maps.arr_MkArr by blast
qed
thus ?thesis
using \<mu> Maps.cod_char Span.src_def by simp
qed
text \<open>
The idea of the proof is that @{term "iso_class (tab\<^sub>0 (src \<mu>))"} is invertible
in \<open>Maps(B)\<close> and determines an invertible arrow of spans from @{term "SPN (src \<mu>)"}
to @{term "Span.src (SPN \<mu>)"}.
\<close>
let ?\<phi> = "\<lparr>Chn = ?tab\<^sub>0, Dom = Dom (SPN (src \<mu>)), Cod = Cod (Span.src (SPN \<mu>))\<rparr>"
interpret \<phi>: arrow_of_spans Maps.comp ?\<phi>
apply (unfold_locales, simp_all)
proof -
show "Maps.in_hom ?tab\<^sub>0 SPN_src.dom.apex src_SPN.cod.apex"
using \<mu> tab\<^sub>0 Maps.dom_char Maps.cod_char SPN_src src_SPN
tab.apex_def src_SPN.cod.apex_def
apply (intro Maps.in_homI) by simp_all
show "src_SPN.cod.leg0 \<odot> ?tab\<^sub>0 = SPN_src.dom.leg0"
proof -
have "Maps.seq src_SPN.cod.leg0 ?tab\<^sub>0"
using \<mu> src_SPN tab\<^sub>0 Maps.dom_char Maps.cod_char
by (intro Maps.seqI, auto)
moreover have "Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
proof -
have "tab\<^sub>0 (src \<mu>) \<in> Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
using \<mu> is_iso_classI ide_in_iso_class [of "src \<mu>"]
ide_in_iso_class [of "tab\<^sub>0 (src \<mu>)"] \<open>src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>0 (src \<mu>)\<close>
by auto
thus ?thesis
using Maps.Comp_eq_iso_class_memb
\<open>\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)\<close>
\<open>\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)\<close>
by meson
qed
ultimately show ?thesis
using \<mu> Maps.comp_char [of src_SPN.cod.leg0 ?tab\<^sub>0] src_SPN by simp
qed
show "src_SPN.cod.leg1 \<odot> ?tab\<^sub>0 = SPN_src.dom.leg1"
proof -
have "Maps.seq src_SPN.cod.leg1 ?tab\<^sub>0"
using \<mu> src_SPN tab\<^sub>0 Maps.dom_char Maps.cod_char
by (intro Maps.seqI, auto)
moreover have "Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
proof -
have "tab\<^sub>1 (src \<mu>) \<in> Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
using \<mu> is_iso_classI ide_in_iso_class [of "src \<mu>"]
ide_in_iso_class [of "tab\<^sub>0 (src \<mu>)"]
\<open>isomorphic (src \<mu> \<star> tab\<^sub>0 (src \<mu>)) (tab\<^sub>1 (src \<mu>))\<close>
by auto
thus ?thesis
using Maps.Comp_eq_iso_class_memb
\<open>\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)\<close>
\<open>\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)\<close>
by meson
qed
ultimately show ?thesis
using \<mu> Maps.comp_char [of src_SPN.cod.leg1 ?tab\<^sub>0] src_SPN by simp
qed
qed
have "Span.in_hom ?\<phi> (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
using \<mu> tab\<^sub>0 spn_ide [of "src \<mu>"] iso_class_eqI
Span.arr_char Span.dom_char Span.cod_char \<phi>.arrow_of_spans_axioms
SPN_src src_SPN src.apex_def tab.apex_def Maps.dom_char
apply (intro Span.in_homI) by auto
(* The preceding cannot be written "by (intro Span.in_homI, auto)", why? *)
moreover have "Maps.iso ?tab\<^sub>0"
using \<mu> tab\<^sub>0 ide_in_iso_class src.is_map_iff_tab\<^sub>0_is_equivalence obj_is_self_adjoint
Maps.iso_char' [of ?tab\<^sub>0]
by auto
ultimately show "Span.isomorphic (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
using Span.isomorphic_def Span.iso_char by auto
qed
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.isomorphic (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
proof -
fix \<mu>
assume \<mu>: "arr \<mu>"
let ?trg = "Maps.MkIde (trg \<mu>)"
have trg: "Maps.ide ?trg"
using \<mu> by simp
interpret trg: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>trg \<mu>\<close>
using \<mu> by (unfold_locales, auto)
interpret trg: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>\<close>
using trg by (unfold_locales, simp)
- let ?tab\<^sub>0 = "MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
+ let ?tab\<^sub>0 = "Maps.MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
have tab\<^sub>0_trg: "\<guillemotleft>tab\<^sub>0 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
is_left_adjoint (tab\<^sub>0 (trg \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
using \<mu> by simp
have tab\<^sub>0: "Maps.arr ?tab\<^sub>0"
using \<mu> Maps.arr_MkArr tab\<^sub>0_trg by blast
- let ?tab\<^sub>1 = "MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
+ let ?tab\<^sub>1 = "Maps.MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
have tab\<^sub>1_trg: "\<guillemotleft>tab\<^sub>1 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
is_left_adjoint (tab\<^sub>1 (trg \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
using \<mu> by simp
have tab\<^sub>1: "Maps.arr ?tab\<^sub>1"
using \<mu> Maps.arr_MkArr tab\<^sub>1_trg by blast
interpret tab: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<close>
using tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char by (unfold_locales, simp)
have "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>0 (trg \<mu>)"
proof -
have "\<guillemotleft>\<l>[tab\<^sub>1 (trg \<mu>)] : trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<Rightarrow> tab\<^sub>1 (trg \<mu>)\<guillemotright>"
using \<mu> by simp
moreover have "iso \<l>[tab\<^sub>1 (trg \<mu>)]"
using \<mu> iso_lunit by simp
ultimately have "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)"
using isomorphic_def by auto
also have "tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>0 (trg \<mu>)"
using \<mu> trg.obj_has_symmetric_tab isomorphic_symmetric by auto
finally show ?thesis by blast
qed
hence "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)"
using \<mu> trg.obj_has_symmetric_tab isomorphic_transitive by blast
have "\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)"
proof -
have "\<guillemotleft>tab\<^sub>1 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and> is_left_adjoint (tab\<^sub>0 (trg \<mu>)) \<and>
\<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
using \<mu> by simp
thus ?thesis by auto
qed
have "\<lbrakk>trg \<mu>\<rbrakk> \<in> Maps.Hom (trg \<mu>) (trg \<mu>)"
proof -
have "\<guillemotleft>trg \<mu> : trg \<mu> \<rightarrow> trg \<mu>\<guillemotright> \<and> is_left_adjoint (trg \<mu>) \<and> \<lbrakk>trg \<mu>\<rbrakk> = \<lbrakk>trg \<mu>\<rbrakk>"
using \<mu> obj_is_self_adjoint by simp
thus ?thesis by auto
qed
interpret SPN_trg: arrow_of_spans Maps.comp \<open>SPN (trg \<mu>)\<close>
using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
have SPN_trg: "SPN (trg \<mu>) =
- \<lparr>Chn = MkArr (src (tab\<^sub>1 (trg \<mu>))) (src (tab\<^sub>1 (trg \<mu>))) \<lbrakk>spn (trg \<mu>)\<rbrakk>,
+ \<lparr>Chn = Maps.MkArr (src (tab\<^sub>1 (trg \<mu>))) (src (tab\<^sub>1 (trg \<mu>))) \<lbrakk>spn (trg \<mu>)\<rbrakk>,
Dom = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<rparr>"
unfolding SPN_def using \<mu> by simp
interpret trg_SPN: arrow_of_spans Maps.comp \<open>Span.trg (SPN \<mu>)\<close>
using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
have trg_SPN: "Span.trg (SPN \<mu>) = \<lparr>Chn = ?trg,
Dom = \<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>,
Cod = \<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>\<rparr>"
proof -
- let ?tab\<^sub>1_dom = "MkArr (src (tab\<^sub>1 (dom \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
+ let ?tab\<^sub>1_dom = "Maps.MkArr (src (tab\<^sub>1 (dom \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
have "Maps.arr ?tab\<^sub>1_dom"
proof -
have "\<guillemotleft>tab\<^sub>1 (dom \<mu>) : src (tab\<^sub>1 (dom \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
is_left_adjoint (tab\<^sub>1 (dom \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
using \<mu> by simp
thus ?thesis
using \<mu> Maps.arr_MkArr by blast
qed
thus ?thesis
using \<mu> Maps.cod_char Span.trg_def by simp
qed
let ?\<phi> = "\<lparr>Chn = ?tab\<^sub>1, Dom = Dom (SPN (trg \<mu>)), Cod = Cod (Span.trg (SPN \<mu>))\<rparr>"
interpret \<phi>: arrow_of_spans Maps.comp ?\<phi>
apply (unfold_locales, simp_all)
proof -
show "Maps.in_hom ?tab\<^sub>1 SPN_trg.dom.apex trg_SPN.cod.apex"
using \<mu> tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char SPN_trg trg_SPN
tab.apex_def trg_SPN.cod.apex_def
apply (intro Maps.in_homI) by simp_all
(* The preceding cannot be written "by (intro Maps.in_homI, simp_all)", why? *)
show "Maps.comp trg_SPN.cod.leg0 ?tab\<^sub>1 = SPN_trg.dom.leg0"
proof -
have "Maps.seq trg_SPN.cod.leg0 ?tab\<^sub>1"
using \<mu> trg_SPN tab\<^sub>1 Maps.dom_char Maps.cod_char
by (intro Maps.seqI, auto)
moreover have "Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
proof -
have "tab\<^sub>1 (trg \<mu>) \<in> Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
using \<mu> is_iso_classI ide_in_iso_class [of "trg \<mu>"]
ide_in_iso_class [of "tab\<^sub>1 (trg \<mu>)"] \<open>trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)\<close>
by auto
thus ?thesis
using Maps.Comp_eq_iso_class_memb
\<open>iso_class (tab\<^sub>1 (trg \<mu>)) \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)\<close>
\<open>iso_class (trg \<mu>) \<in> Maps.Hom (trg \<mu>) (trg \<mu>)\<close>
by meson
qed
moreover have "\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
using \<mu> iso_class_eqI trg.obj_has_symmetric_tab by auto
ultimately show ?thesis
using \<mu> Maps.comp_char [of trg_SPN.cod.leg0 ?tab\<^sub>1] trg_SPN
by simp
qed
show "trg_SPN.cod.leg1 \<odot> ?tab\<^sub>1 = SPN_trg.dom.leg1"
proof -
have "Maps.seq trg_SPN.cod.leg1 ?tab\<^sub>1"
using \<mu> trg_SPN tab\<^sub>1 Maps.dom_char Maps.cod_char
by (intro Maps.seqI, auto)
moreover have "Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
proof -
have "tab\<^sub>1 (trg \<mu>) \<in> Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
using \<mu> is_iso_classI ide_in_iso_class [of "trg \<mu>"]
ide_in_iso_class [of "tab\<^sub>1 (trg \<mu>)"] \<open>trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)\<close>
by auto
thus ?thesis
using Maps.Comp_eq_iso_class_memb
\<open>\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)\<close>
\<open>\<lbrakk>trg \<mu>\<rbrakk> \<in> Maps.Hom (trg \<mu>) (trg \<mu>)\<close>
by meson
qed
ultimately show ?thesis
using \<mu> Maps.comp_char [of trg_SPN.cod.leg1 ?tab\<^sub>1] trg_SPN by simp
qed
qed
have \<phi>: "Span.in_hom ?\<phi> (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
using \<mu> tab\<^sub>0 spn_ide [of "trg \<mu>"] iso_class_eqI
Span.arr_char Span.dom_char Span.cod_char \<phi>.arrow_of_spans_axioms
SPN_trg trg_SPN trg.apex_def tab.apex_def Maps.dom_char
apply (intro Span.in_homI) by auto
have "Maps.iso ?tab\<^sub>1"
proof -
have "Maps.iso ?tab\<^sub>0"
using \<mu> tab\<^sub>0 ide_in_iso_class trg.is_map_iff_tab\<^sub>0_is_equivalence obj_is_self_adjoint
Maps.iso_char' [of ?tab\<^sub>0]
by auto
moreover have "?tab\<^sub>0 = ?tab\<^sub>1"
proof -
have "\<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
using \<mu> iso_class_eqI trg.obj_has_symmetric_tab by auto
thus ?thesis by simp
qed
ultimately show ?thesis by simp
qed
thus "Span.isomorphic (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
using \<phi> Span.isomorphic_def Span.iso_char by auto
qed
qed
lemma SPN_is_weak_arrow_of_homs:
shows "weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN"
..
end
subsubsection "Compositors"
text \<open>
To complete the proof that \<open>SPN\<close> is a pseudofunctor, we need to obtain a natural
isomorphism \<open>\<Phi>\<close>, whose component at \<open>(r, s)\<close> is an isomorphism \<open>\<Phi> (r, s)\<close>
from the horizontal composite \<open>SPN r \<circ> SPN s\<close> to \<open>SPN (r \<star> s)\<close> in \<open>Span(Maps(B))\<close>,
and we need to prove that the coherence conditions are satisfied.
We have shown that the tabulations of \<open>r\<close> and \<open>s\<close> compose to yield a tabulation of \<open>r \<star> s\<close>.
Since tabulations of the same arrow are equivalent, this tabulation must be equivalent
to the chosen tabulation of \<open>r \<star> s\<close>. We therefore obtain an equivalence map from the
apex of \<open>SPN r \<circ> SPN s\<close> to the apex of \<open>SPN (r \<star> s)\<close> which commutes with the
legs of these spans up to isomorphism. This equivalence map determines an invertible
arrow in \<open>Span(Maps(B))\<close>. Moreover, by property \<open>T2\<close>, any two such equivalence maps are
connected by a unique 2-cell, which is consequently an isomorphism. This shows that
the arrow in \<open>Span(Maps(B))\<close> is uniquely determined, which fact we can exploit to establish
the required coherence conditions.
\<close>
locale two_composable_identities_in_bicategory_of_spans =
bicategory_of_spans V H \<a> \<i> src trg +
r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r +
s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and s :: 'a +
assumes composable: "src r = trg s"
begin
notation isomorphic (infix "\<cong>" 50)
interpretation r: arrow_in_bicategory_of_spans V H \<a> \<i> src trg r r r
by (unfold_locales, auto)
interpretation r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
r
using r.is_arrow_of_tabulations_in_maps by simp
interpretation s: arrow_in_bicategory_of_spans V H \<a> \<i> src trg s s s
by (unfold_locales, auto)
interpretation s: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
s
using s.is_arrow_of_tabulations_in_maps by simp
sublocale identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>r \<star> s\<close>
apply unfold_locales by (simp add: composable)
sublocale horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
r s
using composable by (unfold_locales, auto)
abbreviation p\<^sub>0 where "p\<^sub>0 \<equiv> \<rho>\<sigma>.p\<^sub>0"
abbreviation p\<^sub>1 where "p\<^sub>1 \<equiv> \<rho>\<sigma>.p\<^sub>1"
text \<open>
We will take as the composition isomorphism from \<open>SPN r \<circ> SPN s\<close> to \<open>SPN (r \<star> s)\<close>
the arrow of tabulations, induced by the identity \<open>r \<star> s\<close>, from the composite of
the chosen tabulations of \<open>r\<close> and \<open>s\<close> to the chosen tabulation of \<open>r \<star> s\<close>.
As this arrow of tabulations is induced by an identity, it is an equivalence map.
\<close>
interpretation cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1\<close>
\<open>r \<star> s\<close> tab \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
\<open>r \<star> s\<close>
using composable
by (unfold_locales, auto)
lemma cmp_interpretation:
shows "identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
(r \<star> s) \<rho>\<sigma>.tab (tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0) (tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1)
(r \<star> s) tab (tab\<^sub>0 (r \<star> s)) (tab\<^sub>1 (r \<star> s))
(r \<star> s)"
..
definition cmp
where "cmp = cmp.chine"
lemma cmp_props:
shows "\<guillemotleft>cmp : src \<rho>\<sigma>.tab \<rightarrow> src tab\<guillemotright>"
and "\<guillemotleft>cmp : cmp \<Rightarrow> cmp\<guillemotright>"
and "equivalence_map cmp"
and "tab\<^sub>0 (r \<star> s) \<star> cmp \<cong> tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0"
and "tab\<^sub>1 (r \<star> s) \<star> cmp \<cong> tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1"
using cmp_def cmp.leg0_uniquely_isomorphic(1) cmp.leg1_uniquely_isomorphic(1)
isomorphic_symmetric cmp.chine_is_equivalence
by auto
lemma cmp_in_hom [intro]:
shows "\<guillemotleft>cmp : src \<rho>\<sigma>.tab \<rightarrow> src tab\<guillemotright>"
and "\<guillemotleft>cmp : cmp \<Rightarrow> cmp\<guillemotright>"
using cmp_props by auto
lemma cmp_simps [simp]:
shows "arr cmp" and "ide cmp"
and "src cmp = src \<rho>\<sigma>.tab" and "trg cmp = src tab"
and "dom cmp = cmp" and "cod cmp = cmp"
using cmp_props equivalence_map_is_ide by auto
text \<open>
Now we have to use the above properties of the underlying bicategory to
exhibit the composition isomoprhisms as actual arrows in \<open>Span(Maps(B))\<close>
and to prove the required naturality and coherence conditions.
\<close>
interpretation Maps: maps_category V H \<a> \<i> src trg ..
interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
no_notation Fun.comp (infixl "\<circ>" 55)
notation Span.vcomp (infixr "\<bullet>" 55)
notation Span.hcomp (infixr "\<circ>" 53)
notation Maps.comp (infixr "\<odot>" 55)
interpretation SPN: "functor" V Span.vcomp SPN
using SPN_is_functor by simp
interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
using SPN_is_weak_arrow_of_homs by simp
interpretation SPN_r_SPN_s: arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
using composable Span.ide_char [of "SPN r \<circ> SPN s"] by simp
interpretation SPN_r_SPN_s: identity_arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
using composable Span.ide_char [of "SPN r \<circ> SPN s"]
by (unfold_locales, simp)
interpretation SPN_rs: arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
using composable Span.arr_char r.base_simps(2) s.base_simps(2) by blast
interpretation SPN_rs: identity_arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
using composable Span.ide_char SPN.preserves_ide r.is_ide s.is_ide
by (unfold_locales, simp)
text \<open>
The following are the legs (as arrows of \<open>Maps\<close>) of the spans \<open>SPN r\<close> and \<open>SPN s\<close>.
\<close>
definition R\<^sub>0 where "R\<^sub>0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>"
definition R\<^sub>1 where "R\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
definition S\<^sub>0 where "S\<^sub>0 = \<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>"
definition S\<^sub>1 where "S\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 s\<rbrakk>\<rbrakk>"
lemma span_legs_eq:
shows "Leg0 (Dom (SPN r)) = R\<^sub>0" and "Leg1 (Dom (SPN r)) = R\<^sub>1"
and "Leg0 (Dom (SPN s)) = S\<^sub>0" and "Leg1 (Dom (SPN s)) = S\<^sub>1"
using SPN_def R\<^sub>0_def R\<^sub>1_def S\<^sub>0_def S\<^sub>1_def composable by auto
lemma R\<^sub>0_in_hom [intro]:
shows "Maps.in_hom R\<^sub>0 (Maps.MkIde (src r.s\<^sub>0)) (Maps.MkIde (src r))"
by (simp add: Maps.MkArr_in_hom' R\<^sub>0_def)
lemma R\<^sub>1_in_hom [intro]:
shows "Maps.in_hom R\<^sub>1 (Maps.MkIde (src r.s\<^sub>0)) (Maps.MkIde (trg r))"
by (simp add: Maps.MkArr_in_hom' R\<^sub>1_def)
lemma S\<^sub>0_in_hom [intro]:
shows "Maps.in_hom S\<^sub>0 (Maps.MkIde (src s.s\<^sub>0)) (Maps.MkIde (src s))"
by (simp add: Maps.MkArr_in_hom' S\<^sub>0_def)
lemma S\<^sub>1_in_hom [intro]:
shows "Maps.in_hom S\<^sub>1 (Maps.MkIde (src s.s\<^sub>0)) (Maps.MkIde (trg s))"
by (simp add: Maps.MkArr_in_hom' S\<^sub>1_def)
lemma RS_simps [simp]:
shows "Maps.arr R\<^sub>0" and "Maps.dom R\<^sub>0 = Maps.MkIde (src r.s\<^sub>0)"
and "Maps.cod R\<^sub>0 = Maps.MkIde (src r)"
and "Maps.Dom R\<^sub>0 = src r.s\<^sub>0" and "Maps.Cod R\<^sub>0 = src r"
and "Maps.arr R\<^sub>1" and "Maps.dom R\<^sub>1 = Maps.MkIde (src r.s\<^sub>0)"
and "Maps.cod R\<^sub>1 = Maps.MkIde (trg r)"
and "Maps.Dom R\<^sub>1 = src r.s\<^sub>0" and "Maps.Cod R\<^sub>1 = trg r"
and "Maps.arr S\<^sub>0" and "Maps.dom S\<^sub>0 = Maps.MkIde (src s.s\<^sub>0)"
and "Maps.cod S\<^sub>0 = Maps.MkIde (src s)"
and "Maps.Dom S\<^sub>0 = src s.s\<^sub>0" and "Maps.Cod S\<^sub>0 = src s"
and "Maps.arr S\<^sub>1" and "Maps.dom S\<^sub>1 = Maps.MkIde (src s.s\<^sub>0)"
and "Maps.cod S\<^sub>1 = Maps.MkIde (trg s)"
and "Maps.Dom S\<^sub>1 = src s.s\<^sub>0" and "Maps.Cod S\<^sub>1 = trg s"
using R\<^sub>0_in_hom R\<^sub>1_in_hom S\<^sub>0_in_hom S\<^sub>1_in_hom composable
by (auto simp add: R\<^sub>0_def R\<^sub>1_def S\<^sub>0_def S\<^sub>1_def)
text \<open>
The apex of the composite span @{term "SPN r \<circ> SPN s"} (defined in terms of pullback)
coincides with the apex of the composite tabulation \<open>\<rho>\<sigma>\<close> (defined using
the chosen tabulation of \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s)\<close>). We need this to be true in order
to define the compositor of a pseudofunctor from the underlying bicategory \<open>B\<close>
to \<open>Span(Maps(B))\<close>. It is only true if we have carefully chosen pullbacks in \<open>Maps(B)\<close>
in order to ensure the relationship with the chosen tabulations.
\<close>
lemma SPN_r_SPN_s_apex_eq:
shows "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
proof -
have "obj (Maps.Cod SPN_r_SPN_s.leg0)"
using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
moreover have "obj (Maps.Dom SPN_r_SPN_s.leg0)"
using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
- moreover have "SPN_r_SPN_s.leg0 \<noteq> Null"
+ moreover have "SPN_r_SPN_s.leg0 \<noteq> Maps.Null"
using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
moreover have "Maps.Dom SPN_r_SPN_s.leg0 = src \<rho>\<sigma>.tab"
proof -
interpret REP_S\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP S\<^sub>1\<close>
using Maps.REP_in_Map Maps.arr_char Maps.in_HomD S\<^sub>1_def
apply unfold_locales
by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
interpret REP_R\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP R\<^sub>0\<close>
using Maps.REP_in_Map Maps.arr_char Maps.in_HomD R\<^sub>0_def
apply unfold_locales
by (meson Maps.REP_in_hhom(2) R\<^sub>0_in_hom)
have "Maps.Dom SPN_r_SPN_s.leg0 = Maps.Dom (S\<^sub>0 \<odot> Maps.PRJ\<^sub>0 R\<^sub>0 S\<^sub>1)"
using composable Span.hcomp_def S\<^sub>0_def R\<^sub>0_def S\<^sub>1_def by simp
also have "... = Maps.Dom \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
proof -
have "ide ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
proof -
have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
using REP_R\<^sub>0.is_map REP_S\<^sub>1.is_map left_adjoint_is_ide R\<^sub>0_def S\<^sub>1_def
by (metis (no_types, lifting) Maps.REP_CLS REP_R\<^sub>0.antipar(2)
isomorphic_implies_hpar(4) composable r.leg0_simps(3)
r.satisfies_T0 s.leg1_is_map s.leg1_simps(3) s.leg1_simps(4))
thus ?thesis by simp
qed
thus ?thesis by simp
qed
moreover have "Maps.Dom (S\<^sub>0 \<odot> \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>) =
src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
proof -
have "Maps.arr (\<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk>)"
using Maps.CLS_in_hom Maps.prj0_simps(1) Maps.PRJ\<^sub>0_def composable by fastforce
moreover have "Maps.Dom S\<^sub>0 = Maps.Cod \<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk>"
proof -
have "Maps.Cod \<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk> =
trg (prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0))"
by simp
also have "... = src (Maps.REP S\<^sub>1)"
proof -
have "ide (Maps.REP S\<^sub>1)"
by simp
moreover have "is_left_adjoint (Maps.REP R\<^sub>0)"
by auto
moreover have "trg (Maps.REP S\<^sub>1) = trg (Maps.REP R\<^sub>0)"
by (simp add: composable)
ultimately show ?thesis
using S\<^sub>1_def Maps.REP_CLS r.leg0_is_map s.leg1_is_map by simp
qed
also have "... = src (tab\<^sub>0 s)"
using tab\<^sub>0_in_hom(1) by simp
also have "... = Maps.Dom S\<^sub>0"
using S\<^sub>0_def by simp
finally show ?thesis by simp
qed
ultimately have
"Maps.Dom (S\<^sub>0 \<odot> \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>) =
Maps.Dom \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>"
using Maps.CLS_in_hom by simp
thus ?thesis by simp
qed
ultimately show ?thesis
- using Maps.PRJ\<^sub>0_def Maps.CLS_in_hom Maps.dom_char composable Span.hcomp_def
- \<rho>\<sigma>.tab_in_hom s.leg0_is_map s.leg1_is_map Maps.span_prj
- r.satisfies_T0 s.satisfies_T0
- Maps.Dom.simps(1) RS_simps(1) RS_simps(16) RS_simps(18) RS_simps(3)
+ using Maps.PRJ\<^sub>0_def composable Maps.Dom.simps(1) RS_simps(1) RS_simps(16)
+ RS_simps(18) RS_simps(3)
by presburger
qed
also have "... = src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
by simp
finally have
"Maps.Dom SPN_r_SPN_s.leg0 = src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
by simp
also have "... = src (tab\<^sub>0 (r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1))"
proof -
interpret r\<^sub>0's\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1\<close>
using composable by (unfold_locales, simp)
have "(Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1 \<cong> r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1"
proof -
have "(Maps.REP R\<^sub>0)\<^sup>* \<cong> r.s\<^sub>0\<^sup>*"
proof -
have 1: "adjoint_pair (Maps.REP R\<^sub>0) (Maps.REP R\<^sub>0)\<^sup>*"
using REP_R\<^sub>0.is_map left_adjoint_extends_to_adjoint_pair by blast
moreover have "adjoint_pair r.s\<^sub>0 (Maps.REP R\<^sub>0)\<^sup>*"
proof -
have "Maps.REP R\<^sub>0 \<cong> r.s\<^sub>0"
unfolding R\<^sub>0_def
using Maps.REP_CLS r.leg0_is_map composable by force
thus ?thesis
using 1 adjoint_pair_preserved_by_iso isomorphic_def
REP_R\<^sub>0.triangle_in_hom(4) REP_R\<^sub>0.triangle_right'
by auto
qed
ultimately show ?thesis
using r.leg0_is_map left_adjoint_determines_right_up_to_iso
left_adjoint_extends_to_adjoint_pair
by auto
qed
moreover have "Maps.REP S\<^sub>1 \<cong> s.s\<^sub>1"
unfolding S\<^sub>1_def
using Maps.REP_CLS s.leg1_is_map composable by force
moreover have "\<exists>a. a \<cong> (tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<and> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1 \<cong> a"
using calculation composable isomorphic_implies_hpar(3)
hcomp_ide_isomorphic hcomp_isomorphic_ide [of "(Maps.REP R\<^sub>0)\<^sup>*" "r.s\<^sub>0\<^sup>*" s.s\<^sub>1]
by auto
ultimately show ?thesis
using isomorphic_transitive by blast
qed
thus ?thesis
using r\<^sub>0's\<^sub>1.isomorphic_implies_same_tab isomorphic_symmetric by metis
qed
also have "... = src \<rho>\<sigma>.tab"
using VV.ide_char VV.arr_char composable Span.hcomp_def \<rho>\<sigma>.tab_simps(2) by auto
finally show ?thesis by simp
qed
ultimately show ?thesis
using composable Maps.arr_char Maps.dom_char SPN_r_SPN_s.dom.apex_def
apply auto
by (metis (no_types, lifting) Maps.not_arr_null SPN_r_SPN_s.chine_eq_apex
SPN_r_SPN_s.chine_simps(1))
qed
text \<open>
We will be taking the arrow @{term "CLS cmp"} of \<open>Maps\<close> as the composition isomorphism from
@{term "SPN r \<circ> SPN s"} to @{term "SPN (r \<star> s)"}. The following result shows that it
has the right domain and codomain for that purpose.
\<close>
lemma iso_class_cmp_in_hom:
- shows "Maps.in_hom (MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
+ shows "Maps.in_hom (Maps.MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
SPN_r_SPN_s.apex SPN_rs.apex"
and "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex"
proof -
- show "Maps.in_hom (MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
+ show "Maps.in_hom (Maps.MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
SPN_r_SPN_s.apex SPN_rs.apex"
proof -
have "obj (src \<rho>\<sigma>.tab)"
using obj_src \<rho>\<sigma>.tab_in_hom by blast
moreover have "obj (src tab)"
using obj_src by simp
moreover have "\<lbrakk>cmp\<rbrakk> \<in> Maps.Hom (src \<rho>\<sigma>.tab) (src tab)"
by (metis (mono_tags, lifting) cmp.is_map cmp_def cmp_props(1) mem_Collect_eq)
moreover have "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
using SPN_r_SPN_s_apex_eq by simp
moreover have "SPN_rs.apex = Maps.MkIde (src tab)"
using SPN_def composable SPN_rs.cod.apex_def Maps.arr_char Maps.dom_char
SPN_rs.dom.leg_simps(1)
by fastforce
ultimately show ?thesis
using Maps.MkArr_in_hom by simp
qed
thus "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex" by simp
qed
interpretation r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
V H \<a> \<i> src trg \<open>(Maps.REP R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP S\<^sub>1\<close>
proof
show "ide (Maps.REP S\<^sub>1)"
using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
show "ide (Maps.REP R\<^sub>0)\<^sup>*"
using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
Maps.REP_in_hhom(2) R\<^sub>0_in_hom by auto
show "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
using Maps.REP_in_hhom(2) R\<^sub>0_in_hom composable by auto
qed
interpretation R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
by (unfold_locales, simp add: composable)
lemma prj_tab_agreement:
shows "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
and "\<rho>\<sigma>.p\<^sub>0 \<cong> prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
and "\<rho>\<sigma>.p\<^sub>1 \<cong> prj\<^sub>1 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
proof -
show 1: "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
proof -
have "(tab\<^sub>0 r)\<^sup>* \<cong> (Maps.REP R\<^sub>0)\<^sup>*"
using Maps.REP_CLS isomorphic_symmetric R\<^sub>0_def composable r.satisfies_T0
isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint
by fastforce
moreover have "tab\<^sub>1 s \<cong> Maps.REP S\<^sub>1"
by (metis Maps.REP_CLS isomorphic_symmetric S\<^sub>1_def s.leg1_is_map s.leg1_simps(3-4))
moreover have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (tab\<^sub>1 s)"
using composable r.T0.antipar right_adjoint_simps(2) by fastforce
ultimately show ?thesis
using hcomp_isomorphic_ide [of "(tab\<^sub>0 r)\<^sup>*" "(Maps.REP R\<^sub>0)\<^sup>*" "tab\<^sub>1 s"]
hcomp_ide_isomorphic isomorphic_transitive composable
by auto
qed
show "\<rho>\<sigma>.p\<^sub>0 \<cong> tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
show "\<rho>\<sigma>.p\<^sub>1 \<cong> tab\<^sub>1 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
qed
lemma chine_hcomp_SPN_SPN:
shows "Span.chine_hcomp (SPN r) (SPN s) = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
proof -
have "Span.chine_hcomp (SPN r) (SPN s) =
Maps.MkIde (src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)))"
using Span.chine_hcomp_ide_ide [of "SPN r" "SPN s"] composable
Maps.pbdom_def Maps.PRJ\<^sub>0_def Maps.CLS_in_hom Maps.dom_char R\<^sub>0_def S\<^sub>1_def
apply simp
using Maps.prj0_simps(1) RS_simps(1) RS_simps(16) RS_simps(18) RS_simps(3)
by presburger
also have "... = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
using prj_tab_agreement isomorphic_implies_hpar(3) by force
finally show ?thesis by simp
qed
end
text \<open>
The development above focused on two specific composable 1-cells in bicategory \<open>B\<close>.
Here we reformulate those results as statements about the entire bicategory.
\<close>
context bicategory_of_spans
begin
interpretation Maps: maps_category V H \<a> \<i> src trg ..
interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
no_notation Fun.comp (infixl "\<circ>" 55)
notation Span.vcomp (infixr "\<bullet>" 55)
notation Span.hcomp (infixr "\<circ>" 53)
notation Maps.comp (infixr "\<odot>" 55)
notation isomorphic (infix "\<cong>" 50)
interpretation SPN: "functor" V Span.vcomp SPN
using SPN_is_functor by simp
interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
using SPN_is_weak_arrow_of_homs by simp
interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
using SPN.functor_FF by auto
interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
..
interpretation SPNoH: composite_functor VV.comp V
Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
..
text \<open>
Given arbitrary composable 1-cells \<open>r\<close> and \<open>s\<close>, obtain an arrow of spans in \<open>Maps\<close>
having the isomorphism class of \<open>rs.cmp\<close> as its chine.
\<close>
definition CMP
where "CMP r s \<equiv>
\<lparr>Chn = \<lbrakk>\<lbrakk>two_composable_identities_in_bicategory_of_spans.cmp V H \<a> \<i> src trg r s\<rbrakk>\<rbrakk>,
Dom = Dom (SPN r \<circ> SPN s), Cod = Dom (SPN (r \<star> s))\<rparr>"
lemma compositor_in_hom [intro]:
assumes "ide r" and "ide s" and "src r = trg s"
shows "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
and "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
proof -
have rs: "VV.ide (r, s)"
using assms VV.ide_char VV.arr_char by simp
interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
using rs VV.ide_char VV.arr_char apply unfold_locales by auto
-(*
- interpret rs: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
- \<open>r \<star> s\<close> \<open>tab_of_ide (r \<star> s)\<close> \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
- \<open>r \<star> s\<close> \<open>tab_of_ide (r \<star> s)\<close> \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
- \<open>r \<star> s\<close>
- apply unfold_locales by auto
-*)
interpret cmp: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>r \<star> s\<close> rs.\<rho>\<sigma>.tab \<open>tab\<^sub>0 s \<star> rs.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 r \<star> rs.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>r \<star> s\<close> rs.tab \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
\<open>r \<star> s\<close>
by (unfold_locales, auto)
have "rs.cmp = cmp.chine"
using rs.cmp_def by simp
interpret SPN_r_SPN_s: arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
using rs.composable Span.ide_char [of "SPN r \<circ> SPN s"] by simp
interpret SPN_r_SPN_s: identity_arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
using rs.composable Span.ide_char [of "SPN r \<circ> SPN s"]
by (unfold_locales, simp)
interpret SPN_rs: arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
using Span.arr_char rs.is_ide SPN.preserves_arr by blast
interpret SPN_rs: identity_arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
using Span.ide_char rs.is_ide SPN.preserves_ide
by (unfold_locales, simp)
interpret Dom: span_in_category Maps.comp \<open>Dom (CMP r s)\<close>
by (unfold_locales, simp add: CMP_def)
interpret Cod: span_in_category Maps.comp \<open>Cod (CMP r s)\<close>
proof -
(* TODO: I don't understand what makes this so difficult. *)
have "\<guillemotleft>tab\<^sub>0 (r \<star> s) : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> src s\<guillemotright> \<and> is_left_adjoint (tab\<^sub>0 (r \<star> s)) \<and>
\<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> = \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk>"
by simp
hence "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> src s\<guillemotright> \<and> is_left_adjoint f \<and> \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> = \<lbrakk>f\<rbrakk>"
by blast
moreover have "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> trg r\<guillemotright> \<and> is_left_adjoint f \<and>
\<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> = \<lbrakk>f\<rbrakk>"
by (metis rs.base_simps(2) rs.leg1_in_hom(1) rs.leg1_is_map trg_hcomp')
ultimately show "span_in_category Maps.comp (Cod (CMP r s))"
using assms Maps.arr_char Maps.dom_char CMP_def
by (unfold_locales, auto)
qed
interpret r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
V H \<a> \<i> src trg \<open>(Maps.REP rs.R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP rs.S\<^sub>1\<close>
proof
show "ide (Maps.REP rs.S\<^sub>1)"
using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
by (meson Maps.REP_in_hhom(2) rs.S\<^sub>1_in_hom)
show "ide (Maps.REP rs.R\<^sub>0)\<^sup>*"
using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
Maps.REP_in_hhom(2) rs.R\<^sub>0_in_hom by auto
show "src (Maps.REP rs.R\<^sub>0)\<^sup>* = trg (Maps.REP rs.S\<^sub>1)"
using Maps.REP_in_hhom(2) rs.R\<^sub>0_in_hom rs.composable by auto
qed
interpret R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
by (unfold_locales, simp add: rs.composable)
text \<open>
Here we obtain explicit formulas for the legs and apex of \<open>SPN_r_SPN_s\<close> and \<open>SPN_rs\<close>.
\<close>
have SPN_r_SPN_s_leg0_eq:
"SPN_r_SPN_s.leg0 = Maps.comp rs.S\<^sub>0 (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1)"
using rs.composable Span.hcomp_def rs.S\<^sub>0_def rs.R\<^sub>0_def rs.S\<^sub>1_def by simp
have SPN_r_SPN_s_leg1_eq:
"SPN_r_SPN_s.leg1 = Maps.comp rs.R\<^sub>1 (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1)"
using rs.composable Span.hcomp_def rs.R\<^sub>1_def rs.R\<^sub>0_def rs.S\<^sub>1_def by simp
have "SPN_r_SPN_s.apex = Maps.MkIde (src rs.\<rho>\<sigma>.tab)"
using rs.SPN_r_SPN_s_apex_eq by auto
have SPN_rs_leg0_eq: "SPN_rs.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk>\<rbrakk>"
unfolding SPN_def using rs by simp
have SPN_rs_leg1_eq: "SPN_rs.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk>\<rbrakk>"
unfolding SPN_def using rs by simp
have "SPN_rs.apex = Maps.MkIde (src (tab_of_ide (r \<star> s)))"
using SPN_rs.dom.apex_def Maps.dom_char SPN_rs_leg0_eq SPN_rs.dom.leg_simps(1)
by simp
text \<open>
The composition isomorphism @{term "CMP r s"} is an arrow of spans in \<open>Maps(B)\<close>.
\<close>
interpret arrow_of_spans Maps.comp \<open>CMP r s\<close>
proof
show 1: "Maps.in_hom (Chn (CMP r s)) Dom.apex Cod.apex"
using rs.iso_class_cmp_in_hom rs.composable CMP_def by simp
show "Cod.leg0 \<odot> Chn (CMP r s) = Dom.leg0"
proof (intro Maps.arr_eqI)
show 2: "Maps.seq Cod.leg0 (Chn (CMP r s))"
using 1 Maps.dom_char Maps.cod_char by blast
show 3: "Maps.arr Dom.leg0" by simp
show "Maps.Dom (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Dom Dom.leg0"
using 1 2 Maps.dom_char Maps.cod_char Maps.comp_char
Dom.leg_in_hom Maps.in_hom_char Maps.seq_char
by auto
show "Maps.Cod (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Cod Dom.leg0"
using 2 3 Maps.comp_char [of Cod.leg0 "Chn (CMP r s)"]
Dom.leg_simps Dom.apex_def Maps.dom_char SPN_r_SPN_s_leg0_eq
Maps.comp_char [of rs.S\<^sub>0 "Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1"] CMP_def
by simp
show "Maps.Map (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Map Dom.leg0"
proof -
have "Maps.Map (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Comp \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk>"
using 1 2 Maps.dom_char Maps.cod_char
Maps.comp_char [of Cod.leg0 "Chn (CMP r s)"] CMP_def
by simp
also have "... = Maps.Comp \<lbrakk>tab\<^sub>0 s\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
proof -
have "Maps.Comp \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk> = \<lbrakk>tab\<^sub>0 (r \<star> s) \<star> rs.cmp\<rbrakk>"
using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp cmp.is_map rs.cmp_def
by auto
also have "... = Maps.Comp \<lbrakk>tab\<^sub>0 s\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp iso_class_eqI rs.cmp_props(4)
by auto
finally show ?thesis by simp
qed
also have "... = Maps.Map Dom.leg0"
proof -
have "Maps.seq rs.S\<^sub>0 (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1)"
by (intro Maps.seqI, simp_all add: rs.composable)
moreover have "\<lbrakk>prj\<^sub>0 (Maps.REP rs.S\<^sub>1) (Maps.REP rs.R\<^sub>0)\<rbrakk> = \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
using "rs.prj_tab_agreement" iso_class_eqI by auto
moreover have "Maps.Dom (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1) = src rs.\<rho>\<sigma>.p\<^sub>0"
using rs.prj_tab_agreement Maps.PRJ\<^sub>0_def rs.composable
isomorphic_implies_hpar(3)
by auto
ultimately show ?thesis
using SPN_r_SPN_s_leg0_eq Maps.comp_char [of rs.S\<^sub>0 "Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1"]
rs.S\<^sub>0_def Maps.PRJ\<^sub>0_def rs.composable CMP_def
by simp
qed
finally show ?thesis by simp
qed
qed
show "Cod.leg1 \<odot> Chn (CMP r s) = Dom.leg1"
proof (intro Maps.arr_eqI)
show 2: "Maps.seq Cod.leg1 (Chn (CMP r s))"
using 1 Maps.dom_char Maps.cod_char by blast
show 3: "Maps.arr Dom.leg1" by simp
show "Maps.Dom (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Dom Dom.leg1"
using 1 2 Maps.dom_char Maps.cod_char Maps.comp_char
Dom.leg_in_hom Maps.in_hom_char Maps.seq_char
by auto
show "Maps.Cod (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Cod Dom.leg1"
using 2 3 Maps.comp_char [of Cod.leg1 "Chn (CMP r s)"]
Dom.apex_def Maps.dom_char SPN_r_SPN_s_leg1_eq
Maps.comp_char [of rs.R\<^sub>1 "Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1"] CMP_def
by simp
show "Maps.Map (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Map Dom.leg1"
proof -
have "Maps.Map (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Comp \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk>"
using 1 2 Maps.dom_char Maps.cod_char
Maps.comp_char [of Cod.leg1 "Chn (CMP r s)"] CMP_def
by simp
also have "... = Maps.Comp \<lbrakk>tab\<^sub>1 r\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
proof -
have "Maps.Comp \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk> = \<lbrakk>tab\<^sub>1 (r \<star> s) \<star> rs.cmp\<rbrakk>"
using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp cmp.is_map rs.cmp_def
by auto
also have "... = Maps.Comp \<lbrakk>tab\<^sub>1 r\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
using Maps.Comp_eq_iso_class_memb
Maps.CLS_hcomp [of "tab\<^sub>1 r" rs.\<rho>\<sigma>.p\<^sub>1] iso_class_eqI rs.cmp_props(5)
by auto
finally show ?thesis by simp
qed
also have "... = Maps.Map Dom.leg1"
proof -
have "Maps.seq rs.R\<^sub>1 (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1)"
by (intro Maps.seqI, simp_all add: rs.composable)
moreover have "\<lbrakk>prj\<^sub>1 (Maps.REP rs.S\<^sub>1) (Maps.REP rs.R\<^sub>0)\<rbrakk> = \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
using rs.prj_tab_agreement iso_class_eqI by auto
moreover have "Maps.Dom (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1) = src rs.\<rho>\<sigma>.p\<^sub>1"
using rs.prj_tab_agreement Maps.PRJ\<^sub>1_def rs.composable
isomorphic_implies_hpar(3)
by auto
ultimately show ?thesis
using SPN_r_SPN_s_leg1_eq Maps.comp_char [of rs.R\<^sub>1 "Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1"]
rs.R\<^sub>1_def Maps.PRJ\<^sub>1_def rs.composable CMP_def
by simp
qed
finally show ?thesis by simp
(*
* Very simple, right? Yeah, once you sort through the notational morass and
* figure out what equals what.
*)
qed
qed
qed
show "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
using Span.arr_char arrow_of_spans_axioms Span.dom_char Span.cod_char
CMP_def SPN.FF_def VV.arr_char rs.composable
by auto
thus "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
using assms VV.ide_char VV.arr_char VV.in_hom_char SPN.FF_def
Span.src_dom [of "CMP r s"] Span.trg_dom [of "CMP r s"]
by fastforce
qed
lemma compositor_simps [simp]:
assumes "ide r" and "ide s" and "src r = trg s"
shows "Span.arr (CMP r s)"
and "Span.src (CMP r s) = SPN.map\<^sub>0 (src s)" and "Span.trg (CMP r s) = SPN.map\<^sub>0 (trg r)"
and "Span.dom (CMP r s) = HoSPN_SPN.map (r, s)"
and "Span.cod (CMP r s) = SPNoH.map (r, s)"
using assms compositor_in_hom [of r s] by auto
lemma compositor_is_iso:
assumes "ide r" and "ide s" and "src r = trg s"
shows "Span.iso (CMP r s)"
proof -
interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
using assms by (unfold_locales, auto)
have "Span.arr (CMP r s)"
using assms compositor_in_hom by blast
moreover have "Maps.iso \<lbrakk>\<lbrakk>rs.cmp\<rbrakk>\<rbrakk>"
using assms Maps.iso_char'
by (metis (mono_tags, lifting) Maps.CLS_in_hom Maps.Map.simps(1) Maps.in_homE
equivalence_is_left_adjoint ide_in_iso_class rs.cmp_props(3) rs.cmp_simps(2))
ultimately show ?thesis
unfolding CMP_def
using assms Span.iso_char by simp
qed
interpretation \<Xi>: transformation_by_components VV.comp Span.vcomp
HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
proof
fix rs
assume rs: "VV.ide rs"
let ?r = "fst rs"
let ?s = "snd rs"
show "Span.in_hom (CMP ?r ?s) (HoSPN_SPN.map rs) (SPNoH.map rs)"
using rs compositor_in_hom [of ?r ?s] VV.ide_char VV.arr_char by simp
next
fix \<mu>\<nu>
assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
let ?\<mu> = "fst \<mu>\<nu>"
let ?\<nu> = "snd \<mu>\<nu>"
show "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu> =
SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
proof -
let ?LHS = "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu>"
let ?RHS = "SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
have LHS:
"Span.in_hom ?LHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
proof
show "Span.in_hom (HoSPN_SPN.map \<mu>\<nu>) (HoSPN_SPN.map (VV.dom \<mu>\<nu>))
(HoSPN_SPN.map (VV.cod \<mu>\<nu>))"
using \<mu>\<nu> by blast
show "Span.in_hom (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)))
(HoSPN_SPN.map (VV.cod \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
using \<mu>\<nu> by (auto simp add: VV.arr_char)
qed
have RHS:
"Span.in_hom ?RHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
using \<mu>\<nu> by (auto simp add: VV.arr_char)
show "?LHS = ?RHS"
proof (intro Span.arr_eqI)
show "Span.par ?LHS ?RHS"
apply (intro conjI)
using LHS RHS apply auto[2]
proof -
show "Span.dom ?LHS = Span.dom ?RHS"
proof -
have "Span.dom ?LHS = HoSPN_SPN.map (VV.dom \<mu>\<nu>)"
using LHS by auto
also have "... = Span.dom ?RHS"
using RHS by auto
finally show ?thesis by simp
qed
show "Span.cod ?LHS = Span.cod ?RHS"
proof -
have "Span.cod ?LHS = SPNoH.map (VV.cod \<mu>\<nu>)"
using LHS by auto
also have "... = Span.cod ?RHS"
using RHS by auto
finally show ?thesis by simp
qed
qed
show "Chn ?LHS = Chn ?RHS"
proof -
interpret dom_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
\<open>dom ?\<mu>\<close> \<open>dom ?\<nu>\<close>
using \<mu>\<nu> VV.ide_char VV.arr_char by (unfold_locales, auto)
interpret cod_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
\<open>cod ?\<mu>\<close> \<open>cod ?\<nu>\<close>
using \<mu>\<nu> VV.ide_char VV.arr_char by (unfold_locales, auto)
interpret \<mu>_\<nu>: horizontal_composite_of_arrows_of_tabulations_in_maps
V H \<a> \<i> src trg
\<open>dom ?\<mu>\<close> \<open>tab_of_ide (dom ?\<mu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>)\<close>
\<open>dom ?\<nu>\<close> \<open>tab_of_ide (dom ?\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<nu>)\<close>
\<open>cod ?\<mu>\<close> \<open>tab_of_ide (cod ?\<mu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>)\<close>
\<open>cod ?\<nu>\<close> \<open>tab_of_ide (cod ?\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<nu>)\<close>
?\<mu> ?\<nu>
using \<mu>\<nu> VV.arr_char by (unfold_locales, auto)
let ?\<mu>\<nu> = "?\<mu> \<star> ?\<nu>"
interpret dom_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom ?\<mu>\<nu>\<close>
using \<mu>\<nu> by (unfold_locales, simp)
interpret cod_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod ?\<mu>\<nu>\<close>
using \<mu>\<nu> by (unfold_locales, simp)
interpret \<mu>\<nu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom ?\<mu>\<nu>\<close> \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
\<open>cod ?\<mu>\<nu>\<close> \<open>tab_of_ide (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
?\<mu>\<nu>
using \<mu>\<nu> by (unfold_locales, auto)
have Chn_LHS_eq:
"Chn ?LHS = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
proof -
have "Chn ?LHS = Chn (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>))) \<odot>
Chn (HoSPN_SPN.map \<mu>\<nu>)"
using \<mu>\<nu> LHS Span.Chn_vcomp by blast
also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Chn (HoSPN_SPN.map \<mu>\<nu>)"
using \<mu>\<nu> VV.arr_char VV.cod_char CMP_def by simp
also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot>
Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
using \<mu>\<nu> VV.arr_char SPN.FF_def Span.hcomp_def by simp
finally show ?thesis by blast
qed
have Chn_RHS_eq:
- "Chn ?RHS = MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
- \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
- MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
- \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
+ "Chn ?RHS = Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
+ Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
proof -
have "Chn ?RHS = Chn (SPN (?\<mu> \<star> ?\<nu>)) \<odot>
- MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
- \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
+ Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
using \<mu>\<nu> RHS Span.vcomp_def VV.arr_char CMP_def Span.arr_char Span.not_arr_Null
by auto
moreover have "Chn (SPN (?\<mu> \<star> ?\<nu>)) =
- MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
- (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
- \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
+ Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
proof -
have "Chn (SPN (?\<mu> \<star> ?\<nu>)) =
- MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
- (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
- \<lbrakk>spn ?\<mu>\<nu>\<rbrakk>"
+ Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
+ \<lbrakk>spn ?\<mu>\<nu>\<rbrakk>"
using \<mu>\<nu> SPN_def by simp
- also have "... = MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
- (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
- \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
+ also have "... = Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
using spn_def by simp
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
let ?Chn_LHS =
- "MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
+ "Maps.MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<odot>
Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"
let ?Chn_RHS =
- "MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
+ "Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
\<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
- MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
+ Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
have "?Chn_LHS = ?Chn_RHS"
proof (intro Maps.arr_eqI)
interpret LHS: arrow_of_spans Maps.comp ?LHS
using LHS Span.arr_char by auto
interpret RHS: arrow_of_spans Maps.comp ?RHS
using RHS Span.arr_char by auto
show 1: "Maps.arr ?Chn_LHS"
using LHS.chine_in_hom Chn_LHS_eq by auto
show 2: "Maps.arr ?Chn_RHS"
using RHS.chine_in_hom Chn_RHS_eq by auto
text \<open>
Here is where we use \<open>dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN\<close>,
which depends on our having chosen the ``right'' pullbacks for \<open>Maps(B)\<close>.
The map \<open>Chn_LHS\<close> has as its domain the apex of the
horizontal composite of the components of @{term "VV.dom \<mu>\<nu>"},
whereas \<open>Chn_RHS\<close> has as its
domain the apex of the chosen tabulation of \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>.
We need these to be equal in order for \<open>Chn_LHS\<close> and \<open>Chn_RHS\<close> to be equal.
\<close>
show "Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS"
proof -
- have 3: "Maps.Dom ?Chn_LHS = Maps.Dom (Maps.dom ?Chn_LHS)"
+ have "Maps.Dom ?Chn_LHS = Maps.Dom (Maps.dom ?Chn_LHS)"
using \<mu>\<nu> 1 Maps.Dom_dom by presburger
also have
"... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
proof -
have "... = Maps.Dom (Maps.dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
using 1 Maps.seq_char Maps.Dom_comp by auto
also have "... = Maps.Dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
(Leg1 (Dom (SPN ?\<nu>))))"
using \<mu>\<nu> VV.arr_char Span.chine_hcomp_in_hom [of "SPN ?\<nu>" "SPN ?\<mu>"]
by auto
also have "... = Maps.Dom (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
(Leg1 (Dom (SPN ?\<nu>)))))"
proof -
have "Maps.cospan (Leg0 (Dom (SPN (fst \<mu>\<nu>)))) (Leg1 (Dom (SPN (snd \<mu>\<nu>))))"
using \<mu>\<nu> VV.arr_char SPN_in_hom Span.arr_char Span.dom_char SPN_def
Maps.CLS_in_hom Maps.arr_char Maps.cod_char dom_\<mu>_\<nu>.composable
dom_\<mu>_\<nu>.RS_simps(16) dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.RS_simps(1)
dom_\<mu>_\<nu>.R\<^sub>0_def Maps.pbdom_in_hom
by simp
thus ?thesis
using \<mu>\<nu> VV.arr_char Maps.pbdom_in_hom by simp
qed
also have "... = Maps.Dom
(Maps.dom (Maps.pbdom (Leg0 (Dom (SPN (dom ?\<mu>))))
(Leg1 (Dom (SPN (dom ?\<nu>))))))"
using \<mu>\<nu> SPN_def VV.arr_char by simp
also have "... = Maps.Dom
(Maps.dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>))))"
using \<mu>\<nu> VV.arr_char ide_dom
by (simp add: Span.chine_hcomp_ide_ide)
also have "... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
using Maps.Dom_dom Maps.in_homE SPN.preserves_reflects_arr SPN.preserves_src
SPN.preserves_trg Span.chine_hcomp_in_hom dom_\<mu>_\<nu>.composable
dom_\<mu>_\<nu>.r.base_simps(2) dom_\<mu>_\<nu>.s.base_simps(2)
by (metis (no_types, lifting))
finally show ?thesis by simp
qed
also have "... = src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
using "dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN" by simp
also have "... = Maps.Dom ?Chn_RHS"
using 2 Maps.seq_char Maps.Dom_comp by auto
finally show ?thesis by simp
qed
show "Maps.Cod ?Chn_LHS = Maps.Cod ?Chn_RHS"
proof -
have "Maps.Cod ?Chn_LHS = src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>))"
using \<mu>\<nu> 1 VV.arr_char Maps.seq_char by auto
also have "... = src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))"
using \<mu>\<nu> VV.arr_char cod_\<mu>\<nu>.tab_simps(2) by auto
also have "... = Maps.Cod ?Chn_RHS"
by (metis (no_types, lifting) "2" Maps.Cod.simps(1) Maps.Cod_comp Maps.seq_char)
finally show ?thesis by simp
qed
show "Maps.Map ?Chn_LHS = Maps.Map ?Chn_RHS"
proof -
have RHS: "Maps.Map ?Chn_RHS = iso_class (\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp)"
proof -
have "Maps.Map ?Chn_RHS = Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
using \<mu>\<nu> 2 VV.arr_char Maps.Map_comp
Maps.comp_char
- [of "MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
- (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
- \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
- "MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
- (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
- \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"]
+ [of "Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
+ "Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
+ (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"]
by simp
also have "... = \<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk>"
proof -
have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))"
proof -
have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.tab) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))"
using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_props(1-3)
by (metis (mono_tags, lifting) equivalence_is_left_adjoint mem_Collect_eq)
thus ?thesis
using \<mu>\<nu> VV.arr_char dom_\<mu>\<nu>.tab_simps(2) by simp
qed
moreover have "\<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<in>
Maps.Hom (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
(src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
using \<mu>\<nu> VV.arr_char \<mu>\<nu>.chine_in_hom \<mu>\<nu>.is_map by auto
moreover have
"\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<in> Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
proof
show "is_iso_class \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
using is_iso_classI by simp
show "is_iso_class \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
using is_iso_classI by simp
show "dom_\<mu>_\<nu>.cmp \<in> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
using ide_in_iso_class [of dom_\<mu>_\<nu>.cmp] by simp
show "\<mu>\<nu>.chine \<in> \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
using ide_in_iso_class by simp
show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> \<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp"
using \<mu>\<nu> VV.arr_char \<mu>\<nu>.chine_simps dom_\<mu>_\<nu>.cmp_simps dom_\<mu>\<nu>.tab_simps(2)
isomorphic_reflexive
by auto
qed
ultimately show ?thesis
using \<mu>\<nu> dom_\<mu>_\<nu>.cmp_props \<mu>\<nu>.chine_in_hom \<mu>\<nu>.chine_is_induced_map
Maps.Comp_eq_iso_class_memb
by blast
qed
finally show ?thesis by simp
qed
have LHS: "Maps.Map ?Chn_LHS = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
proof -
have "Maps.Map ?Chn_LHS =
Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
(Maps.Map
(Maps.tuple (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
(Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
(Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
(Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))))"
proof -
have "Maps.Map ?Chn_LHS =
Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
(Maps.Map (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
using \<mu>\<nu> 1 VV.arr_char Maps.Map_comp cod_\<mu>\<nu>.tab_simps(2)
Maps.comp_char
- [of "MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
- (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
- \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
+ [of "Maps.MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
+ (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
+ \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
"Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"]
by simp
moreover have "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>) =
Maps.tuple
(Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
(Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
(Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
(Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))"
proof -
have "Maps.PRJ\<^sub>0
- (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
- (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
\<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<and>
Maps.PRJ\<^sub>1
- (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
- (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
\<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
interpret X: identity_in_bicategory_of_spans V H \<a> \<i> src trg
\<open>(tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)\<close>
using \<mu>\<nu> VV.arr_char
by (unfold_locales, simp)
have "Maps.PRJ\<^sub>0
- (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
- (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
- \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
- \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
- Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
- \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
+ \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
+ \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
+ Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
unfolding Maps.PRJ\<^sub>0_def
using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
dom_\<mu>_\<nu>.S\<^sub>1_def
by auto
moreover
have "Maps.PRJ\<^sub>1
- (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
- (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
- \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
- \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
- Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
- \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
+ (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
+ \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
+ \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
+ Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
unfolding Maps.PRJ\<^sub>1_def
using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
dom_\<mu>_\<nu>.S\<^sub>1_def
by auto
moreover
- have "(Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
- \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
- Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
- \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) \<cong>
+ have "(Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
+ \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
+ Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) \<cong>
(tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)"
- proof -
- have "MkArr (src (tab\<^sub>0 (dom (fst \<mu>\<nu>)))) (trg (snd \<mu>\<nu>)) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk> =
- dom_\<mu>_\<nu>.R\<^sub>0"
- using VV.arr_char \<mu>\<nu> dom_\<mu>_\<nu>.R\<^sub>0_def by simp
- moreover have "MkArr (src (tab\<^sub>0 (dom (snd \<mu>\<nu>)))) (trg (snd \<mu>\<nu>))
- \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk> =
- dom_\<mu>_\<nu>.S\<^sub>1"
- using VV.arr_char \<mu>\<nu> dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.s.leg1_simps(3)
- dom_\<mu>_\<nu>.s.leg1_simps(4) trg_dom
- by presburger
- ultimately show ?thesis
- using dom_\<mu>_\<nu>.prj_tab_agreement(1) isomorphic_symmetric
- by presburger
- qed
+ using VV.arr_char \<mu>\<nu> dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.s.leg1_simps(3)
+ dom_\<mu>_\<nu>.s.leg1_simps(4) trg_dom dom_\<mu>_\<nu>.R\<^sub>0_def
+ dom_\<mu>_\<nu>.prj_tab_agreement(1) isomorphic_symmetric
+ by simp
ultimately show ?thesis
using X.isomorphic_implies_same_tab isomorphic_symmetric by metis
qed
thus ?thesis
unfolding Span.chine_hcomp_def
using \<mu>\<nu> VV.arr_char SPN_def isomorphic_reflexive
Maps.comp_CLS [of "spn ?\<mu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1 "spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1"]
Maps.comp_CLS [of "spn ?\<nu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 "spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"]
by simp
qed
moreover have "Maps.Dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)) =
src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
by (metis (no_types, lifting) "1" "2" Maps.Dom.simps(1) Maps.comp_char
\<open>Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS\<close>)
ultimately show ?thesis by simp
qed
also have "... = Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
proof -
let ?tuple = "Maps.tuple \<lbrakk>\<lbrakk>spn (fst \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>tab\<^sub>0 (cod ?\<mu>)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (cod ?\<nu>)\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>spn (snd \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
have "iso_class \<mu>_\<nu>.chine = Maps.Map ?tuple"
using \<mu>_\<nu>.CLS_chine spn_def Maps.Map.simps(1)
by (metis (no_types, lifting))
thus ?thesis by simp
qed
also have "... = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
proof -
have "\<lbrakk>\<mu>_\<nu>.chine\<rbrakk> \<in> Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)"
proof -
have "\<guillemotleft>\<mu>_\<nu>.chine : src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<guillemotright>"
using \<mu>\<nu> VV.arr_char by simp
thus ?thesis
using \<mu>_\<nu>.is_map ide_in_iso_class left_adjoint_is_ide by blast
qed
moreover have "\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<in>
Maps.Hom (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
proof -
have "\<guillemotleft>cod_\<mu>_\<nu>.cmp : src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))\<guillemotright>"
using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_in_hom cod_\<mu>\<nu>.tab_simps(2)
by simp
thus ?thesis
using cod_\<mu>_\<nu>.cmp_props equivalence_is_left_adjoint left_adjoint_is_ide
ide_in_iso_class [of cod_\<mu>_\<nu>.cmp]
by blast
qed
moreover have
"cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine \<in> Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
proof
show "is_iso_class \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
using \<mu>_\<nu>.w_simps(1) is_iso_classI by blast
show "is_iso_class \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
using cod_\<mu>_\<nu>.cmp_simps(2) is_iso_classI by blast
show "\<mu>_\<nu>.chine \<in> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
using ide_in_iso_class by simp
show "cod_\<mu>_\<nu>.cmp \<in> \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
using ide_in_iso_class by simp
show "cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
by (simp add: isomorphic_reflexive)
qed
ultimately show ?thesis
using \<mu>\<nu> cod_\<mu>_\<nu>.cmp_props \<mu>_\<nu>.chine_in_hom \<mu>_\<nu>.chine_is_induced_map
Maps.Comp_eq_iso_class_memb
by simp
qed
finally show ?thesis by simp
qed
have EQ: "\<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk> = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
proof (intro iso_class_eqI)
show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
proof -
interpret dom_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom ?\<mu>\<nu>\<close>
dom_\<mu>_\<nu>.\<rho>\<sigma>.tab
\<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
\<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>dom ?\<mu>\<nu>\<close>
\<open>tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)\<close>
\<open>tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)\<close>
\<open>tab\<^sub>1 (dom ?\<mu> \<star> dom ?\<nu>)\<close>
\<open>dom ?\<mu>\<nu>\<close>
using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_interpretation by simp
interpret cod_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>cod ?\<mu>\<nu>\<close>
cod_\<mu>_\<nu>.\<rho>\<sigma>.tab
\<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
\<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>cod ?\<mu>\<nu>\<close>
\<open>tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)\<close>
\<open>tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
\<open>tab\<^sub>1 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
\<open>cod ?\<mu>\<nu>\<close>
using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_interpretation by simp
interpret L: vertical_composite_of_arrows_of_tabulations_in_maps
V H \<a> \<i> src trg
\<open>dom ?\<mu>\<nu>\<close>
\<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
\<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
\<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>dom ?\<mu>\<nu>\<close>
\<open>tab_of_ide (dom ?\<mu>\<nu>)\<close>
\<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close>
\<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
\<open>cod ?\<mu>\<nu>\<close>
cod_\<mu>\<nu>.tab
\<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
\<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
\<open>dom ?\<mu>\<nu>\<close>
\<open>?\<mu> \<star> ?\<nu>\<close>
using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_in_hom
by (unfold_locales, auto)
interpret R: vertical_composite_of_arrows_of_tabulations_in_maps
V H \<a> \<i> src trg
\<open>dom ?\<mu>\<nu>\<close>
\<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
\<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
\<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>cod ?\<mu>\<nu>\<close>
\<open>cod_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
\<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
\<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>cod ?\<mu>\<nu>\<close>
cod_\<mu>\<nu>.tab
\<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
\<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
\<open>?\<mu> \<star> ?\<nu>\<close>
\<open>cod ?\<mu>\<nu>\<close>
using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_in_hom
by (unfold_locales, auto)
have "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> L.chine"
using \<mu>\<nu> VV.arr_char L.chine_char dom_\<mu>_\<nu>.cmp_def isomorphic_symmetric
by simp
also have "... = R.chine"
using L.is_ide \<mu>\<nu> comp_arr_dom comp_cod_arr isomorphic_reflexive by force
also have "... \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
using \<mu>\<nu> VV.arr_char R.chine_char cod_\<mu>_\<nu>.cmp_def by simp
finally show ?thesis by simp
qed
qed
show ?thesis
using LHS RHS EQ by simp
qed
qed
thus ?thesis
using Chn_LHS_eq Chn_RHS_eq by simp
qed
qed
qed
qed
interpretation \<Xi>: natural_isomorphism VV.comp Span.vcomp
HoSPN_SPN.map SPNoH.map \<Xi>.map
using VV.ide_char VV.arr_char \<Xi>.map_simp_ide compositor_is_iso
by (unfold_locales, simp)
lemma compositor_is_natural_transformation:
shows "transformation_by_components VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map
(\<lambda>rs. CMP (fst rs) (snd rs))"
..
lemma compositor_is_natural_isomorphism:
shows "natural_isomorphism VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map \<Xi>.map"
..
end
subsubsection "Associativity Coherence"
locale three_composable_identities_in_bicategory_of_spans =
bicategory_of_spans V H \<a> \<i> src trg +
f: identity_in_bicategory_of_spans V H \<a> \<i> src trg f +
g: identity_in_bicategory_of_spans V H \<a> \<i> src trg g +
h: identity_in_bicategory_of_spans V H \<a> \<i> src trg h
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and f :: 'a
and g :: 'a
and h :: 'a +
assumes fg: "src f = trg g"
and gh: "src g = trg h"
begin
interpretation f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
using f.is_arrow_of_tabulations_in_maps by simp
interpretation h: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h
using h.is_arrow_of_tabulations_in_maps by simp
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
interpretation Maps: maps_category V H \<a> \<i> src trg ..
interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
no_notation Fun.comp (infixl "\<circ>" 55)
notation Span.vcomp (infixr "\<bullet>" 55)
notation Span.hcomp (infixr "\<circ>" 53)
notation Maps.comp (infixr "\<odot>" 55)
notation isomorphic (infix "\<cong>" 50)
interpretation SPN: "functor" V Span.vcomp SPN
using SPN_is_functor by simp
interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
using SPN_is_weak_arrow_of_homs by simp
interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
using SPN.functor_FF by auto
interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
..
interpretation SPNoH: composite_functor VV.comp V Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
..
text \<open>
Here come a lot of interpretations for ``composite things''.
We need these in order to have relatively short, systematic names for entities that will
appear in the lemmas to follow.
The names of the interpretations use a prefix notation, where \<open>H\<close> refers to horizontal
composition of 1-cells and \<open>T\<close> refers to composite of tabulations.
So, for example, \<open>THfgh\<close> refers to the composite of the tabulation associated with the
horizontal composition \<open>f \<star> g\<close> with the tabulation associated with \<open>h\<close>.
\<close>
interpretation HHfgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close>
using fg gh by (unfold_locales, auto)
interpretation HfHgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close>
using fg gh by (unfold_locales, auto)
interpretation Tfg: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g
using fg gh by (unfold_locales, auto)
interpretation Tgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg g h
using fg gh by (unfold_locales, auto)
interpretation THfgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
\<open>f \<star> g\<close> h
using fg gh by (unfold_locales, auto)
interpretation THfgh: tabulation V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab
\<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
using THfgh.\<rho>\<sigma>.composite_is_tabulation by simp
interpretation TfHgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
f \<open>g \<star> h\<close>
using fg gh by (unfold_locales, auto)
interpretation TfHgh: tabulation V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab
\<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
using TfHgh.\<rho>\<sigma>.composite_is_tabulation by simp
interpretation Tfg_Hfg: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
\<open>f \<star> g\<close>
by (unfold_locales, auto)
interpretation Tgh_Hgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
\<open>g \<star> h\<close>
by (unfold_locales, auto)
interpretation THfgh_HHfgh:
arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>(f \<star> g) \<star> h\<close> \<open>tab_of_ide ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
\<open>(f \<star> g) \<star> h\<close>
using fg gh by (unfold_locales, auto)
interpretation TfHgh_HfHgh:
arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> \<open>tab_of_ide (f \<star> g \<star> h)\<close> \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
\<open>f \<star> g \<star> h\<close>
using fg gh by (unfold_locales, auto)
interpretation TTfgh: composite_tabulation_in_maps V H \<a> \<i> src trg
\<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
using fg gh by (unfold_locales, auto)
interpretation TTfgh_THfgh:
horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
\<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
\<open>f \<star> g\<close> h
..
interpretation TfTgh: composite_tabulation_in_maps V H \<a> \<i> src trg
f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
\<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
using fg gh by (unfold_locales, auto)
interpretation TfTgh_TfHgh:
horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
\<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
\<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
f \<open>g \<star> h\<close>
..
interpretation TfTgh_TfTgh:
horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
\<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
\<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
f \<open>g \<star> h\<close>
..
text \<open>
The following interpretation defines the associativity between the peaks
of the two composite tabulations \<open>TTfgh\<close> (associated to the left) and \<open>TfTgh\<close>
(associated to the right).
\<close>
(* TODO: Try to get rid of the .\<rho>\<sigma> in, e.g., Tfg.\<rho>\<sigma>.p\<^sub>1. *)
interpretation TTfgh_TfTgh:
arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
\<open>\<a>[f, g, h]\<close>
using fg gh by (unfold_locales, auto)
text \<open>
This interpretation defines the map, from the apex of the tabulation associated
with the horizontal composite \<open>(f \<star> g) \<star> h\<close> to the apex of the tabulation associated
with the horizontal composite \<open>f \<star> g \<star> h\<close>, induced by the associativity isomorphism
\<open>\<a>[f, g, h]\<close> from \<open>(f \<star> g) \<star> h\<close> to \<open>f \<star> g \<star> h\<close>.
\<close>
interpretation HHfgh_HfHgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (dom (\<alpha> (f, g, h)))\<close>
\<open>tab\<^sub>0 (dom (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (dom (\<alpha> (f, g, h)))\<close>
\<open>cod (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (cod (\<alpha> (f, g, h)))\<close>
\<open>tab\<^sub>0 (cod (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (cod (\<alpha> (f, g, h)))\<close>
\<open>\<alpha> (f, g, h)\<close>
proof -
have "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
((f \<star> g) \<star> h) (tab_of_ide ((f \<star> g) \<star> h)) (tab\<^sub>0 ((f \<star> g) \<star> h)) (tab\<^sub>1 ((f \<star> g) \<star> h))
(f \<star> g \<star> h) (tab_of_ide (f \<star> g \<star> h)) (tab\<^sub>0 (f \<star> g \<star> h)) (tab\<^sub>1 (f \<star> g \<star> h))
\<a>[f, g, h]"
using fg gh by (unfold_locales, auto)
thus "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
(dom (\<alpha> (f, g, h))) (tab_of_ide (dom (\<alpha> (f, g, h))))
(tab\<^sub>0 (dom (\<alpha> (f, g, h)))) (tab\<^sub>1 (dom (\<alpha> (f, g, h))))
(cod (\<alpha> (f, g, h))) (tab_of_ide (cod (\<alpha> (f, g, h))))
(tab\<^sub>0 (cod (\<alpha> (f, g, h)))) (tab\<^sub>1 (cod (\<alpha> (f, g, h))))
(\<alpha> (f, g, h))"
using fg gh \<alpha>_def by auto
qed
interpretation SPN_f: arrow_of_spans Maps.comp \<open>SPN f\<close>
using SPN_in_hom Span.arr_char [of "SPN f"] by simp
interpretation SPN_g: arrow_of_spans Maps.comp \<open>SPN g\<close>
using SPN_in_hom Span.arr_char [of "SPN g"] by simp
interpretation SPN_h: arrow_of_spans Maps.comp \<open>SPN h\<close>
using SPN_in_hom Span.arr_char [of "SPN h"] by simp
interpretation SPN_fgh: three_composable_identity_arrows_of_spans Maps.comp
Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 \<open>SPN f\<close> \<open>SPN g\<close> \<open>SPN h\<close>
using fg gh Span.arr_char SPN_in_hom SPN.preserves_ide Span.ide_char
apply unfold_locales by auto
text \<open>
The following relates the projections associated with the composite span \<open>SPN_fgh\<close>
with tabulations in the underlying bicategory.
\<close>
lemma prj_char:
shows "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
and "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
and "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
and "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
and "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
and "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
proof -
show "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
have "ide (Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
by (metis TTfgh.composable TTfgh.leg1_simps(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
Tfg.\<rho>\<sigma>.T0.ide_right Tfg_Hfg.u_simps(3) f.T0.antipar(2) f.T0.ide_right
f.u_simps(3) fg g.ide_leg1 g.leg1_simps(4) h.ide_leg1 h.leg1_simps(4)
ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(1))
thus ?thesis
using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>1 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1"]
by (simp add: TTfgh.composable Tfg.\<rho>\<sigma>.T0.antipar(2))
qed
show "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
have "ide (Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
by (metis TTfgh.leg1_simps(2) bicategory_of_spans.tab\<^sub>0_simps(1)
bicategory_of_spans.tab\<^sub>1_simps(1) bicategory_of_spans_axioms
Tfg.\<rho>\<sigma>.T0.antipar(2) Tfg.\<rho>\<sigma>.T0.ide_right Tfg.composable f.T0.antipar(2)
f.T0.ide_right f.u_simps(3) g.ide_leg1 g.leg1_simps(4)
Tfg.u_simps(3) THfgh.composable h.ide_leg1 h.leg1_simps(4)
ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(3))
thus ?thesis
using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>0 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1"]
by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
qed
show "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
using isomorphic_reflexive TTfgh.prj_char Tfg.\<rho>\<sigma>.prj_char
Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
by (simp add: Tfg.composable)
show "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
TfTgh.prj_char
by simp
show "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>1 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0"]
by simp
show "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>1 g" "Tgh.\<rho>\<sigma>.p\<^sub>1" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>0 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0"]
by simp
qed
interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
using compositor_is_natural_transformation by simp
interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
HoSPN_SPN.map SPNoH.map \<Phi>.map
using compositor_is_natural_isomorphism by simp
(*
* TODO: Figure out how this subcategory gets introduced.
* The simps in the locale are used in the subsequent proofs.
*)
interpretation VVV': subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> arr (fst (snd \<tau>\<mu>\<nu>)) \<and> arr (snd (snd \<tau>\<mu>\<nu>)) \<and>
src (fst (snd \<tau>\<mu>\<nu>)) = trg (snd (snd \<tau>\<mu>\<nu>)) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using fg gh VVV.arr_char VV.arr_char VVV.subcategory_axioms by simp
text \<open>
We define abbreviations for the left and right-hand sides of the equation for
associativity coherence.
\<close>
(*
* TODO: \<Phi> doesn't really belong in this locale. Replace it with CMP and rearrange
* material so that this locale comes first and the definition of \<Phi> comes later
* in bicategory_of_spans.
*)
abbreviation LHS
where "LHS \<equiv> SPN \<a>[f, g, h] \<bullet> \<Phi>.map (f \<star> g, h) \<bullet> (\<Phi>.map (f, g) \<circ> SPN h)"
abbreviation RHS
where "RHS \<equiv> \<Phi>.map (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi>.map (g, h)) \<bullet>
Span.assoc (SPN f) (SPN g) (SPN h)"
lemma arr_LHS:
shows "Span.arr LHS"
using fg gh VVV.arr_char VVV.ide_char VV.arr_char VV.ide_char Span.hseqI'
HoHV_def compositor_in_hom \<alpha>_def
apply (intro Span.seqI)
apply simp_all
using SPN.FF_def
apply simp
proof -
have "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h)"
using fg gh compositor_in_hom by simp
also have "... = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
proof -
have "Span.seq (CMP (f \<star> g) h) (CMP f g \<circ> SPN h)"
proof (intro Span.seqI Span.hseqI)
show 1: "Span.in_hhom (SPN h) (SPN.map\<^sub>0 (src h)) (SPN.map\<^sub>0 (trg h))"
using SPN.preserves_src SPN.preserves_trg by simp
show 2: "Span.in_hhom (CMP f g) (SPN.map\<^sub>0 (trg h)) (SPN.map\<^sub>0 (trg f))"
using compositor_in_hom SPN_fgh.\<nu>\<pi>.composable fg by auto
show 3: "Span.arr (CMP (f \<star> g) h)"
using TTfgh.composable Tfg.\<rho>\<sigma>.ide_base compositor_simps(1) h.is_ide by auto
show "Span.dom (CMP (f \<star> g) h) = Span.cod (CMP f g \<circ> SPN h)"
using 1 2 3 fg gh compositor_in_hom SPN_fgh.\<nu>\<pi>.composable SPN_in_hom SPN.FF_def
by auto
qed
thus ?thesis by simp
qed
finally show "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
by blast
qed
lemma arr_RHS:
shows "Span.arr RHS"
using fg gh VV.ide_char VV.arr_char \<Phi>.map_simp_ide SPN.FF_def Span.hseqI'
by (intro Span.seqI, simp_all)
lemma par_LHS_RHS:
shows "Span.par LHS RHS"
proof (intro conjI)
show "Span.arr LHS"
using arr_LHS by simp
show "Span.arr RHS"
using arr_RHS by simp
show "Span.dom LHS = Span.dom RHS"
proof -
have "Span.dom LHS = Span.dom (\<Phi>.map (f, g) \<circ> SPN h)"
using arr_LHS by auto
also have "... = Span.dom (\<Phi>.map (f, g)) \<circ> Span.dom (SPN h)"
using arr_LHS Span.dom_hcomp [of "SPN h" "\<Phi>.map (f, g)"] by blast
also have "... = (SPN f \<circ> SPN g) \<circ> SPN h"
using fg \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def by simp
also have "... = Span.dom (Span.assoc (SPN f) (SPN g) (SPN h))"
using fg gh VVV.arr_char VVV.ide_char VV.arr_char VV.ide_char by simp
also have "... = Span.dom RHS"
using \<open>Span.arr RHS\<close> by auto
finally show ?thesis by blast
qed
show "Span.cod LHS = Span.cod RHS"
proof -
have "Span.cod LHS = Span.cod (SPN \<a>[f, g, h])"
using arr_LHS by simp
also have "... = SPN (f \<star> g \<star> h)"
unfolding \<alpha>_def
using fg gh VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char HoVH_def
by simp
also have "... = Span.cod RHS"
using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def
compositor_in_hom
by simp
finally show ?thesis by blast
qed
qed
lemma Chn_LHS_eq:
shows "Chn LHS =
\<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
proof -
have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot>
Span.chine_hcomp (CMP f g) (SPN h)"
proof -
have "Chn LHS = Chn (SPN \<a>[f, g, h]) \<odot> Chn (CMP (f \<star> g) h) \<odot>
Chn (CMP f g \<circ> SPN h)"
using fg gh arr_LHS \<Phi>.map_simp_ide VV.ide_char VV.arr_char Span.Chn_vcomp
by auto
moreover have "Chn (SPN \<a>[f, g, h]) = Maps.CLS HHfgh_HfHgh.chine"
using fg gh SPN_def VVV.arr_char VV.arr_char spn_def \<alpha>_def by simp
moreover have "Chn (CMP (f \<star> g) h) = Maps.CLS THfgh_HHfgh.chine"
using fg gh CMP_def THfgh.cmp_def by simp
moreover have "Chn (CMP f g \<circ> SPN h) = Span.chine_hcomp (CMP f g) (SPN h)"
using fg gh Span.hcomp_def by simp
ultimately show ?thesis by simp
qed
moreover have "Span.chine_hcomp (CMP f g) (SPN h) = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
proof -
have "Span.chine_hcomp (CMP f g) (SPN h) =
Maps.tuple
(\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
\<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
(\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
proof -
have "\<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
using fg isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>0 g" "Tfg.\<rho>\<sigma>.p\<^sub>0" "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
by simp
moreover have "span_in_category.apex Maps.comp \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr> =
\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk>"
proof -
interpret h: span_in_category Maps.comp \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr>\<close>
using h.determines_span by simp
interpret dom_h: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom h\<close> \<open>tab_of_ide (dom h)\<close> \<open>tab\<^sub>0 (dom h)\<close> \<open>tab\<^sub>1 (dom h)\<close>
\<open>cod h\<close> \<open>tab_of_ide (cod h)\<close> \<open>tab\<^sub>0 (cod h)\<close> \<open>tab\<^sub>1 (cod h)\<close>
h
by (simp add: h.is_arrow_of_tabulations_in_maps
identity_arrow_of_tabulations_in_maps.intro
identity_arrow_of_tabulations_in_maps_axioms.intro)
have "Maps.arr h.leg0"
using h.leg_simps(1) by simp
hence "Maps.dom h.leg0 = \<lbrakk>\<lbrakk>dom_h.chine\<rbrakk>\<rbrakk>"
using Maps.dom_char Maps.CLS_in_hom
apply simp
proof -
have "h.is_induced_map (src (tab\<^sub>0 h))"
using h.is_induced_map_iff dom_h.\<Delta>_eq_\<rho> h.apex_is_induced_by_cell by force
hence "src (tab\<^sub>0 h) \<cong> h.chine"
using h.chine_is_induced_map h.induced_map_unique by simp
thus "\<lbrakk>src (tab\<^sub>0 h)\<rbrakk> = \<lbrakk>h.chine\<rbrakk>"
using iso_class_eqI by simp
qed
thus ?thesis
using h.apex_def spn_def by simp
qed
ultimately show ?thesis
unfolding Span.chine_hcomp_def
using fg gh CMP_def Tfg.\<rho>\<sigma>.prj_char Span.hcomp_def by simp
qed
also have "... = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
proof -
have "\<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
Maps.tuple \<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
using TTfgh_THfgh.CLS_chine by simp
also have "... =
Maps.tuple (\<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>)
\<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
(\<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
proof -
have "\<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint TTfgh.p\<^sub>1"
using Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable by simp
moreover have "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1 \<cong> Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"
using TTfgh_THfgh.prj_chine(2) isomorphic_reflexive isomorphic_implies_hpar(2)
by blast
ultimately show ?thesis
using Tfg_Hfg.is_map
Maps.comp_CLS [of Tfg_Hfg.chine TTfgh.p\<^sub>1 "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"]
by simp
qed
moreover have "\<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint TTfgh.p\<^sub>0"
by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
moreover have "h.chine \<star> TTfgh.p\<^sub>0 \<cong> h.chine \<star> TTfgh.p\<^sub>0"
using TTfgh_THfgh.prj_chine(1) isomorphic_reflexive isomorphic_implies_hpar(2)
by blast
ultimately show ?thesis
using h.is_map Maps.comp_CLS [of h.chine TTfgh.p\<^sub>0 "h.chine \<star> TTfgh.p\<^sub>0"]
by simp
qed
ultimately show ?thesis by argo
qed
also have "... =
Maps.tuple (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
\<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
(\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
using Tfg.cmp_def spn_def TTfgh.prj_char by simp
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
ultimately show ?thesis by simp
qed
abbreviation tuple_BC
where "tuple_BC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0"
abbreviation tuple_ABC
where "tuple_ABC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>1\<^sub>1
SPN_fgh.\<mu>.leg0
(SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
tuple_BC"
abbreviation tuple_BC'
where "tuple_BC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
abbreviation tuple_ABC'
where "tuple_ABC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
tuple_BC'"
lemma csq:
shows "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
and "Maps.commutative_square SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
proof -
show 1: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
proof
show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
using SPN_fgh.prj_simps(2-3,5-6) by presburger
show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
by auto
show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
qed
show "Maps.commutative_square
SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
proof
show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using fg gh SPN_fgh.prj_simps(10) by blast
show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
using fg gh 1 Maps.tuple_simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(1)
SPN_fgh.prj_simps(4) SPN_fgh.prj_simps(5)
by presburger
show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 = (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
using 1 fg gh Maps.comp_assoc Maps.prj_tuple
by (metis (no_types, lifting) Maps.pullback_commutes' SPN_fgh.cospan_\<mu>\<nu>)
qed
qed
lemma tuple_ABC_eq_ABC':
shows "tuple_BC = tuple_BC'"
and "tuple_ABC = tuple_ABC'"
proof -
have "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
using prj_char by simp
moreover have "SPN_fgh.\<mu>.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk>"
by simp
moreover have "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
by (simp add: g.T0.antipar(2))
moreover show "tuple_BC = tuple_BC'"
using prj_char Tfg.\<rho>\<sigma>.prj_char by simp
ultimately show "tuple_ABC = tuple_ABC'"
by argo
qed
lemma tuple_BC_in_hom:
shows "Maps.in_hom tuple_BC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0))"
proof
show 1: "Maps.arr tuple_BC"
using csq(1) by simp
have 2: "Maps.commutative_square
\<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
by (metis Tfg.S\<^sub>0_def Tfg.span_legs_eq(3) Tgh.S\<^sub>1_def Tgh.span_legs_eq(4) csq(1)
prj_char(2) prj_char(3))
show "Maps.dom tuple_BC = Maps.MkIde (src TTfgh.p\<^sub>0)"
proof -
have "Maps.dom tuple_BC' = Maps.dom \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
using 2 Maps.tuple_simps by simp
also have "... = Chn (Span.hcomp (Span.hcomp (SPN f) (SPN g)) (SPN h))"
using Maps.dom_char
by (metis SPN_fgh.prj_simps(5) prj_char(2))
also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
using 1 fg gh Maps.dom_char csq(1) prj_char(3) tuple_ABC_eq_ABC'(1)
Maps.Dom.simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(3,5-6)
by presburger
finally have "Maps.dom tuple_BC' = Maps.MkIde (src TTfgh.p\<^sub>0)"
by blast
thus ?thesis
using tuple_ABC_eq_ABC' by simp
qed
show "Maps.cod tuple_BC = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
proof -
have "Maps.cod tuple_BC' = Maps.pbdom \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>"
using 1 2 fg gh Maps.tuple_in_hom by blast
also have "... = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
using 1 2 fg gh Maps.pbdom_def
by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tfg.S\<^sub>0_def Tfg.span_legs_eq(3)
Tgh.S\<^sub>1_def Tgh.chine_hcomp_SPN_SPN Tgh.span_legs_eq(4) g.is_ide)
finally show ?thesis
using tuple_ABC_eq_ABC' by simp
qed
qed
lemma tuple_ABC_in_hom:
shows "Maps.in_hom tuple_ABC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src TfTgh.p\<^sub>0))"
proof
show 1: "Maps.arr tuple_ABC"
using SPN_fgh.chine_assoc_def SPN_fgh.chine_assoc_in_hom by auto
show "Maps.dom tuple_ABC = Maps.MkIde (src TTfgh.p\<^sub>0)"
proof -
have "Maps.dom tuple_ABC = Maps.dom SPN_fgh.chine_assoc"
by (simp add: SPN_fgh.chine_assoc_def)
also have "... = Chn ((SPN f \<circ> SPN g) \<circ> SPN h)"
using SPN_fgh.chine_assoc_in_hom by blast
also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
by (metis (lifting) Maps.Dom.simps(1) Maps.dom_char SPN_fgh.prj_simps(3)
SPN_fgh.prj_simps(6) prj_char(3))
finally show ?thesis by blast
qed
show "Maps.cod tuple_ABC = Maps.MkIde (src TfTgh.p\<^sub>0)"
proof -
have "Maps.cod tuple_ABC = Maps.cod SPN_fgh.chine_assoc"
by (simp add: SPN_fgh.chine_assoc_def)
also have 1: "... = Chn (SPN f \<circ> SPN g \<circ> SPN h)"
using SPN_fgh.chine_assoc_in_hom by blast
also have "... = Maps.MkIde (src TfTgh.p\<^sub>0)"
by (metis (lifting) Maps.Dom.simps(1) Maps.cod_char Maps.seq_char
SPN_fgh.prj_chine_assoc(1) SPN_fgh.prj_simps(1) TfTgh.leg1_in_hom(1)
TfTgh_TfTgh.u_in_hom 1 in_hhomE prj_char(4) src_hcomp')
finally show ?thesis by argo
qed
qed
lemma Chn_RHS_eq:
shows "Chn RHS = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
proof -
have "Chn RHS =
Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
proof -
have "Chn RHS = Chn (\<Phi>.map (f, g \<star> h)) \<odot>
Chn ((SPN f \<circ> \<Phi>.map (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h))"
using arr_RHS Span.vcomp_eq Span.Chn_vcomp by blast
also have "... = Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
proof -
have "Span.seq (SPN f \<circ> \<Phi>.map (g, h)) (Span.assoc (SPN f) (SPN g) (SPN h))"
using arr_RHS by auto
thus ?thesis
using fg gh Span.vcomp_eq [of "SPN f \<circ> \<Phi>.map (g, h)"
"Span.assoc (SPN f) (SPN g) (SPN h)"]
by simp
qed
finally show ?thesis by blast
qed
moreover have "Chn (\<Phi>.map (f, g \<star> h)) = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk>"
using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char VV.arr_char CMP_def TfHgh.cmp_def
by simp
moreover have "Chn (SPN f \<circ> \<Phi>.map (g, h)) = Span.chine_hcomp (SPN f) (CMP g h)"
using fg gh Span.hcomp_def \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def
by simp
moreover have "Chn (Span.assoc (SPN f) (SPN g) (SPN h)) = tuple_ABC"
using fg gh Span.\<alpha>_ide VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
SPN_fgh.chine_assoc_def Span.\<alpha>_def
by simp
moreover have "Span.chine_hcomp (SPN f) (CMP g h) = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
proof -
have "Span.chine_hcomp (SPN f) (CMP g h) =
Maps.tuple
(\<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>)
\<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
(\<lbrakk>\<lbrakk>Tgh_Hgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
proof -
interpret f: span_in_category Maps.comp
- \<open>\<lparr>Leg0 = MkArr (src (tab\<^sub>0 f)) (trg g) \<lbrakk>tab\<^sub>0 f\<rbrakk>,
- Leg1 = MkArr (src (tab\<^sub>0 f)) (trg f) \<lbrakk>tab\<^sub>1 f\<rbrakk>\<rparr>\<close>
+ \<open>\<lparr>Leg0 = Maps.MkArr (src (tab\<^sub>0 f)) (trg g) \<lbrakk>tab\<^sub>0 f\<rbrakk>,
+ Leg1 = Maps.MkArr (src (tab\<^sub>0 f)) (trg f) \<lbrakk>tab\<^sub>1 f\<rbrakk>\<rparr>\<close>
using f.determines_span
by (simp add: Tfg.composable)
interpret f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
using f.is_arrow_of_tabulations_in_maps by simp
have "f.apex = Maps.CLS f.chine"
proof (intro Maps.arr_eqI)
show "Maps.arr f.apex" by simp
show "Maps.arr \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
using Maps.CLS_in_hom f.is_map by blast
show "Maps.Dom f.apex = Maps.Dom \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
using f.apex_def Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable by auto
show "Maps.Cod f.apex = Maps.Cod \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
using f.apex_def Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable by auto
show "Maps.Map f.apex = Maps.Map \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
proof -
have "Maps.Map f.apex = \<lbrakk>src (tab\<^sub>0 f)\<rbrakk>"
using f.apex_def Maps.dom_char Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable
by auto
also have "... = \<lbrakk>f.chine\<rbrakk>"
proof (intro iso_class_eqI)
have "f.is_induced_map (src (tab\<^sub>0 f))"
using f.apex_is_induced_by_cell comp_cod_arr by auto
thus "src (tab\<^sub>0 f) \<cong> f.chine"
using f.induced_map_unique f.chine_is_induced_map by simp
qed
also have "... = Maps.Map \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
by simp
finally show ?thesis by simp
qed
qed
thus ?thesis
unfolding Span.chine_hcomp_def
using fg gh CMP_def Tgh.\<rho>\<sigma>.prj_char Span.hcomp_def isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
Tgh.cmp_def TfTgh.prj_char
by simp
qed
also have "... = Maps.tuple \<lbrakk>\<lbrakk>f.chine \<star> TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>Tgh_Hgh.chine \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
using isomorphic_reflexive TfHgh.composable f.is_map TfHgh.composable Tgh_Hgh.is_map
Maps.comp_CLS [of f.chine TfTgh.p\<^sub>1 "f.chine \<star> TfTgh.p\<^sub>1"]
Maps.comp_CLS [of Tgh_Hgh.chine TfTgh.p\<^sub>0 "Tgh_Hgh.chine \<star> TfTgh.p\<^sub>0"]
by auto
also have "... = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
using TfTgh_TfHgh.CLS_chine by simp
finally show ?thesis by blast
qed
ultimately have "Chn RHS =\<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC"
by simp
also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
using tuple_ABC_eq_ABC' by simp
finally show ?thesis by simp
qed
interpretation g\<^sub>0h\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg \<open>tab\<^sub>1 h\<close> \<open>tab\<^sub>0 g\<close>
using gh by (unfold_locales, auto)
interpretation f\<^sub>0g\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg \<open>tab\<^sub>1 g\<close> \<open>tab\<^sub>0 f\<close>
using fg by (unfold_locales, auto)
interpretation f\<^sub>0gh\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg
\<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close> \<open>tab\<^sub>0 f\<close>
using fg gh Tgh.\<rho>\<sigma>.leg1_is_map
by (unfold_locales, auto)
interpretation fg\<^sub>0h\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg
\<open>tab\<^sub>1 h\<close> \<open>tab\<^sub>0 g \<star> Tfg.p\<^sub>0\<close>
using TTfgh.r\<^sub>0s\<^sub>1_is_cospan by simp
lemma src_tab_eq:
shows "(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu> =
TTfgh.tab"
proof -
have "TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu> =
(\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> TTfgh.tab"
unfolding TTfgh.tab_def
using TTfgh_TfTgh.chine_is_induced_map TTfgh.tab_def TTfgh_TfTgh.\<Delta>_simps(4)
by auto
moreover have "iso (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0)"
by (simp add: fg gh)
moreover have "inv (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) = \<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
using fg gh by simp
ultimately show ?thesis
- using invert_side_of_triangle(1)
+ using TTfgh_TfTgh.\<Delta>_simps(1)
+ invert_side_of_triangle(1)
[of "TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu>"
"\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0" TTfgh.tab]
- TTfgh_TfTgh.\<Delta>_simps(1) (* TODO: Must go last? Why? *)
- by presburger
+ by argo
qed
text \<open>
We need to show that the associativity isomorphism (defined in terms of tupling) coincides
with \<open>TTfgh_TfTgh.chine\<close> (defined in terms of tabulations). In order to do this,
we need to know how the latter commutes with projections. That is the purpose of
the following lemma. Unfortunately, it requires some lengthy calculations,
which I haven't seen any way to avoid.
\<close>
lemma prj_chine:
shows "\<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
and "\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
and "\<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
proof -
have 1: "ide TfTgh.p\<^sub>1"
by (simp add: TfTgh.composable)
have 2: "ide TTfgh_TfTgh.chine"
by simp
have 3: "src TfTgh.p\<^sub>1 = trg TTfgh_TfTgh.chine"
using TTfgh_TfTgh.chine_in_hom(1) by simp
have 4: "src (tab\<^sub>1 f) = trg TfTgh.p\<^sub>1"
using TfTgh.leg1_simps(2) by blast
text \<open>
The required isomorphisms will each be established via \<open>T2\<close>, using the equation
\<open>src_tab_eq\<close> (associativities omitted from diagram):
$$
\begin{array}{l}
\xymatrix{
&& \xtwocell[dddd]{}\omit{^{\rm the\_}\nu}
& \scriptstyle{{\rm TTfgh}.{\rm apex}} \ar[dd]^{{\rm chine}} \ar[dddlll]_{{\rm TfTgh}.p_1} \ar[dddrrr]^{{\rm TfTgh}.p_0}
& \xtwocell[dddd]{}\omit{^{\rm the\_}\theta} \\
&&&&& \\
&&& \scriptstyle{{\rm TfTgh.apex}} \ar[ddll]_{{\rm TfTgh}.p_1} \ar[dr]^{{\rm TfTgh}.p_0} && \\
\scriptstyle{f.{\rm apex}} \ar[dd]_{f.{\rm tab}_1}
&& \dtwocell\omit{^<-7>{f_0gh_1.\phi}}
&& \scriptstyle{{\rm Tgh.apex}} \ar[dl]_{{\rm Tgh}.p_1} \ar[dr]^{{\rm Tgh}.p_0} \ddtwocell\omit{^{g_0h_1.\phi}}
&& \scriptstyle{h.{\rm apex}} \ar[dd]^{h.{\rm tab}_0} \\
& \scriptstyle{f.{\rm apex}} \ar[dl]_{f.{\rm tab}_1} \ar[dr]^{f.{\rm tab}_0} \dtwocell\omit{^f.{\rm tab}}
&& \scriptstyle{g.{\rm apex}} \ar[dl]_{g.{\rm tab}_1} \ar[dr]^{g.{\rm tab}_0} \dtwocell\omit{^g.{\rm tab}}
&& \scriptstyle{h.{\rm apex}} \ar[dl]_{h.{\rm tab}_1} \ar[dr]^{h.{\rm tab}_0} \dtwocell\omit{^h.{\rm tab}} \\
\scriptstyle{{\rm trg}~f} && \scriptstyle{{\rm src}~f = {\rm trg}~g} \ar[ll]^{f}
&& \scriptstyle{{\rm src}~g = {\rm trg}~h} \ar[ll]^{g} && \scriptstyle{{\rm src}~h} \ar[ll]^{h}
}
\\
\\
\hspace{7cm}=
\\
\\
\xymatrix{
&&& \scriptstyle{{\rm TTfgh.apex}} \ar[dl]_{{\rm TTfgh}.p_1} \ar[ddrr]^{{\rm TTfgh}.p_0} && \\
&& \scriptstyle{{\rm Tfg.apex}} \ar[dl]_{{\rm Tfg}.p_1} \ar[dr]^{{\rm Tfg}.p_0} \ddtwocell\omit{^{f_0g_1.\phi}}
& \dtwocell\omit{^<-7>{fg_0h_1.\phi}} &&& \\
& \scriptstyle{f.{\rm apex}} \ar[dl]_{f.{\rm tab}_1} \ar[dr]^{f.{\rm tab}_0} \dtwocell\omit{^f.{\rm tab}}
&& \scriptstyle{g.{\rm apex}} \ar[dl]_{g.{\rm tab}_1} \ar[dr]^{g.{\rm tab}_0} \dtwocell\omit{^g.{\rm tab}}
&& \scriptstyle{h.{\rm apex}} \ar[dl]_{h.{\rm tab}_1} \ar[dr]^{h.{\rm tab}_0} \dtwocell\omit{^h.{\rm tab}} \\
\scriptstyle{{\rm trg}~f} && \scriptstyle{{\rm src}~f = {\rm trg}~g} \ar[ll]^{f}
&& \scriptstyle{{\rm src}~g = {\rm trg}~h} \ar[ll]^{g} && \scriptstyle{{\rm src}~h} \ar[ll]^{h}
}
\end{array}
$$
There is a sequential dependence between the proofs, such as we have already
seen for \<open>horizontal_composite_of_arrows_of_tabulations_in_maps.prj_chine\<close>.
\<close>
define u\<^sub>f where "u\<^sub>f = g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
define w\<^sub>f where "w\<^sub>f = Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1"
define w\<^sub>f' where "w\<^sub>f' = TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
define \<theta>\<^sub>f
where "\<theta>\<^sub>f = (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot> (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot> (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> (f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
define \<theta>\<^sub>f'
where "\<theta>\<^sub>f' = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]"
define \<beta>\<^sub>f
where "\<beta>\<^sub>f = \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
have w\<^sub>f: "ide w\<^sub>f"
using w\<^sub>f_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
have w\<^sub>f_is_map: "is_left_adjoint w\<^sub>f"
using w\<^sub>f_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
by (simp add: left_adjoints_compose)
have w\<^sub>f': "ide w\<^sub>f'"
unfolding w\<^sub>f'_def by simp
have w\<^sub>f'_is_map: "is_left_adjoint w\<^sub>f'"
unfolding w\<^sub>f'_def
using 3 TTfgh_TfTgh.is_map f\<^sub>0gh\<^sub>1.leg1_is_map
by (simp add: left_adjoints_compose)
have \<theta>\<^sub>f: "\<guillemotleft>\<theta>\<^sub>f : tab\<^sub>0 f \<star> w\<^sub>f \<Rightarrow> u\<^sub>f\<guillemotright>"
proof (unfold \<theta>\<^sub>f_def w\<^sub>f_def u\<^sub>f_def, intro comp_in_homI)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using f\<^sub>0g\<^sub>1.leg1_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan by auto
show "\<guillemotleft>f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1 :
(tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using f\<^sub>0g\<^sub>1.\<phi>_in_hom(2) Tfg.\<rho>\<sigma>.T0.antipar(1)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>(g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 :
(tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> ((g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using Tfg.\<rho>\<sigma>.T0.antipar(1)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1 :
((g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (g \<star> tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
(g \<star> tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> g \<star> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
show "\<guillemotleft>g \<star> fg\<^sub>0h\<^sub>1.\<phi> : g \<star> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> g \<star> tab\<^sub>1 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
using fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>g \<star> h.tab \<star> TTfgh.p\<^sub>0 : g \<star> tab\<^sub>1 h \<star> TTfgh.p\<^sub>0 \<Rightarrow> g \<star> (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0\<guillemotright>"
using gh fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] :
g \<star> (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0 \<Rightarrow> g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
using gh fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
by (intro hcomp_in_vhom, auto)
qed
have \<theta>\<^sub>f': "\<guillemotleft>\<theta>\<^sub>f' : tab\<^sub>0 f \<star> w\<^sub>f' \<Rightarrow> u\<^sub>f\<guillemotright>"
proof (unfold \<theta>\<^sub>f'_def w\<^sub>f'_def u\<^sub>f_def, intro comp_in_homI)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<Rightarrow> (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using "1" "2" "3" "4" assoc'_in_hom(2) f.ide_u f.leg1_simps(3) by auto
show "\<guillemotleft>f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine :
(tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine \<Rightarrow>
((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.\<phi>_in_hom(2)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> (((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>(\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
(((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> ((g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
((g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> ((g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan g\<^sub>0h\<^sub>1.\<phi>_in_hom(2)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
((g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> ((g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) :
((g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> g \<star> h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan by auto
show "\<guillemotleft>g \<star> h \<star> TTfgh_TfTgh.the_\<theta> :
g \<star> h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan TTfgh_TfTgh.the_\<theta>_in_hom
by (intro hcomp_in_vhom, auto)
qed
have \<beta>\<^sub>f: "\<guillemotleft>\<beta>\<^sub>f : tab\<^sub>1 f \<star> w\<^sub>f \<Rightarrow> tab\<^sub>1 f \<star> w\<^sub>f'\<guillemotright>"
proof (unfold \<beta>\<^sub>f_def w\<^sub>f_def w\<^sub>f'_def, intro comp_in_homI)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
tab\<^sub>1 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using TTfgh.leg1_in_hom(2) assoc'_in_hom by auto
show "\<guillemotleft>TTfgh_TfTgh.the_\<nu> :
(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using TTfgh_TfTgh.the_\<nu>_in_hom TTfgh_TfTgh.the_\<nu>_props by simp
show "\<guillemotleft>\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
(tab\<^sub>1 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine \<Rightarrow> tab\<^sub>1 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<guillemotright>"
using 1 2 3 4 by auto
qed
have iso_\<beta>\<^sub>f: "iso \<beta>\<^sub>f"
unfolding \<beta>\<^sub>f_def
using 1 2 3 4 \<beta>\<^sub>f \<beta>\<^sub>f_def isos_compose
apply (intro isos_compose)
apply (metis TTfgh.composable TTfgh.leg1_in_hom(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
Tfg.\<rho>\<sigma>.T0.ide_right Tfg.\<rho>\<sigma>.leg1_in_hom(2) Tfg_Hfg.u_simps(3)
f.T0.antipar(2) f.T0.ide_right f.ide_leg1 f\<^sub>0g\<^sub>1.cospan g.ide_leg1
h.ide_leg1 h.leg1_simps(4) hcomp_in_vhomE ide_hcomp
iso_assoc' tab\<^sub>1_simps(1))
using TTfgh_TfTgh.the_\<nu>_props(2) f.ide_leg1 iso_assoc by blast+
have u\<^sub>f: "ide u\<^sub>f"
using \<theta>\<^sub>f ide_cod by blast
have w\<^sub>f_in_hhom: "in_hhom w\<^sub>f (src u\<^sub>f) (src (tab\<^sub>0 f))"
using u\<^sub>f w\<^sub>f u\<^sub>f_def w\<^sub>f_def by simp
have w\<^sub>f'_in_hhom: "in_hhom w\<^sub>f' (src u\<^sub>f) (src (tab\<^sub>0 f))"
using u\<^sub>f w\<^sub>f' w\<^sub>f'_def u\<^sub>f_def by simp
have 5: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>f \<Rightarrow> w\<^sub>f'\<guillemotright> \<and> \<beta>\<^sub>f = tab\<^sub>1 f \<star> \<gamma> \<and> \<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>)"
proof -
have eq\<^sub>f: "f.composite_cell w\<^sub>f \<theta>\<^sub>f = f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f"
proof -
text \<open>
I don't see any alternative here to just grinding out the calculation.
The idea is to bring \<open>f.composite_cell w\<^sub>f \<theta>\<^sub>f\<close> into a form in which
\<open>src_tab_eq\<close> can be applied to eliminate \<open>\<theta>\<^sub>f\<close> in favor of \<open>\<theta>\<^sub>f'\<close>.
\<close>
have "f.composite_cell w\<^sub>f \<theta>\<^sub>f =
(f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
unfolding w\<^sub>f_def \<theta>\<^sub>f_def
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps Tgh.composable hseqI' whisker_left comp_assoc
by simp (* 20 sec *)
also have "... =
(\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
(f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
proof -
have "(\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
(f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) =
f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_cod_arr comp_assoc_assoc' by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
(f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0] \<cdot>
(f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0)) \<cdot>
(f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
assoc'_naturality [of f g "\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"]
by simp
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>1 h \<star> TTfgh.p\<^sub>0] \<cdot>
(f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>)) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
assoc'_naturality [of f g "h.tab \<star> TTfgh.p\<^sub>0"]
by simp
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1]) \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
assoc'_naturality [of f g fg\<^sub>0h\<^sub>1.\<phi>]
by simp
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
proof -
have "(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot> \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] =
\<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot> \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] =
\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
\<a>'_def \<alpha>_def
by simp
also have "... =
\<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
by (intro E.eval_eqI, simp_all)
also have "... = \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
\<a>'_def \<alpha>_def
by simp
finally show ?thesis by blast
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
proof -
have "(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] =
\<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom hseqI'
assoc_naturality [of f f\<^sub>0g\<^sub>1.\<phi> TTfgh.p\<^sub>1]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
proof -
have "(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] =
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom hseqI'
assoc_naturality [of f "g.tab \<star> Tfg.p\<^sub>0" TTfgh.p\<^sub>1]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps assoc'_naturality [of f.tab Tfg.p\<^sub>1 TTfgh.p\<^sub>1] comp_assoc
by simp
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1)) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "(((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) =
(f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_cod_arr whisker_right comp_assoc_assoc'
whisker_left [of f "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]" "\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]"]
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
(((\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "((\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) =
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1"
using fg fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_cod_arr comp_assoc_assoc'
whisker_right
[of TTfgh.p\<^sub>1 "\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0]" "\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0]"]
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
((\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1)) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1)
\<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
whisker_right comp_assoc
by simp
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1)
\<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>)\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
\<a>'_def \<alpha>_def
by simp
also have "... = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
by (intro E.eval_eqI, auto)
also have "... = \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
\<a>'_def \<alpha>_def
by simp
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1)
\<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "(\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) =
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
comp_cod_arr comp_assoc_assoc'
by simp
thus ?thesis by simp
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
(f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
(f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
(f.tab \<star> Tfg.p\<^sub>1)
\<star> TTfgh.p\<^sub>1)) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
TTfgh.tab \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using TTfgh.tab_def Tfg.\<rho>\<sigma>.tab_def by simp
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<cdot>
(g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> Tgh.p\<^sub>0) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1)
\<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1)
\<star> TTfgh_TfTgh.chine) \<cdot>
TTfgh_TfTgh.the_\<nu>) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using src_tab_eq TfTgh.tab_def Tgh.\<rho>\<sigma>.tab_def comp_assoc by simp
text \<open>Now we have to make this look like \<open>f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f\<close>.\<close>
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>)) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1)
\<star> TTfgh_TfTgh.chine) \<cdot>
TTfgh_TfTgh.the_\<nu>) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<cdot>
(g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> Tgh.p\<^sub>0) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1)
\<star> TfTgh.p\<^sub>0 =
(f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0)"
using fg gh hseqI' whisker_right whisker_left by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1)
\<star> TTfgh_TfTgh.chine =
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine)"
proof -
have "arr (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using fg gh hseqI'
by (intro seqI' comp_in_homI, auto)
(*
* TODO: Find a way to generate the following consequences automatically
* without having to list them.
*)
moreover
have "arr ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
moreover
have "arr (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1))"
using calculation by blast
ultimately show ?thesis
using whisker_right by auto
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
(((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
(f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
comp_arr_dom comp_assoc_assoc'
by simp
thus ?thesis by simp
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
(((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using comp_assoc by presburger
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
assoc'_naturality [of f.tab TfTgh.p\<^sub>1 TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
((\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine)) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "(\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) =
f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
comp_cod_arr comp_assoc_assoc'
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
using comp_assoc by presburger
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
proof -
have "(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] =
\<lbrace>(\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using \<a>'_def \<alpha>_def by simp
also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>])\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
by (intro E.eval_eqI, auto)
also have "... = \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using \<a>'_def \<alpha>_def by simp
finally show ?thesis by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
proof -
(*
* This one can't be shortcut with a straight coherence-based proof,
* due to the presence of f\<^sub>0gh\<^sub>1.\<phi>, g\<^sub>0h\<^sub>1.\<phi>, h.tab, with associativities that
* do not respect their domain and codomain.
*
* I also tried to avoid distributing the "f \<star>" in advance, in order to
* reduce the number of associativity proof steps, but it then becomes
* less automatic to prove the necessary "arr" facts to do the proof.
* So unfortunately the mindless grind seems to be the path of least
* resistance.
*)
have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
assoc'_naturality [of f f\<^sub>0gh\<^sub>1.\<phi> TTfgh_TfTgh.chine] comp_assoc
by simp
also have "... =
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
proof -
have "((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
assoc'_naturality [of f "(g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
proof -
have "((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
assoc'_naturality
[of f "\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
proof -
have "((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
assoc'_naturality [of f "(g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
(((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
proof -
have "((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
assoc'_naturality
[of f "(g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
proof -
(* OK, we can perhaps shortcut the last few steps... *)
have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<lbrace>((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>])
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
\<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
\<a>'_def \<alpha>_def
by simp
also have "... =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
\<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>])
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)\<rbrace>"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
apply (intro E.eval_eqI) by simp_all
also have "... =
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
\<a>'_def \<alpha>_def
by simp
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
finally show ?thesis
- using comp_assoc by simp
- qed
- thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
+ qed
+ thus ?thesis
+ using comp_assoc by presburger
qed
also have "... =
(\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) =
(f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
proof -
have "arr ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using fg gh hseqI'
apply (intro seqI hseqI) by auto
moreover
have "arr ((((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using calculation by blast
moreover
have "arr (((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using calculation by blast
moreover
have "arr ((((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using calculation by blast
moreover
have "arr ((f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using calculation by blast
ultimately show ?thesis
using whisker_left by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
(f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)) \<cdot>
(f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) =
\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
(((f \<star> g) \<star> h) \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
proof -
have "(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) =
\<a>\<^sup>-\<^sup>1[f, g, h] \<star> TTfgh_TfTgh.the_\<theta>"
using fg gh comp_arr_dom comp_cod_arr
interchange [of "\<a>\<^sup>-\<^sup>1[f, g, h]" "f \<star> g \<star> h"
"tab\<^sub>0 h \<star> TTfgh.p\<^sub>0" TTfgh_TfTgh.the_\<theta>]
by simp
also have "... = (((f \<star> g) \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh comp_arr_dom comp_cod_arr
interchange [of "(f \<star> g) \<star> h" "\<a>\<^sup>-\<^sup>1[f, g, h]" TTfgh_TfTgh.the_\<theta>
"((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine"]
by simp
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
(\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
((f \<star> g) \<star> h \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
\<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh assoc_naturality [of "f \<star> g" h TTfgh_TfTgh.the_\<theta>] comp_assoc
by simp
also have "... =
(f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using fg gh hseqI' assoc_naturality [of f g "h \<star> TTfgh_TfTgh.the_\<theta>"] comp_assoc
by simp
finally show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
((f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
(f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
f \<star> can
(\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
proof -
have "\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
\<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>,
\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>,
((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]
\<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
\<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>,
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
\<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star>
\<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)\<rbrace>"
using \<a>'_def \<alpha>_def by simp
also have "... =
can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))"
using fg gh
apply (unfold can_def)
apply (intro E.eval_eqI)
by simp_all
also have "... =
f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
using fg gh whisker_can_left_0 by simp
finally show ?thesis by blast
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... =
(f \<star> (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
(f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
TTfgh_TfTgh.the_\<nu> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
proof -
have "((f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
(f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) =
f \<star> (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]"
proof -
have 1: "arr ((g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using fg gh hseqI'
apply (intro seqI' comp_in_homI) by auto
moreover
have 2: "arr (can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
using calculation by blast
ultimately show ?thesis
- using whisker_left 1 2 f.is_ide by simp (* 20 sec *)
- qed
- thus ?thesis
- using comp_assoc by simp
+ using whisker_left f.ide_base by presburger
+ qed
+ thus ?thesis
+ using comp_assoc by presburger
qed
also have "... = f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f"
unfolding w\<^sub>f'_def \<theta>\<^sub>f'_def \<beta>\<^sub>f_def
- using comp_assoc by simp
+ using comp_assoc by presburger
finally show ?thesis by blast
qed
show ?thesis
using w\<^sub>f w\<^sub>f' \<theta>\<^sub>f \<theta>\<^sub>f' \<beta>\<^sub>f f.T2 [of w\<^sub>f w\<^sub>f' \<theta>\<^sub>f u\<^sub>f \<theta>\<^sub>f' \<beta>\<^sub>f] eq\<^sub>f by fast
qed
obtain \<gamma>\<^sub>f where \<gamma>\<^sub>f: "\<guillemotleft>\<gamma>\<^sub>f : w\<^sub>f \<Rightarrow> w\<^sub>f'\<guillemotright> \<and> \<beta>\<^sub>f = tab\<^sub>1 f \<star> \<gamma>\<^sub>f \<and> \<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f)"
using 5 by auto
show "\<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
have "iso \<gamma>\<^sub>f"
using \<gamma>\<^sub>f BS3 w\<^sub>f_is_map w\<^sub>f'_is_map by blast
hence "isomorphic w\<^sub>f w\<^sub>f'"
using \<gamma>\<^sub>f isomorphic_def isomorphic_symmetric by auto
thus ?thesis
using w\<^sub>f w\<^sub>f_def w\<^sub>f'_def Maps.CLS_eqI isomorphic_symmetric by auto
qed
text \<open>
On to the next equation:
\[
\<open>\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>\<close>.
\]
We have to make use of the equation \<open>\<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f)\<close> in this part,
similarly to how the equation \<open>src_tab_eq\<close> was used to replace
\<open>TTfgh.tab\<close> in the first part.
\<close>
define u\<^sub>g where "u\<^sub>g = h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
define w\<^sub>g where "w\<^sub>g = Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1"
define w\<^sub>g' where "w\<^sub>g' = Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
define \<theta>\<^sub>g
where "\<theta>\<^sub>g = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
define \<theta>\<^sub>g'
where "\<theta>\<^sub>g' = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
define \<beta>\<^sub>g
where "\<beta>\<^sub>g = \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot> \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
have u\<^sub>g: "ide u\<^sub>g"
unfolding u\<^sub>g_def by simp
have w\<^sub>g: "ide w\<^sub>g"
unfolding w\<^sub>g_def using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
have w\<^sub>g_is_map: "is_left_adjoint w\<^sub>g"
unfolding w\<^sub>g_def
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps left_adjoints_compose by simp
have w\<^sub>g': "ide w\<^sub>g'"
unfolding w\<^sub>g'_def by simp
have w\<^sub>g'_is_map: "is_left_adjoint w\<^sub>g'"
unfolding w\<^sub>g'_def
using TTfgh_TfTgh.is_map left_adjoints_compose by simp
have \<theta>\<^sub>g: "\<guillemotleft>\<theta>\<^sub>g : tab\<^sub>0 g \<star> w\<^sub>g \<Rightarrow> u\<^sub>g\<guillemotright>"
unfolding w\<^sub>g_def u\<^sub>g_def \<theta>\<^sub>g_def
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps fg\<^sub>0h\<^sub>1.\<phi>_in_hom
apply (intro comp_in_homI) by auto
have \<theta>\<^sub>g': "\<guillemotleft>\<theta>\<^sub>g' : tab\<^sub>0 g \<star> w\<^sub>g' \<Rightarrow> u\<^sub>g\<guillemotright>"
unfolding w\<^sub>g'_def u\<^sub>g_def \<theta>\<^sub>g'_def
using fg\<^sub>0h\<^sub>1.p\<^sub>0_simps
apply (intro comp_in_homI)
apply auto
apply auto
by fastforce+
have w\<^sub>g_in_hhom: "in_hhom w\<^sub>g (src u\<^sub>g) (src (tab\<^sub>0 g))"
unfolding w\<^sub>g_def u\<^sub>g_def by auto
have w\<^sub>g'_in_hhom: "in_hhom w\<^sub>g' (src u\<^sub>g) (src (tab\<^sub>0 g))"
unfolding w\<^sub>g'_def u\<^sub>g_def by auto
have \<beta>\<^sub>g: "\<guillemotleft>\<beta>\<^sub>g : tab\<^sub>1 g \<star> w\<^sub>g \<Rightarrow> tab\<^sub>1 g \<star> w\<^sub>g'\<guillemotright>"
proof (unfold \<beta>\<^sub>g_def w\<^sub>g_def, intro comp_in_homI)
(* auto can solve this, but it's too slow *)
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
tab\<^sub>1 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
show "\<guillemotleft>inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1 :
(tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom f\<^sub>0g\<^sub>1.\<phi>_uniqueness(2) by auto
show "\<guillemotleft>\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
(tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps \<gamma>\<^sub>f w\<^sub>f_def w\<^sub>f'_def by auto
show "\<guillemotleft>tab\<^sub>0 f \<star> \<gamma>\<^sub>f : tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps \<gamma>\<^sub>f w\<^sub>f_def w\<^sub>f'_def by auto
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<Rightarrow> (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
by auto
show "\<guillemotleft>f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine :
(tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine
\<Rightarrow> ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
using f\<^sub>0gh\<^sub>1.\<phi>_in_hom by auto
show "\<guillemotleft>\<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] :
((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
\<Rightarrow> (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
by auto
show "\<guillemotleft>\<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
(tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine \<Rightarrow> tab\<^sub>1 g \<star> w\<^sub>g'\<guillemotright>"
using w\<^sub>g'_def by auto
qed
have eq\<^sub>g: "g.composite_cell w\<^sub>g \<theta>\<^sub>g = g.composite_cell w\<^sub>g' \<theta>\<^sub>g' \<cdot> \<beta>\<^sub>g"
proof -
have "g.composite_cell w\<^sub>g \<theta>\<^sub>g =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot>
(h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
fg\<^sub>0h\<^sub>1.\<phi> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1] \<cdot>
(g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
unfolding w\<^sub>g_def \<theta>\<^sub>g_def by simp
also have "... =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
((g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]) \<cdot>
(g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
using fg gh f\<^sub>0g\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' whisker_left
comp_assoc
by simp
also have "... =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
(\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]))) \<cdot>
\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1] \<cdot>
(g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
proof -
have "(\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) =
g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr hseqI' comp_assoc_assoc' by simp
thus ?thesis
by (simp add: comp_assoc)
qed
also have "... =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]) \<cdot>
(g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1))"
using fg gh f\<^sub>0g\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
fg\<^sub>0h\<^sub>1.p\<^sub>1_simps pentagon' iso_inv_iso
invert_opposite_sides_of_square
[of "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1"
"(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1])"
"\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]" "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]"]
by simp
also have "... =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps assoc'_naturality [of g.tab Tfg.p\<^sub>0 TTfgh.p\<^sub>1] by simp
also have "... =
(g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
(g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
(g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
(\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
proof -
have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] =
((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
((tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps whisker_right comp_assoc_assoc' by simp
also have "... = ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_uniqueness hseqI' comp_cod_arr by simp
also have "... = ((tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
proof -
have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) =
f\<^sub>0g\<^sub>1.\<phi> \<cdot> inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1"
using f\<^sub>0g\<^sub>1.\<phi>_uniqueness whisker_right by simp
also have "... = (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1"
using f\<^sub>0g\<^sub>1.\<phi>_uniqueness comp_arr_inv' by simp
finally show ?thesis by simp
qed
also have "... = \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr by simp
finally have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] = \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<theta>\<^sub>f \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
- unfolding \<theta>\<^sub>f_def using comp_assoc by simp
+ unfolding \<theta>\<^sub>f_def using comp_assoc by presburger
also have "... = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
using \<gamma>\<^sub>f comp_assoc by simp
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
- unfolding \<theta>\<^sub>f'_def using comp_assoc by simp
+ unfolding \<theta>\<^sub>f'_def using comp_assoc by presburger
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
(inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
proof -
have "(\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
(f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) =
f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine"
using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_cod_arr comp_arr_dom comp_assoc_assoc' by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<beta>\<^sub>g"
unfolding \<beta>\<^sub>g_def using comp_assoc by presburger
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<beta>\<^sub>g"
proof -
have "(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
assoc'_naturality [of "(g.tab \<star> Tgh.p\<^sub>1)" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<beta>\<^sub>g"
proof -
have "((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
assoc'_naturality [of g.tab Tgh.p\<^sub>1 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
((\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
\<beta>\<^sub>g"
proof -
have "(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
using hseqI' comp_cod_arr comp_assoc_assoc' by simp
thus ?thesis
using comp_assoc g\<^sub>0h\<^sub>1.\<phi>_in_hom by simp
qed
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
((\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
\<beta>\<^sub>g"
proof -
have "(\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
(\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((g \<star> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1)) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_assoc comp_assoc_assoc' by simp
also have "... = (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_cod_arr comp_assoc_assoc' by simp
also have "... = (((g \<star> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1)) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' whisker_right comp_assoc_assoc' by simp
also have "... = (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine"
using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_cod_arr by simp
- finally show ?thesis by simp
+ finally show ?thesis by presburger
qed
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
\<beta>\<^sub>g"
using comp_assoc by presburger
also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<beta>\<^sub>g"
proof -
have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
proof -
have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
((((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
proof -
have "(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
assoc'_naturality [of "g \<star> g\<^sub>0h\<^sub>1.\<phi>" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
proof -
have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
assoc'_naturality [of "g \<star> h.tab \<star> Tgh.p\<^sub>0" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
proof -
have "((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
assoc'_naturality [of g g\<^sub>0h\<^sub>1.\<phi> "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
proof -
have "((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
assoc'_naturality [of g "h.tab \<star> Tgh.p\<^sub>0" "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
finally show ?thesis by simp
qed
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = ((g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
(g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])) \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<beta>\<^sub>g"
proof -
have "can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
proof -
have "\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
can (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
proof -
have "\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' canI_associator_0 \<a>'_def \<alpha>_def by simp
also have "... = can (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
unfolding can_def
using gh
apply (intro E.eval_eqI) by simp_all
finally show ?thesis by blast
qed
moreover
have "\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
can ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
proof -
have "\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' canI_associator_0 \<a>'_def \<alpha>_def by simp
also have "... = can ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
unfolding can_def
using gh
apply (intro E.eval_eqI) by simp_all
finally show ?thesis by blast
qed
ultimately show ?thesis
using gh whisker_can_left_0 by simp
qed
moreover have "\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
proof -
have "\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
\<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
((\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[(\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' \<a>'_def \<alpha>_def by simp
also have "... = \<lbrace>\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
apply (intro E.eval_eqI) by simp_all
also have "... = g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' \<a>'_def \<alpha>_def by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (g \<star>
(h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
\<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<beta>\<^sub>g"
proof -
have "arr ((h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
apply (intro seqI) by auto
moreover
have "arr ((can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
using calculation by blast
moreover
have "arr (((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
using calculation by blast
moreover
have "arr ((g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
using calculation by blast
ultimately
have "(g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
(g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
g \<star>
(h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
using whisker_left by simp (* 20 sec *)
thus ?thesis by simp
qed
also have "... = g.composite_cell w\<^sub>g' \<theta>\<^sub>g' \<cdot> \<beta>\<^sub>g"
unfolding w\<^sub>g'_def \<theta>\<^sub>g'_def
- using comp_assoc by simp
+ using comp_assoc by presburger
finally show ?thesis by simp
qed
have 6: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>g \<Rightarrow> w\<^sub>g'\<guillemotright> \<and> \<beta>\<^sub>g = tab\<^sub>1 g \<star> \<gamma> \<and> \<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>)"
using w\<^sub>g w\<^sub>g' \<theta>\<^sub>g \<theta>\<^sub>g' \<beta>\<^sub>g eq\<^sub>g g.T2 [of w\<^sub>g w\<^sub>g' \<theta>\<^sub>g u\<^sub>g \<theta>\<^sub>g' \<beta>\<^sub>g] by blast
obtain \<gamma>\<^sub>g where \<gamma>\<^sub>g: "\<guillemotleft>\<gamma>\<^sub>g : w\<^sub>g \<Rightarrow> w\<^sub>g'\<guillemotright> \<and> \<beta>\<^sub>g = tab\<^sub>1 g \<star> \<gamma>\<^sub>g \<and> \<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)"
using 6 by auto
show "\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
proof -
have "iso \<gamma>\<^sub>g"
using \<gamma>\<^sub>g BS3 w\<^sub>g_is_map w\<^sub>g'_is_map by blast
hence "isomorphic w\<^sub>g w\<^sub>g'"
using \<gamma>\<^sub>g isomorphic_def isomorphic_symmetric by auto
thus ?thesis
using w\<^sub>g w\<^sub>g' w\<^sub>g_def w\<^sub>g'_def Maps.CLS_eqI by auto
qed
text \<open>Now the last equation: similar, but somewhat simpler.\<close>
define u\<^sub>h where "u\<^sub>h = tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
define w\<^sub>h where "w\<^sub>h = TTfgh.p\<^sub>0"
define w\<^sub>h' where "w\<^sub>h' = Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
define \<theta>\<^sub>h
where "\<theta>\<^sub>h = tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
define \<theta>\<^sub>h'
where "\<theta>\<^sub>h' = TTfgh_TfTgh.the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
define \<beta>\<^sub>h
where "\<beta>\<^sub>h = \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
have u\<^sub>h: "ide u\<^sub>h"
unfolding u\<^sub>h_def by simp
have w\<^sub>h: "ide w\<^sub>h"
unfolding w\<^sub>h_def by simp
have w\<^sub>h_is_map: "is_left_adjoint w\<^sub>h"
unfolding w\<^sub>h_def by simp
have w\<^sub>h': "ide w\<^sub>h'"
unfolding w\<^sub>h'_def by simp
have w\<^sub>h'_is_map: "is_left_adjoint w\<^sub>h'"
unfolding w\<^sub>h'_def
using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps TTfgh_TfTgh.is_map left_adjoints_compose by simp
have \<theta>\<^sub>h: "\<guillemotleft>\<theta>\<^sub>h : tab\<^sub>0 h \<star> w\<^sub>h \<Rightarrow> u\<^sub>h\<guillemotright>"
unfolding \<theta>\<^sub>h_def w\<^sub>h_def u\<^sub>h_def by auto
have \<theta>\<^sub>h': "\<guillemotleft>\<theta>\<^sub>h' : tab\<^sub>0 h \<star> w\<^sub>h' \<Rightarrow> u\<^sub>h\<guillemotright>"
unfolding \<theta>\<^sub>h'_def w\<^sub>h'_def u\<^sub>h_def
using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
by (intro comp_in_homI, auto)
have \<beta>\<^sub>h: "\<guillemotleft>\<beta>\<^sub>h : tab\<^sub>1 h \<star> w\<^sub>h \<Rightarrow> tab\<^sub>1 h \<star> w\<^sub>h'\<guillemotright>"
proof (unfold \<beta>\<^sub>h_def w\<^sub>h_def w\<^sub>h'_def, intro comp_in_homI)
(* auto can solve this, but it's too slow *)
show "\<guillemotleft>inv fg\<^sub>0h\<^sub>1.\<phi> : tab\<^sub>1 h \<star> TTfgh.p\<^sub>0 \<Rightarrow> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.\<phi>_uniqueness by blast
show "\<guillemotleft>\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
(tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
show "\<guillemotleft>tab\<^sub>0 g \<star> \<gamma>\<^sub>g :
tab\<^sub>0 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 g \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
using \<gamma>\<^sub>g w\<^sub>g_def w\<^sub>g'_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
tab\<^sub>0 g \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
\<Rightarrow> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
show "\<guillemotleft>g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine :
(tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
\<Rightarrow> (tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by force
show "\<guillemotleft>\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
(tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
\<Rightarrow> tab\<^sub>1 h \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
qed
have eq\<^sub>h: "h.composite_cell w\<^sub>h \<theta>\<^sub>h = h.composite_cell w\<^sub>h' \<theta>\<^sub>h' \<cdot> \<beta>\<^sub>h"
proof -
text \<open>
Once again, the strategy is to form the subexpression
\[
\<open>\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]\<close>
\]
which is equal to \<open>\<theta>\<^sub>g\<close>, so that we can make use of the equation \<open>\<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)\<close>.
\<close>
have "h.composite_cell w\<^sub>h \<theta>\<^sub>h =
(h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0)"
unfolding w\<^sub>h_def \<theta>\<^sub>h_def by simp
also have "... = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0)"
proof -
have "(h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"
using comp_cod_arr by simp
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
fg\<^sub>0h\<^sub>1.\<phi> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
proof -
have "(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi> =
(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> ((tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc_assoc' by simp
also have "... = (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' fg\<^sub>0h\<^sub>1.\<phi>_uniqueness comp_cod_arr by simp
also have "... = (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> (tab\<^sub>1 h \<star> TTfgh.p\<^sub>0)"
using comp_arr_inv' fg\<^sub>0h\<^sub>1.\<phi>_uniqueness by simp
also have "... = h.tab \<star> TTfgh.p\<^sub>0"
using comp_arr_dom fg\<^sub>0h\<^sub>1.p\<^sub>0_simps hseqI' by simp
finally have "(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi> =
h.tab \<star> TTfgh.p\<^sub>0"
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<theta>\<^sub>g \<cdot> \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
unfolding \<theta>\<^sub>g_def by simp
also have "... = (\<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)) \<cdot> \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
using \<gamma>\<^sub>g by simp
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
unfolding \<theta>\<^sub>g'_def
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
((\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
proof -
have "(\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
(h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
using comp_cod_arr hseqI' comp_assoc_assoc' by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(\<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
using comp_assoc by presburger
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
using assoc_naturality [of h.tab Tgh.p\<^sub>0 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"] comp_assoc
by simp
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
((\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
proof -
have "(\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
using comp_cod_arr hseqI' comp_assoc_assoc' by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])) \<cdot>
\<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
using comp_assoc by presburger
also have "... = ((h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
(h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))) \<cdot>
\<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
proof -
have "can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
using \<a>'_def \<alpha>_def by simp
also have "... = can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
can (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
proof -
have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace> =
can (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
unfolding can_def
apply (intro E.eval_eqI) by simp_all
thus ?thesis by simp
qed
also have "... = can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
by simp
also have "... = h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
using whisker_can_left_0 by simp
finally have "can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
(\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
by simp
thus ?thesis
- using comp_assoc by simp
+ using comp_assoc by presburger
qed
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta> \<cdot>
can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
\<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
using whisker_left [of h] comp_assoc by simp
also have "... = (h \<star> TTfgh_TfTgh.the_\<theta> \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
\<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
(tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
inv fg\<^sub>0h\<^sub>1.\<phi>"
proof -
have "can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def
apply (intro E.eval_eqI) by auto
also have "... = \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
using \<a>'_def \<alpha>_def by simp
finally have "can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
(\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) =
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
\<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
by simp
thus ?thesis by simp
qed
also have "... = h.composite_cell w\<^sub>h' \<theta>\<^sub>h' \<cdot> \<beta>\<^sub>h"
unfolding w\<^sub>h'_def \<theta>\<^sub>h'_def \<beta>\<^sub>h_def
- using comp_assoc by simp
+ using comp_assoc by presburger
finally show ?thesis by simp
qed
have 7: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>h \<Rightarrow> w\<^sub>h'\<guillemotright> \<and> \<beta>\<^sub>h = tab\<^sub>1 h \<star> \<gamma> \<and> \<theta>\<^sub>h = \<theta>\<^sub>h' \<cdot> (tab\<^sub>0 h \<star> \<gamma>)"
using w\<^sub>h w\<^sub>h' \<theta>\<^sub>h \<theta>\<^sub>h' \<beta>\<^sub>h eq\<^sub>h h.T2 [of w\<^sub>h w\<^sub>h' \<theta>\<^sub>h u\<^sub>h \<theta>\<^sub>h' \<beta>\<^sub>h] by blast
obtain \<gamma>\<^sub>h where \<gamma>\<^sub>h: "\<guillemotleft>\<gamma>\<^sub>h : w\<^sub>h \<Rightarrow> w\<^sub>h'\<guillemotright> \<and> \<beta>\<^sub>h = tab\<^sub>1 h \<star> \<gamma>\<^sub>h \<and> \<theta>\<^sub>h = \<theta>\<^sub>h' \<cdot> (tab\<^sub>0 h \<star> \<gamma>\<^sub>h)"
using 7 by auto
show "\<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
proof -
have "iso \<gamma>\<^sub>h"
using \<gamma>\<^sub>h BS3 w\<^sub>h_is_map w\<^sub>h'_is_map by blast
hence "isomorphic w\<^sub>h w\<^sub>h'"
using \<gamma>\<^sub>h isomorphic_def isomorphic_symmetric by auto
thus ?thesis
using w\<^sub>h w\<^sub>h' w\<^sub>h_def w\<^sub>h'_def Maps.CLS_eqI [of w\<^sub>h w\<^sub>h'] by simp
qed
qed
text \<open>
Finally, we can show that @{term TTfgh_TfTgh.chine} is given by tupling.
\<close>
lemma CLS_chine:
shows "\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = tuple_ABC"
proof -
have "tuple_ABC = SPN_fgh.chine_assoc"
using SPN_fgh.chine_assoc_def by simp
also have "... = \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof (intro Maps.arr_eqI)
show "Maps.arr SPN_fgh.chine_assoc"
using SPN_fgh.chine_assoc_in_hom by auto
show "Maps.arr \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using Maps.CLS_in_hom TTfgh_TfTgh.is_map by blast
show "Maps.Dom SPN_fgh.chine_assoc = Maps.Dom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using SPN_fgh.chine_assoc_def Maps.dom_char tuple_ABC_in_hom TTfgh_TfTgh.chine_in_hom
by fastforce
show "Maps.Cod SPN_fgh.chine_assoc = Maps.Cod \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have "Maps.Cod SPN_fgh.chine_assoc = Maps.Cod tuple_ABC"
using SPN_fgh.chine_assoc_def by simp
also have "... = src (prj\<^sub>0 (tab\<^sub>1 g \<star> prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)) (tab\<^sub>0 f))"
by (metis (lifting) Maps.Dom.simps(1) Maps.seq_char SPN_fgh.prj_chine_assoc(1)
SPN_fgh.prj_simps(1) calculation f\<^sub>0gh\<^sub>1.leg1_simps(3) prj_char(4))
also have "... = Maps.Cod \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using Maps.cod_char TTfgh_TfTgh.chine_in_hom by simp
finally show ?thesis by blast
qed
show "Maps.Map SPN_fgh.chine_assoc = Maps.Map \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have 0: "Chn (Span.hcomp (SPN f) (Span.hcomp (SPN g) (SPN h))) =
Maps.MkIde (src TfTgh.p\<^sub>0)"
using fg gh
by (metis (mono_tags, lifting) Maps.in_homE Maps.seqE SPN_fgh.prj_chine_assoc(1)
SPN_fgh.prj_simps(1) SPN_fgh.prj_simps(13) calculation tuple_ABC_in_hom)
have "tuple_ABC = \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof (intro Maps.prj_joint_monic
[of SPN_fgh.\<mu>.leg0 "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1"
tuple_ABC "\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"])
show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using SPN_fgh.\<nu>\<pi>.dom.is_span SPN_fgh.\<nu>\<pi>.leg1_composite SPN_fgh.cospan_\<mu>\<nu>
by auto
show "Maps.seq SPN_fgh.Prj\<^sub>1 tuple_ABC"
using 0 tuple_ABC_in_hom SPN_fgh.prj_in_hom(4) by auto
show "Maps.seq SPN_fgh.Prj\<^sub>1 \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof
show "Maps.in_hom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh TTfgh_TfTgh.chine_in_hom Maps.CLS_in_hom TTfgh_TfTgh.is_map
by blast
show "Maps.in_hom SPN_fgh.Prj\<^sub>1 \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> SPN_fgh.\<mu>.apex"
proof
show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using SPN_fgh.prj_in_hom(4) by blast
show "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
proof -
have "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = Maps.MkIde (src TfTgh.p\<^sub>0)"
by simp
also have "... = Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using 0 Maps.pbdom_def SPN_fgh.chine_composite(2) by presburger
finally show ?thesis by blast
qed
show "SPN_fgh.\<mu>.apex = Maps.dom SPN_fgh.\<mu>.leg0"
using SPN_f.dom.apex_def by blast
qed
qed
have 2: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
proof
show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
using SPN_fgh.prj_simps(2-3,5-6) by presburger
show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
by auto
show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
qed
have 1: "Maps.commutative_square
SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
proof
show "Maps.cospan SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using fg gh SPN_fgh.prj_simps(10) by blast
show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
using fg gh csq(2) by blast
show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 =
(SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
using 2 fg gh Maps.comp_assoc csq(2)
Maps.prj_tuple [of SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0]
by blast
qed
show "SPN_fgh.Prj\<^sub>1 \<odot> tuple_ABC = SPN_fgh.Prj\<^sub>1 \<odot> Maps.CLS TTfgh_TfTgh.chine"
proof -
have "SPN_fgh.Prj\<^sub>1 \<odot> tuple_ABC = SPN_fgh.Prj\<^sub>1\<^sub>1"
using csq(2) by simp
also have "... = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
using prj_char by simp
also have "... = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using prj_chine(1) by simp
also have "... = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint TfTgh.p\<^sub>1"
by (simp add: fg)
moreover have "is_left_adjoint TTfgh_TfTgh.chine"
using TTfgh_TfTgh.is_map by simp
moreover have "TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<cong> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
using fg gh isomorphic_reflexive by simp
ultimately show ?thesis
using Maps.comp_CLS
[of TfTgh.p\<^sub>1 TTfgh_TfTgh.chine "TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"]
by simp
qed
finally show ?thesis
using prj_char by simp
qed
show
"Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_ABC =
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have
"Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_ABC =
tuple_BC"
using csq(2)
Maps.prj_tuple [of SPN_fgh.\<mu>.leg0 "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1"
SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC]
by simp
also have "... =
Maps.comp
(Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1))
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof (intro Maps.prj_joint_monic
[of SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 tuple_BC
"Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"])
show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
show "Maps.seq SPN_fgh.\<nu>\<pi>.prj\<^sub>1 tuple_BC"
proof
show "Maps.in_hom tuple_BC
(Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.p\<^sub>0))"
using tuple_BC_in_hom by simp
show "Maps.in_hom SPN_fgh.\<nu>\<pi>.prj\<^sub>1 (Maps.MkIde (src Tgh.p\<^sub>0)) SPN_fgh.\<nu>.apex"
proof -
have "Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 = Maps.MkIde (src Tgh.p\<^sub>0)"
using fg gh Maps.pbdom_def
by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tgh.chine_hcomp_SPN_SPN
g.is_ide)
thus ?thesis
using SPN_fgh.\<nu>\<pi>.prj_in_hom(1) by simp
qed
qed
show "Maps.seq SPN_fgh.\<nu>\<pi>.prj\<^sub>1
(Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>)"
proof
show "Maps.in_hom SPN_fgh.\<nu>\<pi>.prj\<^sub>1
(Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1) SPN_fgh.\<nu>.apex"
using SPN_fgh.\<nu>\<pi>.prj_in_hom(1) by simp
show "Maps.in_hom
(Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>)
\<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
(Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1)"
proof
show "Maps.in_hom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh TTfgh_TfTgh.chine_in_hom Maps.CLS_in_hom TTfgh_TfTgh.is_map
by blast
show "Maps.in_hom
(Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1))
\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
(Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1)"
proof
show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using SPN_fgh.prj_in_hom(4) by blast
show "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
proof -
have "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = Maps.MkIde (src TfTgh.p\<^sub>0)"
by simp
also have "... = Maps.pbdom SPN_fgh.\<mu>.leg0
(SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using 0 Maps.pbdom_def SPN_fgh.chine_composite(2) by presburger
finally show ?thesis by blast
qed
show "Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 =
Maps.dom (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
using fg gh Maps.pbdom_def SPN_fgh.\<nu>\<pi>.apex_composite
SPN_fgh.\<nu>\<pi>.dom.apex_def SPN_fgh.\<nu>\<pi>.dom.is_span
SPN_fgh.\<nu>\<pi>.leg1_composite
by presburger
qed
qed
qed
show "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot> tuple_BC =
SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot> tuple_BC = SPN_fgh.Prj\<^sub>0"
using csq(1) by simp
also have "... = SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
\<lbrakk>\<lbrakk>Tgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char(1) isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.p\<^sub>1"]
by simp
also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh TTfgh_TfTgh.is_map isomorphic_reflexive
Maps.comp_CLS
[of TfTgh.p\<^sub>0 TTfgh_TfTgh.chine "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh TTfgh_TfTgh.is_map left_adjoints_compose isomorphic_reflexive
Maps.comp_CLS [of Tgh.p\<^sub>0 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
"Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
also have "... = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
using prj_chine(3) by simp
also have "... = SPN_fgh.Prj\<^sub>0"
using prj_char by simp
finally show ?thesis by argo
qed
finally show ?thesis by blast
qed
show "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot> tuple_BC =
SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot> tuple_BC = SPN_fgh.Prj\<^sub>0\<^sub>1"
using csq(1) by simp
also have "... = SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
have "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
\<lbrakk>\<lbrakk>Tgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char(1) isomorphic_reflexive
Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.p\<^sub>1"]
by simp
also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh TTfgh_TfTgh.is_map isomorphic_reflexive
Maps.comp_CLS
[of TfTgh.p\<^sub>0 TTfgh_TfTgh.chine "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh TTfgh_TfTgh.is_map left_adjoints_compose isomorphic_reflexive
Maps.comp_CLS [of Tgh.p\<^sub>1 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
"Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
by simp
also have "... = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
using prj_chine(2) by simp
also have "... = SPN_fgh.Prj\<^sub>0\<^sub>1"
using prj_char by simp
finally show ?thesis by argo
qed
finally show ?thesis by blast
qed
qed
finally show ?thesis by simp
qed
qed
thus ?thesis
using SPN_fgh.chine_assoc_def by simp
qed
qed
finally show ?thesis by simp
qed
text \<open>
At long last, we can show associativity coherence for \<open>SPN\<close>.
\<close>
lemma assoc_coherence:
shows "LHS = RHS"
proof (intro Span.arr_eqI)
show "Span.par LHS RHS"
using par_LHS_RHS by blast
show "Chn LHS = Chn RHS"
proof -
have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
using Chn_LHS_eq by simp
also have "... = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
proof -
have "\<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
\<lbrakk>\<lbrakk>THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
using fg gh isomorphic_reflexive HHfgh_HfHgh.is_map THfgh_HHfgh.is_map
TTfgh_THfgh.is_map left_adjoints_compose
Maps.comp_CLS
[of THfgh_HHfgh.chine TTfgh_THfgh.chine "THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"]
by simp
moreover
have "\<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
\<lbrakk>\<lbrakk>HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
proof -
have "ide (HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
proof -
have "ide (THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
using fg gh HHfgh_HfHgh.is_map THfgh_HHfgh.is_map TTfgh_THfgh.is_map
left_adjoint_is_ide left_adjoints_compose
by auto
moreover have "src HHfgh_HfHgh.chine = trg (THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
using fg gh HHfgh_HfHgh.chine_in_hom \<alpha>_def by auto
ultimately show ?thesis by simp
qed
thus ?thesis
using fg gh isomorphic_reflexive HHfgh_HfHgh.is_map THfgh_HHfgh.is_map
TTfgh_THfgh.is_map left_adjoints_compose
Maps.comp_CLS
[of HHfgh_HfHgh.chine "THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"
"HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"]
by auto
qed
ultimately show ?thesis by argo
qed
also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
proof -
interpret A: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>\<a>[f, g, h]\<close> \<open>f \<star> g \<star> h\<close>
..
interpret B: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
\<open>\<a>[f, g, h]\<close> \<open>f \<star> g \<star> h\<close>
using fg gh by (unfold_locales, auto)
interpret C: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>(f \<star> g) \<star> h\<close> HHfgh.tab \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
\<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
\<open>(f \<star> g) \<star> h\<close> \<open>\<a>[f, g, h]\<close>
using fg gh by (unfold_locales, auto)
interpret D: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
\<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
\<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
\<open>(f \<star> g) \<star> h\<close> \<open>\<a>[f, g, h]\<close>
using fg gh by (unfold_locales, auto)
have "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine \<cong> D.chine"
proof -
have "D.chine \<cong> D.\<pi>.chine \<star> TTfgh_THfgh.chine"
using D.chine_char by simp
also have "... \<cong> C.chine \<star> TTfgh_THfgh.chine"
using fg gh comp_arr_dom isomorphic_reflexive by simp
also have "... \<cong> (C.\<pi>.chine \<star> THfgh_HHfgh.chine) \<star> TTfgh_THfgh.chine"
using C.chine_char hcomp_isomorphic_ide by simp
also have "... \<cong> (HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine) \<star> TTfgh_THfgh.chine"
proof -
have "C.\<pi>.chine = HHfgh_HfHgh.chine"
using fg gh comp_arr_dom comp_cod_arr \<alpha>_def by simp
hence "isomorphic C.\<pi>.chine HHfgh_HfHgh.chine"
using isomorphic_reflexive by simp
thus ?thesis
using hcomp_isomorphic_ide by simp
qed
also have "... \<cong> HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"
proof -
have "ide HHfgh_HfHgh.chine \<and> ide THfgh_HHfgh.chine \<and> ide TTfgh_THfgh.chine"
by simp
moreover have "src HHfgh_HfHgh.chine = trg THfgh_HHfgh.chine \<and>
src THfgh_HHfgh.chine = trg TTfgh_THfgh.chine"
using fg gh HHfgh_HfHgh.chine_in_hom THfgh_HHfgh.chine_in_hom
TTfgh_THfgh.chine_in_hom \<alpha>_def
by auto
ultimately show ?thesis
using fg gh iso_assoc isomorphic_def
assoc_in_hom [of HHfgh_HfHgh.chine THfgh_HHfgh.chine TTfgh_THfgh.chine]
by auto
qed
finally show ?thesis
using isomorphic_symmetric by blast
qed
also have "... \<cong> B.chine"
proof -
have "D.chine = B.chine"
using fg gh comp_arr_dom comp_cod_arr by simp
thus ?thesis
using isomorphic_reflexive by simp
qed
also have "... \<cong> TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
proof -
have "B.chine \<cong> TfHgh_HfHgh.chine \<star> B.\<mu>.chine"
using B.chine_char by simp
also have "... \<cong> TfHgh_HfHgh.chine \<star> A.chine"
using fg gh comp_cod_arr isomorphic_reflexive by simp
also have "... \<cong> TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
using A.chine_char hcomp_ide_isomorphic by simp
finally show ?thesis by blast
qed
finally have "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine \<cong>
TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
by blast
thus ?thesis
using fg gh Maps.CLS_eqI isomorphic_implies_hpar(1) by blast
qed
also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
using fg gh isomorphic_reflexive TfTgh_TfHgh.is_map TfHgh_HfHgh.is_map TTfgh_TfTgh.is_map
left_adjoints_compose
Maps.comp_CLS
[of TfTgh_TfHgh.chine TTfgh_TfTgh.chine "TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"]
Maps.comp_CLS
[of TfHgh_HfHgh.chine "TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
"TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"]
by simp
also have "... = Chn RHS"
using Chn_RHS_eq CLS_chine tuple_ABC_eq_ABC'(2) by simp
finally show ?thesis
by blast
qed
qed
end
subsubsection "SPN is an Equivalence Pseudofunctor"
context bicategory_of_spans
begin
interpretation Maps: maps_category V H \<a> \<i> src trg ..
interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
no_notation Fun.comp (infixl "\<circ>" 55)
notation Span.vcomp (infixr "\<bullet>" 55)
notation Span.hcomp (infixr "\<circ>" 53)
notation Maps.comp (infixr "\<odot>" 55)
notation isomorphic (infix "\<cong>" 50)
interpretation SPN: "functor" V Span.vcomp SPN
using SPN_is_functor by simp
interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
using SPN_is_weak_arrow_of_homs by simp
interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
using SPN.functor_FF by auto
interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
SPN.FF \<open>\<lambda>\<mu>\<nu>. Span.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
..
interpretation SPNoH: composite_functor VV.comp V Span.vcomp
\<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
..
interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
using compositor_is_natural_transformation by simp
interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
HoSPN_SPN.map SPNoH.map \<Phi>.map
using compositor_is_natural_isomorphism by simp
abbreviation \<Phi>
where "\<Phi> \<equiv> \<Phi>.map"
interpretation SPN: pseudofunctor V H \<a> \<i> src trg
Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>
proof
show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
SPN \<a>[f, g, h] \<bullet> \<Phi> (f \<star> g, h) \<bullet> (\<Phi> (f, g) \<circ> SPN h) =
\<Phi> (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi> (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h)"
proof -
fix f g h
assume f: "ide f" and g: "ide g" and h: "ide h"
assume fg: "src f = trg g" and gh: "src g = trg h"
interpret fgh: three_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g h
using f g h fg gh
by (unfold_locales, simp)
show "fgh.LHS = fgh.RHS"
using fgh.assoc_coherence by simp
qed
qed
lemma SPN_is_pseudofunctor:
shows "pseudofunctor V H \<a> \<i> src trg
Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>"
..
interpretation SPN: equivalence_pseudofunctor V H \<a> \<i> src trg
Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>
proof
show "\<And>\<mu> \<mu>'. \<lbrakk>par \<mu> \<mu>'; SPN \<mu> = SPN \<mu>'\<rbrakk> \<Longrightarrow> \<mu> = \<mu>'"
proof -
fix \<mu> \<mu>'
assume par: "par \<mu> \<mu>'"
assume eq: "SPN \<mu> = SPN \<mu>'"
interpret dom_\<mu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close>
using par apply unfold_locales by auto
interpret cod_\<mu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod \<mu>\<close>
using par apply unfold_locales by auto
interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<mu>\<close> \<open>tab_of_ide (dom \<mu>)\<close> \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
\<open>cod \<mu>\<close> \<open>tab_of_ide (cod \<mu>)\<close> \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
\<mu>
using par apply unfold_locales by auto
interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
using par apply unfold_locales by auto
interpret \<mu>': arrow_of_tabulations_in_maps V H \<a> \<i> src trg
\<open>dom \<mu>\<close> \<open>tab_of_ide (dom \<mu>)\<close> \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
\<open>cod \<mu>\<close> \<open>tab_of_ide (cod \<mu>)\<close> \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
\<mu>'
using par apply unfold_locales by auto
interpret \<mu>': arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>'
using par apply unfold_locales by auto
have "\<mu>.chine \<cong> \<mu>'.chine"
using par eq SPN_def spn_def Maps.CLS_eqI \<mu>.is_ide by auto
hence "\<mu>.\<Delta> = \<mu>'.\<Delta>"
using \<mu>.\<Delta>_naturality \<mu>'.\<Delta>_naturality
by (metis \<mu>.\<Delta>_simps(4) \<mu>'.\<Delta>_simps(4) \<mu>.chine_is_induced_map \<mu>'.chine_is_induced_map
\<mu>.induced_map_preserved_by_iso)
thus "\<mu> = \<mu>'"
using par \<mu>.\<mu>_in_terms_of_\<Delta> \<mu>'.\<mu>_in_terms_of_\<Delta> by metis
qed
show "\<And>a'. Span.obj a' \<Longrightarrow> \<exists>a. obj a \<and> Span.equivalent_objects (SPN.map\<^sub>0 a) a'"
proof -
fix a'
assume a': "Span.obj a'"
let ?a = "Maps.Dom (Chn a')"
have a: "obj ?a"
using a' Span.obj_char Span.ide_char Maps.ide_char by blast
moreover have "Span.equivalent_objects (SPN.map\<^sub>0 ?a) a'"
proof -
have "SPN.map\<^sub>0 ?a = a'"
proof (intro Span.arr_eqI)
have "Chn (SPN.map\<^sub>0 ?a) = Chn (Span.src (SPN ?a))"
using a a' by auto
also have "... = Maps.MkIde (Maps.Dom (Chn a'))"
proof -
have "Maps.arr \<lbrakk>\<lbrakk>tab\<^sub>0 (dom (Maps.Dom (Chn a')))\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint (tab\<^sub>0 (dom (Maps.Dom (Chn a'))))"
using a by auto
thus ?thesis
using Maps.CLS_in_hom by auto
qed
moreover have "arr (Maps.Dom (Chn a'))"
using a by auto
moreover have "Span.arr (SPN (Maps.Dom (Chn a')))"
using a a' SPN_in_hom by auto
ultimately show ?thesis
using a a' SPN_def Span.src_def Maps.cod_char by simp
qed
also have "... = Chn a'"
using a' Maps.MkIde_Dom Span.obj_char Span.ide_char by simp
finally show "Chn (SPN.map\<^sub>0 ?a) = Chn a'" by simp
show "Span.par (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) a'"
using a a' Span.obj_char
apply (intro conjI)
using SPN.map\<^sub>0_simps(1) Span.obj_def
apply blast
apply simp
apply (metis (no_types, lifting) SPN.map\<^sub>0_def SPN.preserves_arr Span.obj_src
\<open>Chn (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) = Chn a'\<close> obj_def)
by (metis (no_types, lifting) SPN.map\<^sub>0_def SPN.preserves_arr Span.obj_src
\<open>Chn (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) = Chn a'\<close> obj_def)
qed
thus ?thesis
using Span.equivalent_objects_reflexive
by (simp add: a')
qed
ultimately show "\<exists>a. obj a \<and> Span.equivalent_objects (SPN.map\<^sub>0 a) a'"
by auto
qed
show "\<And>a b g. \<lbrakk>obj a; obj b; Span.in_hhom g (SPN.map\<^sub>0 a) (SPN.map\<^sub>0 b); Span.ide g\<rbrakk>
\<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> Span.isomorphic (SPN f) g"
proof -
fix a b g
assume a: "obj a" and b: "obj b"
and g_in_hhom: "Span.in_hhom g (SPN.map\<^sub>0 a) (SPN.map\<^sub>0 b)"
and ide_g: "Span.ide g"
have arr_a: "arr a"
using a by auto
have arr_b: "arr b"
using b by auto
show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> Span.isomorphic (SPN f) g"
proof -
interpret g: arrow_of_spans Maps.comp g
using ide_g Span.ide_char by blast
interpret g: identity_arrow_of_spans Maps.comp g
using ide_g Span.ide_char
by (unfold_locales, auto)
interpret REP_leg0: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP g.leg0\<close>
using Maps.REP_in_Map [of g.leg0]
by (unfold_locales, auto)
have 0: "\<guillemotleft>Maps.REP g.leg0 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg0\<guillemotright>"
using g.dom.leg_in_hom Maps.REP_in_hhom by force
have 1: "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
using g.dom.leg_in_hom Maps.REP_in_hhom by force
let ?f = "Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*"
have f_in_hhom: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
proof
show "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> b\<guillemotright>"
proof -
have "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
using 1 by simp
moreover have "Maps.Cod g.leg1 = b"
proof -
have "src (Maps.REP g.dtrg) = src (Maps.REP (Leg0 (Dom (SPN.map\<^sub>0 b))))"
using g_in_hhom Span.trg_def [of g] by auto
also have "... = src (Maps.REP (Maps.cod \<lbrakk>\<lbrakk>tab\<^sub>0 b\<rbrakk>\<rbrakk>))"
using b arr_b SPN.map\<^sub>0_def Span.src_def SPN_in_hom by auto
also have "... = src (Maps.REP \<lbrakk>\<lbrakk>trg (tab\<^sub>0 b)\<rbrakk>\<rbrakk>)"
using b Maps.CLS_in_hom [of "tab\<^sub>0 b"] by force
also have "... = src (Maps.REP \<lbrakk>\<lbrakk>b\<rbrakk>\<rbrakk>)"
using b by fastforce
also have "... = b"
using b by auto
finally show ?thesis by simp
qed
ultimately show ?thesis by argo
qed
show "\<guillemotleft>(Maps.REP g.leg0)\<^sup>* : a \<rightarrow> src (Maps.REP g.apex)\<guillemotright>"
proof -
have "\<guillemotleft>Maps.REP g.leg0 : src (Maps.REP g.apex) \<rightarrow> a\<guillemotright>"
proof -
have "src (Maps.REP g.dsrc) = src (Maps.REP (Leg0 (Dom (SPN.map\<^sub>0 a))))"
using g_in_hhom Span.src_def [of g] by auto
also have "... = src (Maps.REP (Maps.cod \<lbrakk>\<lbrakk>tab\<^sub>0 a\<rbrakk>\<rbrakk>))"
using a arr_a SPN.map\<^sub>0_def Span.src_def SPN_in_hom by auto
also have "... = src (Maps.REP \<lbrakk>\<lbrakk>trg (tab\<^sub>0 a)\<rbrakk>\<rbrakk>)"
using a Maps.CLS_in_hom [of "tab\<^sub>0 a"] by force
also have "... = src (Maps.REP \<lbrakk>\<lbrakk>a\<rbrakk>\<rbrakk>)"
using a by fastforce
also have "... = a"
using a by auto
finally show ?thesis by fast
qed
thus ?thesis
using REP_leg0.antipar REP_leg0.ide_right
apply (intro in_hhomI) by auto
qed
qed
moreover have ide_f: "ide ?f"
using REP_leg0.antipar f_in_hhom by fastforce
moreover have "Span.isomorphic (SPN ?f) g"
proof -
have SPN_f_eq: "SPN ?f = \<lparr>Chn = \<lbrakk>\<lbrakk>spn ?f\<rbrakk>\<rbrakk>,
Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>\<rparr>,
Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>\<rparr>\<rparr>"
using calculation(1) SPN_def [of ?f] REP_leg0.antipar hseqI' by auto
text \<open>
We need an invertible arrow of spans from \<open>SPN f\<close> to \<open>g\<close>.
There exists a tabulation \<open>(REP g.leg0, \<rho>, REP g.leg1)\<close> of \<open>f\<close>.
There is also a tabulation \<open>(tab\<^sub>0 f, \<rho>', tab\<^sub>1 f) of f\<close>.
As these are tabulations of the same arrow, they are equivalent.
This yields an equivalence map which is an arrow of spans from
\<open>(tab\<^sub>0 f, tab\<^sub>1 f)\<close> to \<open>(REP g.leg0, \<rho>, REP g.leg1)\<close>.
Its isomorphism class is an invertible arrow of spans in maps
from \<open>(CLS (tab\<^sub>0 f), CLS (tab\<^sub>1 f))\<close> to \<open>(g.leg0, g.leg1)\<close>.
\<close>
interpret f: identity_in_bicategory_of_spans V H \<a> \<i> src trg ?f
using ide_f apply unfold_locales by auto
interpret f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
?f f.tab \<open>tab\<^sub>0 ?f\<close> \<open>tab\<^sub>1 ?f\<close> ?f f.tab \<open>tab\<^sub>0 ?f\<close> \<open>tab\<^sub>1 ?f\<close> ?f
using f.is_arrow_of_tabulations_in_maps by simp
interpret g: span_of_maps V H \<a> \<i> src trg \<open>Maps.REP g.leg0\<close> \<open>Maps.REP g.leg1\<close>
using Span.arr_char
by (unfold_locales, blast+)
have 2: "src (Maps.REP g.leg0) = src (Maps.REP g.leg1)"
using 0 1 by fastforce
hence "\<exists>\<rho>. tabulation (\<cdot>) (\<star>) \<a> \<i> src trg ?f \<rho> (Maps.REP g.leg0) (Maps.REP g.leg1)"
using BS2' [of "Maps.REP g.leg0" "Maps.REP g.leg1" ?f] isomorphic_reflexive
Span.arr_char
by auto
hence "tabulation V H \<a> \<i> src trg ?f
(REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f) (Maps.REP g.leg0) (Maps.REP g.leg1)"
using 2 REP_leg0.canonical_tabulation [of "Maps.REP g.leg1"] by auto
hence 3: "\<exists>w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
\<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
\<guillemotleft>w' : src (Maps.REP g.leg0) \<rightarrow> src (tab\<^sub>0 ?f)\<guillemotright> \<and>
\<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
\<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
f.tab = (?f \<star> \<theta>) \<cdot> \<a>[?f, Maps.REP g.leg0, w] \<cdot>
(REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f \<star> w) \<cdot> \<nu> \<and>
\<guillemotleft>\<theta>' : tab\<^sub>0 ?f \<star> w' \<Rightarrow> Maps.REP g.leg0\<guillemotright> \<and>
\<guillemotleft>\<nu>' : Maps.REP g.leg1 \<Rightarrow> tab\<^sub>1 ?f \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f =
(?f \<star> \<theta>') \<cdot> \<a>[?f, tab\<^sub>0 ?f, w'] \<cdot> (f.tab \<star> w') \<cdot> \<nu>'"
using f.apex_unique_up_to_equivalence
[of "REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f"
"Maps.REP g.leg0" "Maps.REP g.leg1"]
by simp
obtain w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
where 4: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
\<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
\<guillemotleft>w' : src (Maps.REP g.leg0) \<rightarrow> src (tab\<^sub>0 ?f)\<guillemotright> \<and>
\<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
\<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
f.tab = (?f \<star> \<theta>) \<cdot> \<a>[?f, Maps.REP g.leg0, w] \<cdot>
(REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f \<star> w) \<cdot> \<nu> \<and>
\<guillemotleft>\<theta>' : tab\<^sub>0 ?f \<star> w' \<Rightarrow> Maps.REP g.leg0\<guillemotright> \<and>
\<guillemotleft>\<nu>' : Maps.REP g.leg1 \<Rightarrow> tab\<^sub>1 ?f \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f =
(?f \<star> \<theta>') \<cdot> \<a>[?f, tab\<^sub>0 ?f, w'] \<cdot> (f.tab \<star> w') \<cdot> \<nu>'"
using 3 by meson
hence w\<theta>\<nu>: "equivalence_map w \<and> \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
\<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
\<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu>"
using equivalence_map_def equivalence_pair_def equivalence_pair_symmetric
by meson
let ?W = "\<lparr>Chn = \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>, Dom = Dom (SPN ?f), Cod = Dom g\<rparr>"
have W_in_hom: "Span.in_hom ?W (SPN ?f) g"
proof
have "arrow_of_spans Maps.comp ?W"
proof
interpret Dom_W: span_in_category Maps.comp \<open>Dom ?W\<close>
proof (unfold_locales, intro conjI)
show "Maps.arr (Leg0 (Dom ?W))"
apply (intro Maps.arrI)
apply auto
by (metis f.base_simps(2) f.satisfies_T0 f.u_in_hom src_hcomp')
show "Maps.arr (Leg1 (Dom ?W))"
using 1
apply (intro Maps.arrI)
apply auto
proof -
let ?f = "tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
assume 1: "\<guillemotleft>Maps.REP g.leg1 : Maps.Dom g.apex \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
have "\<guillemotleft>?f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
\<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
is_left_adjoint ?f \<and> \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>?f\<rbrakk>"
using 1 by simp
thus "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
\<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
is_left_adjoint f \<and>
\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>f\<rbrakk>"
by blast
qed
show "Maps.dom (Leg0 (Dom ?W)) = Maps.dom (Leg1 (Dom ?W))"
proof -
have "Maps.dom (Leg0 (Dom ?W)) =
Maps.MkIde (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))"
using Maps.dom_char
apply simp
by (metis (no_types, lifting) Maps.CLS_in_hom Maps.in_homE f.base_simps(2)
f.satisfies_T0 f.u_simps(3) hcomp_simps(1))
also have "... = Maps.dom (Leg1 (Dom ?W))"
using Maps.dom_char Maps.CLS_in_hom f.leg1_is_map f_in_hhom
apply simp
by (metis (no_types, lifting) Maps.in_homE Maps.REP_simps(3) f.base_simps(2)
f.leg1_is_map f.leg1_simps(3) f.leg1_simps(4) g.dom.leg_simps(3)
trg_hcomp')
finally show ?thesis by blast
qed
qed
show "Maps.span (Leg0 (Dom ?W)) (Leg1 (Dom ?W))"
using Dom_W.span_in_category_axioms Dom_W.is_span by blast
interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
apply unfold_locales by fastforce
show "Maps.span (Leg0 (Cod ?W)) (Leg1 (Cod ?W))"
by fastforce
show "Maps.in_hom (Chn ?W) Dom_W.apex Cod_W.apex"
proof
show 1: "Maps.arr (Chn ?W)"
using w\<theta>\<nu> Maps.CLS_in_hom [of w] equivalence_is_adjoint by auto
show "Maps.dom (Chn ?W) = Dom_W.apex"
proof -
have "Maps.dom (Chn ?W) = Maps.MkIde (src w)"
using 1 w\<theta>\<nu> Maps.dom_char by simp
also have "... = Dom_W.apex"
proof -
have "src w = src (tab\<^sub>0 ?f)"
using w\<theta>\<nu> by blast
thus ?thesis
using Dom_W.apex_def Maps.arr_char Maps.dom_char
apply simp
by (metis (no_types, lifting) f.base_simps(2) f.satisfies_T0
f.u_in_hom hcomp_simps(1))
qed
finally show ?thesis by fastforce
qed
show "Maps.cod (Chn ?W) = Cod_W.apex"
proof -
have "Maps.cod (Chn ?W) = Maps.MkIde (trg w)"
using 1 w\<theta>\<nu> Maps.cod_char by simp
also have "... = Cod_W.apex"
proof -
have "trg w = src (Maps.REP g.leg0)"
using w\<theta>\<nu> by blast
thus ?thesis
using Cod_W.apex_def Maps.arr_char Maps.cod_char
apply simp
using g.dom.apex_def Maps.dom_char Maps.REP_simps(2) g.dom.is_span
by presburger
qed
finally show ?thesis by fastforce
qed
qed
show "Cod_W.leg0 \<odot> Chn ?W = Dom_W.leg0"
proof -
have "Cod_W.leg0 \<odot> Chn ?W = g.leg0 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
by simp
also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
using g.dom.leg_simps(1) Maps.CLS_REP [of g.leg0]
by simp
also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0 \<star> w\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint (Maps.REP g.leg0)"
by fast
moreover have "is_left_adjoint w"
using w\<theta>\<nu> equivalence_is_adjoint by simp
moreover have "Maps.REP g.leg0 \<star> w \<cong> Maps.REP g.leg0 \<star> w"
using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom hseqI'
by (metis (no_types, lifting) REP_leg0.ide_left adjoint_pair_antipar(1)
calculation(2) ide_hcomp in_hhomE)
ultimately show ?thesis
using w\<theta>\<nu> Maps.comp_CLS isomorphic_reflexive equivalence_is_adjoint
by blast
qed
also have "... = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>"
proof -
have "iso \<theta>"
proof -
have "is_left_adjoint (Maps.REP g.leg0 \<star> w)"
using w\<theta>\<nu> equivalence_is_adjoint Maps.REP_in_hhom hseqI'
by (simp add: g.leg0_is_map in_hhom_def left_adjoints_compose)
moreover have "is_left_adjoint (tab\<^sub>0 ?f)"
by simp
ultimately show ?thesis
using w\<theta>\<nu> BS3 by blast
qed
thus ?thesis
using w\<theta>\<nu> Maps.CLS_eqI equivalence_is_adjoint hseqI'
by (meson isomorphic_def isomorphic_implies_hpar(1))
qed
finally show ?thesis by fastforce
qed
show "Cod_W.leg1 \<odot> Chn ?W = Dom_W.leg1"
proof -
have "Cod_W.leg1 \<odot> Chn ?W = g.leg1 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
by simp
also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
using g.dom.leg_simps(3) Maps.CLS_REP by presburger
also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg1 \<star> w\<rbrakk>\<rbrakk>"
proof -
have "is_left_adjoint (Maps.REP g.leg1)"
by fast
moreover have "is_left_adjoint w"
using w\<theta>\<nu> equivalence_is_adjoint by simp
moreover have "Maps.REP g.leg1 \<star> w \<cong> Maps.REP g.leg1 \<star> w"
using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom hseqI'
by (metis (no_types, lifting) "2" calculation(2) g.dom.is_span
hcomp_ide_isomorphic Maps.ide_REP in_hhomE
right_adjoint_determines_left_up_to_iso)
ultimately show ?thesis
using w\<theta>\<nu> Maps.comp_CLS isomorphic_reflexive equivalence_is_adjoint
by blast
qed
also have "... = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>"
proof -
have "ide (Maps.REP g.leg1 \<star> w)"
using 2 w\<theta>\<nu> equivalence_map_is_ide by auto
moreover have "Maps.REP g.leg1 \<star> w \<cong>
tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
using w\<theta>\<nu> equivalence_is_adjoint hseqI' f.leg1_is_map
right_adjoint_determines_left_up_to_iso adjoint_pair_preserved_by_iso
by (meson adjoint_pair_antipar(2) ide_in_hom(2) ide_is_iso)
ultimately show ?thesis
using Maps.CLS_eqI by blast
qed
finally show ?thesis by fastforce
qed
qed
thus W: "Span.arr ?W"
using Span.arr_char by blast
- interpret Dom_W: span_in_category Maps.comp
- \<open>\<lparr>Leg0 = MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
- (src (Maps.REP g.leg0)\<^sup>*)
- (iso_class
- (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))),
- Leg1 = MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
- (Maps.Cod g.leg1)
- (iso_class
- (tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))\<rparr>\<close>
+ interpret Dom_W:
+ span_in_category Maps.comp
+ \<open>\<lparr>Leg0 = Maps.MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
+ (src (Maps.REP g.leg0)\<^sup>*)
+ (iso_class (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))),
+ Leg1 = Maps.MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
+ (Maps.Cod g.leg1)
+ (iso_class (tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))\<rparr>\<close>
using W Span.arr_char
by (simp add: arrow_of_spans_def)
interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
using W Span.arr_char
by (simp add: arrow_of_spans_def)
show "Span.dom ?W = SPN ?f"
proof -
have "Span.dom ?W =
\<lparr>Chn = Dom_W.apex,
Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>,
Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>\<rparr>,
Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>,
Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>\<rparr>\<rparr>"
using 0 W Span.dom_char by simp
also have "... = SPN ?f"
using SPN_def Dom_W.apex_def Maps.dom_char Dom_W.is_span iso_class_eqI
spn_ide
apply simp
using ide_f by blast
finally show ?thesis by blast
qed
show "Span.cod ?W = g"
using 0 W Span.cod_char Cod_W.apex_def by simp
qed
moreover have "Span.iso ?W"
proof -
have "Maps.iso \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
proof -
have "Maps.arr \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk> \<and> w \<in> Maps.Map \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk> \<and> equivalence_map w"
proof (intro conjI)
show 1: "Maps.arr \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
using w\<theta>\<nu> Maps.CLS_in_hom equivalence_is_adjoint by blast
show "equivalence_map w"
using w\<theta>\<nu> by blast
show "w \<in> Maps.Map \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
using 1 w\<theta>\<nu> equivalence_is_adjoint Maps.arr_char
by (simp add: equivalence_map_is_ide ide_in_iso_class)
qed
thus ?thesis
using Maps.iso_char' by blast
qed
thus ?thesis
using w\<theta>\<nu> W_in_hom Span.iso_char by auto
qed
ultimately show ?thesis
using Span.isomorphic_def by blast
qed
ultimately show ?thesis by blast
qed
qed
show "\<And>r s \<tau>. \<lbrakk>ide r; ide s; src r = src s; trg r = trg s; Span.in_hom \<tau> (SPN r) (SPN s)\<rbrakk>
\<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright> \<and> SPN \<mu> = \<tau>"
proof -
fix r s \<tau>
assume r: "ide r" and s: "ide s"
assume src_eq: "src r = src s" and trg_eq: "trg r = trg s"
assume \<tau>: "Span.in_hom \<tau> (SPN r) (SPN s)"
interpret \<tau>: arrow_of_spans Maps.comp \<tau>
using \<tau> Span.arr_char by auto
interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r
using r by (unfold_locales, auto)
interpret s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
using s by (unfold_locales, auto)
interpret s: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> s
using s.is_arrow_of_tabulations_in_maps by simp
have \<tau>_dom_leg0_eq: "\<tau>.dom.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>"
using \<tau> Span.dom_char SPN_def [of r] by auto
have \<tau>_dom_leg1_eq: "\<tau>.dom.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
using \<tau> Span.dom_char SPN_def [of r] by auto
have \<tau>_cod_leg0_eq: "\<tau>.cod.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>"
using \<tau> Span.cod_char SPN_def [of s] by auto
have \<tau>_cod_leg1_eq: "\<tau>.cod.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 s\<rbrakk>\<rbrakk>"
using \<tau> Span.cod_char SPN_def [of s] by auto
have 1: "tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<cong> tab\<^sub>0 r"
proof -
have "tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<cong> Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine"
proof -
have "Maps.REP \<tau>.cod.leg0 \<cong> tab\<^sub>0 s"
using \<tau>_cod_leg0_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS s.satisfies_T0
by presburger
thus ?thesis
using hcomp_isomorphic_ide [of "Maps.REP \<tau>.cod.leg0" "tab\<^sub>0 s" "Maps.REP \<tau>.chine"]
isomorphic_symmetric Maps.seq_char
by fastforce
qed
also have "... \<cong> Maps.REP \<tau>.dom.leg0"
proof -
have "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg0\<rbrakk>\<rbrakk>"
using \<tau>.leg0_commutes Maps.CLS_REP \<tau>.chine_simps(1)
\<tau>.cod.leg_simps(1) \<tau>.dom.leg_simps(1)
by presburger
hence "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg0\<rbrakk>\<rbrakk>"
using Maps.comp_CLS [of "Maps.REP \<tau>.cod.leg0" "Maps.REP \<tau>.chine"
"Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine"]
isomorphic_reflexive
by (metis (no_types, lifting) Maps.seq_char Maps.REP_in_hhom(2) Maps.REP_simps(2-3)
\<tau>.chine_in_hom \<tau>.cod.leg_in_hom(1) \<tau>.dom.leg_simps(1) \<tau>.leg0_commutes
ide_hcomp Maps.ide_REP)
thus ?thesis
using Maps.CLS_eqI Maps.seq_char Maps.ide_REP
by (meson calculation isomorphic_implies_ide(2))
qed
also have "... \<cong> tab\<^sub>0 r"
using \<tau>_dom_leg0_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS r.satisfies_T0
by presburger
finally show ?thesis by blast
qed
obtain \<theta> where \<theta>: "\<guillemotleft>\<theta> : tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<Rightarrow> tab\<^sub>0 r\<guillemotright> \<and> iso \<theta>"
using 1 by blast
have 2: "tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<cong> tab\<^sub>1 r"
proof -
have "tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<cong> Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine"
proof -
have "Maps.REP \<tau>.cod.leg1 \<cong> tab\<^sub>1 s"
using \<tau>_cod_leg1_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS s.leg1_is_map
by presburger
thus ?thesis
using hcomp_isomorphic_ide [of "Maps.REP \<tau>.cod.leg1" "tab\<^sub>1 s" "Maps.REP \<tau>.chine"]
isomorphic_symmetric Maps.seq_char
by fastforce
qed
also have "... \<cong> Maps.REP \<tau>.dom.leg1"
proof -
have "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg1\<rbrakk>\<rbrakk>"
using \<tau>.leg1_commutes Maps.CLS_REP \<tau>.chine_simps(1)
\<tau>.cod.leg_simps(3) \<tau>.dom.leg_simps(3)
by presburger
hence "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg1\<rbrakk>\<rbrakk>"
using Maps.comp_CLS [of "Maps.REP \<tau>.cod.leg1" "Maps.REP \<tau>.chine"
"Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine"]
isomorphic_reflexive
by (metis (no_types, lifting) Maps.seq_char Maps.REP_in_hhom(2)
Maps.REP_simps(2) Maps.REP_simps(3) \<tau>.chine_in_hom \<tau>.cod.leg_in_hom(2)
\<tau>.dom.leg_simps(3) \<tau>.leg1_commutes ide_hcomp Maps.ide_REP)
thus ?thesis
using Maps.CLS_eqI Maps.seq_char Maps.ide_REP
by (meson calculation isomorphic_implies_ide(2))
qed
also have "... \<cong> tab\<^sub>1 r"
using \<tau>_dom_leg1_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS r.leg1_is_map
by presburger
finally show ?thesis by blast
qed
obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 s \<star> Maps.REP \<tau>.chine\<guillemotright> \<and> iso \<nu>"
using 2 isomorphic_symmetric by blast
define \<Delta>
where "\<Delta> \<equiv> (s \<star> \<theta>) \<cdot> \<a>[s, tab\<^sub>0 s, Maps.REP \<tau>.chine] \<cdot> (s.tab \<star> Maps.REP \<tau>.chine) \<cdot> \<nu>"
have \<Delta>: "\<guillemotleft>\<Delta> : tab\<^sub>1 r \<Rightarrow> s \<star> tab\<^sub>0 r\<guillemotright>"
proof (unfold \<Delta>_def, intro comp_in_homI)
show "\<guillemotleft>\<nu> : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 s \<star> Maps.REP \<tau>.chine\<guillemotright>"
using \<nu> by simp
show 3: "\<guillemotleft>s.tab \<star> Maps.REP \<tau>.chine :
tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<Rightarrow> (s \<star> tab\<^sub>0 s) \<star> Maps.REP \<tau>.chine\<guillemotright>"
apply (intro hcomp_in_vhom)
apply auto
using "1" by fastforce
show "\<guillemotleft>\<a>[s, tab\<^sub>0 s, Maps.REP \<tau>.chine] :
(s \<star> tab\<^sub>0 s) \<star> Maps.REP \<tau>.chine \<Rightarrow> s \<star> tab\<^sub>0 s \<star> Maps.REP \<tau>.chine\<guillemotright>"
using s hseqI' assoc_in_hom [of s "tab\<^sub>0 s" "Maps.REP \<tau>.chine"]
by (metis (no_types, lifting) Maps.ide_REP 3 \<tau>.chine_simps(1) hcomp_in_vhomE
ideD(2) ideD(3) s.ide_u s.tab_simps(2) s.u_simps(3))
show "\<guillemotleft>s \<star> \<theta> : s \<star> tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<Rightarrow> s \<star> tab\<^sub>0 r\<guillemotright>"
using 1 s \<theta> isomorphic_implies_hpar(4) src_eq by auto
qed
define \<mu> where "\<mu> \<equiv> r.T0.trnr\<^sub>\<epsilon> s \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
have \<mu>: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
proof (unfold \<mu>_def, intro comp_in_homI)
show "\<guillemotleft>inv (r.T0.trnr\<^sub>\<epsilon> r r.tab) : r \<Rightarrow> tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<guillemotright>"
using r.yields_isomorphic_representation by fastforce
show "\<guillemotleft>r.T0.trnr\<^sub>\<epsilon> s \<Delta> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> s\<guillemotright>"
using s \<Delta> src_eq r.T0.adjoint_transpose_right(2) [of s "tab\<^sub>1 r"] by auto
qed
interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg r s \<mu>
using \<mu> by (unfold_locales, auto)
interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> \<mu>
using \<mu>.is_arrow_of_tabulations_in_maps by simp
have \<Delta>_eq: "\<Delta> = \<mu>.\<Delta>"
proof -
have "r.T0.trnr\<^sub>\<epsilon> s \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab) =
r.T0.trnr\<^sub>\<epsilon> s \<mu>.\<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
using \<mu> \<mu>_def \<mu>.\<mu>_in_terms_of_\<Delta> by auto
hence "r.T0.trnr\<^sub>\<epsilon> s \<Delta> = r.T0.trnr\<^sub>\<epsilon> s \<mu>.\<Delta>"
using r s \<Delta> r.T0.adjoint_transpose_right(2) r.yields_isomorphic_representation
iso_inv_iso iso_is_retraction retraction_is_epi epiE
by (metis \<mu>.in_hom \<mu>_def arrI)
thus ?thesis
using \<Delta> \<mu>.\<Delta>_in_hom(2) src_eq r.T0.adjoint_transpose_right(6)
bij_betw_imp_inj_on
[of "r.T0.trnr\<^sub>\<epsilon> s" "hom (tab\<^sub>1 r) (s \<star> tab\<^sub>0 r)" "hom (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) s"]
inj_on_def [of "r.T0.trnr\<^sub>\<epsilon> s" "hom (tab\<^sub>1 r) (s \<star> tab\<^sub>0 r)"]
by simp
qed
have "\<mu>.is_induced_map (Maps.REP \<tau>.chine)"
using \<theta> \<nu> \<Delta>_eq \<Delta>_def \<mu>.is_induced_map_iff \<tau>.chine_simps(1) Maps.ide_REP by blast
hence 3: "Maps.REP \<tau>.chine \<cong> \<mu>.chine"
using \<mu>.chine_is_induced_map \<mu>.induced_map_unique by simp
have "SPN \<mu> = \<tau>"
proof (intro Span.arr_eqI)
show "Span.par (SPN \<mu>) \<tau>"
using \<mu> \<tau> SPN_in_hom
by (metis (no_types, lifting) SPN.preserves_cod SPN.preserves_dom Span.in_homE
in_homE)
show "Chn (SPN \<mu>) = \<tau>.chine"
proof -
have "Chn (SPN \<mu>) = \<lbrakk>\<lbrakk>spn \<mu>\<rbrakk>\<rbrakk>"
using \<mu> SPN_def spn_def by auto
also have "... = \<lbrakk>\<lbrakk>\<mu>.chine\<rbrakk>\<rbrakk>"
using \<mu> spn_def by fastforce
also have "... = \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk>"
using 3 isomorphic_symmetric Maps.CLS_eqI iso_class_eqI isomorphic_implies_hpar(3)
isomorphic_implies_hpar(4)
by auto
also have "... = \<tau>.chine"
using Maps.CLS_REP \<tau>.chine_simps(1) by blast
finally show ?thesis by blast
qed
qed
thus "\<exists>\<mu>. \<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright> \<and> SPN \<mu> = \<tau>"
using \<mu> by auto
qed
qed
theorem SPN_is_equivalence_pseudofunctor:
shows "equivalence_pseudofunctor V H \<a> \<i> src trg
Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>"
..
text \<open>
We have completed the proof of the second half of the main result (CKS Theorem 4):
\<open>B\<close> is biequivalent (via \<open>SPN\<close>) to \<open>Span(Maps(B))\<close>.
\<close>
corollary
shows "equivalent_bicategories V H \<a> \<i> src trg
Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg"
using SPN_is_equivalence_pseudofunctor equivalent_bicategories_def by blast
end
end
diff --git a/thys/Bicategory/CategoryWithPullbacks.thy b/thys/Bicategory/CategoryWithPullbacks.thy
--- a/thys/Bicategory/CategoryWithPullbacks.thy
+++ b/thys/Bicategory/CategoryWithPullbacks.thy
@@ -1,1268 +1,1260 @@
(* Title: CategoryWithPullbacks
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Category with Pullbacks"
theory CategoryWithPullbacks
imports Category3.Limit
begin
text \<open>
In this section, we give a traditional definition of pullbacks in a category as
limits of cospan diagrams and we define a locale \<open>category_with_pullbacks\<close> that
is satisfied by categories in which every cospan diagram has a limit.
These definitions build on the general definition of limit that we gave in
@{theory Category3.Limit}. We then define a locale \<open>elementary_category_with_pullbacks\<close>
that axiomatizes categories equipped with chosen functions that assign to each cospan
a corresponding span of ``projections'', which enjoy the familiar universal property
of a pullback. After developing consequences of the axioms, we prove that the two
locales are in agreement, in the sense that every interpretation of
\<open>category_with_pullbacks\<close> extends to an interpretation of
\<open>elementary_category_with_pullbacks\<close>, and conversely, the underlying category of
an interpretation of \<open>elementary_category_with_pullbacks\<close> always yields an interpretation
of \<open>category_with_pullbacks\<close>.
\<close>
subsection "Commutative Squares"
context category
begin
text \<open>
The following provides some useful technology for working with commutative squares.
\<close>
definition commutative_square
where "commutative_square f g h k \<equiv> cospan f g \<and> span h k \<and> dom f = cod h \<and> f \<cdot> h = g \<cdot> k"
lemma commutative_squareI [intro, simp]:
assumes "cospan f g" and "span h k" and "dom f = cod h" and "f \<cdot> h = g \<cdot> k"
shows "commutative_square f g h k"
using assms commutative_square_def by auto
lemma commutative_squareE [elim]:
assumes "commutative_square f g h k"
and "\<lbrakk> arr f; arr g; arr h; arr k; cod f = cod g; dom h = dom k; dom f = cod h;
dom g = cod k; f \<cdot> h = g \<cdot> k \<rbrakk> \<Longrightarrow> T"
shows T
using assms commutative_square_def
by (metis (mono_tags, lifting) seqE seqI)
lemma commutative_square_comp_arr:
assumes "commutative_square f g h k" and "seq h l"
shows "commutative_square f g (h \<cdot> l) (k \<cdot> l)"
using assms
apply (elim commutative_squareE, intro commutative_squareI, auto)
using comp_assoc by metis
lemma arr_comp_commutative_square:
assumes "commutative_square f g h k" and "seq l f"
shows "commutative_square (l \<cdot> f) (l \<cdot> g) h k"
using assms comp_assoc
by (elim commutative_squareE, intro commutative_squareI, auto)
end
subsection "Cospan Diagrams"
(* TODO: Rework the ugly development of equalizers into this form. *)
text \<open>
The ``shape'' of a cospan diagram is a category having two non-identity arrows
with distinct domains and a common codomain.
\<close>
locale cospan_shape
begin
datatype Arr = Null | AA | BB | TT | AT | BT
fun comp
where "comp AA AA = AA"
| "comp AT AA = AT"
| "comp TT AT = AT"
| "comp BB BB = BB"
| "comp BT BB = BT"
| "comp TT BT = BT"
| "comp TT TT = TT"
| "comp _ _ = Null"
interpretation partial_magma comp
proof
show "\<exists>!n. \<forall>f. comp n f = n \<and> comp f n = n"
proof
show "\<forall>f. comp Null f = Null \<and> comp f Null = Null" by simp
show "\<And>n. \<forall>f. comp n f = n \<and> comp f n = n \<Longrightarrow> n = Null"
by (metis comp.simps(8))
qed
qed
lemma null_char:
shows "null = Null"
proof -
have "\<forall>f. comp Null f = Null \<and> comp f Null = Null" by simp
thus ?thesis
using null_def ex_un_null theI [of "\<lambda>n. \<forall>f. comp n f = n \<and> comp f n = n"]
by (metis partial_magma.comp_null(2) partial_magma_axioms)
qed
lemma ide_char:
shows "ide f \<longleftrightarrow> f = AA \<or> f = BB \<or> f = TT"
proof
show "ide f \<Longrightarrow> f = AA \<or> f = BB \<or> f = TT"
using ide_def null_char by (cases f, simp_all)
show "f = AA \<or> f = BB \<or> f = TT \<Longrightarrow> ide f"
proof -
have 1: "\<And>f g. f = AA \<or> f = BB \<or> f = TT \<Longrightarrow>
comp f f \<noteq> Null \<and>
(comp g f \<noteq> Null \<longrightarrow> comp g f = g) \<and>
(comp f g \<noteq> Null \<longrightarrow> comp f g = g)"
proof -
fix f g
show "f = AA \<or> f = BB \<or> f = TT \<Longrightarrow>
comp f f \<noteq> Null \<and>
(comp g f \<noteq> Null \<longrightarrow> comp g f = g) \<and>
(comp f g \<noteq> Null \<longrightarrow> comp f g = g)"
by (cases f; cases g, auto)
qed
assume f: "f = AA \<or> f = BB \<or> f = TT"
show "ide f"
using f 1 ide_def null_char by simp
qed
qed
fun Dom
where "Dom AA = AA"
| "Dom BB = BB"
| "Dom TT = TT"
| "Dom AT = AA"
| "Dom BT = BB"
| "Dom _ = Null"
fun Cod
where "Cod AA = AA"
| "Cod BB = BB"
| "Cod TT = TT"
| "Cod AT = TT"
| "Cod BT = TT"
| "Cod _ = Null"
lemma domains_char':
shows "domains f = (if f = Null then {} else {Dom f})"
proof (cases "f = Null")
show "f = Null \<Longrightarrow> ?thesis"
using domains_null null_char by auto
show "f \<noteq> Null \<Longrightarrow> ?thesis"
proof -
assume f: "f \<noteq> Null"
have "Dom f \<in> domains f"
using f domains_def ide_char null_char by (cases f, auto)
moreover have "\<And>a. a \<in> domains f \<Longrightarrow> a = Dom f"
using f domains_def ide_char null_char by (cases f, auto)
ultimately have "domains f = {Dom f}" by blast
thus ?thesis using f by simp
qed
qed
lemma codomains_char':
shows "codomains f = (if f = Null then {} else {Cod f})"
proof (cases "f = Null")
show "f = Null \<Longrightarrow> ?thesis"
using codomains_null null_char by auto
show "f \<noteq> Null \<Longrightarrow> ?thesis"
proof -
assume f: "f \<noteq> Null"
have "Cod f \<in> codomains f"
using f codomains_def ide_char null_char by (cases f, auto)
moreover have "\<And>a. a \<in> codomains f \<Longrightarrow> a = Cod f"
using f codomains_def ide_char null_char by (cases f, auto)
ultimately have "codomains f = {Cod f}" by blast
thus ?thesis using f by simp
qed
qed
lemma arr_char:
shows "arr f \<longleftrightarrow> f \<noteq> Null"
using arr_def domains_char' codomains_char' by simp
lemma seq_char:
shows "seq g f \<longleftrightarrow> (f = AA \<and> (g = AA \<or> g = AT)) \<or>
(f = BB \<and> (g = BB \<or> g = BT)) \<or>
(f = AT \<and> g = TT) \<or>
(f = BT \<and> g = TT) \<or>
(f = TT \<and> g = TT)"
using arr_char null_char
by (cases f; cases g, simp_all)
interpretation category comp
proof
show "\<And>g f. comp g f \<noteq> null \<Longrightarrow> seq g f"
using null_char arr_char seq_char by simp
show "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
using domains_char' codomains_char' by auto
show "\<And>h g f. seq h g \<Longrightarrow> seq (comp h g) f \<Longrightarrow> seq g f"
proof -
fix f g h
show "seq h g \<Longrightarrow> seq (comp h g) f \<Longrightarrow> seq g f"
using seq_char arr_char
by (cases g; cases h; simp_all)
qed
show "\<And>h g f. seq h (comp g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
proof -
fix f g h
show "seq h (comp g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
using seq_char arr_char
by (cases f; cases g; simp_all)
qed
show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (comp h g) f"
proof -
fix f g h
show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (comp h g) f"
using seq_char arr_char
by (cases f; simp_all; cases g; simp_all; cases h; auto)
qed
show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
proof -
fix f g h
show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
using seq_char
by (cases f; simp_all; cases g; simp_all; cases h; auto)
qed
qed
lemma is_category:
shows "category comp"
..
(*
* TODO: The statement of domains_char and codomains_char in Category should be corrected
* so that they are true characterizations that cover the case of null.
*)
lemma dom_char:
shows "dom = Dom"
using dom_def domains_char domains_char' null_char by auto
lemma cod_char:
shows "cod = Cod"
using cod_def codomains_char codomains_char' null_char by auto
end
sublocale cospan_shape \<subseteq> category comp
using is_category by auto
locale cospan_diagram =
J: cospan_shape +
C: category C
for C :: "'c comp" (infixr "\<cdot>" 55)
and f0 :: 'c
and f1 :: 'c +
assumes is_cospan: "C.cospan f0 f1"
begin
no_notation J.comp (infixr "\<cdot>" 55)
notation J.comp (infixr "\<cdot>\<^sub>J" 55)
fun map
where "map J.AA = C.dom f0"
| "map J.BB = C.dom f1"
| "map J.TT = C.cod f0"
| "map J.AT = f0"
| "map J.BT = f1"
| "map _ = C.null"
end
sublocale cospan_diagram \<subseteq> diagram J.comp C map
proof
show "\<And>f. \<not> J.arr f \<Longrightarrow> map f = C.null"
using J.arr_char by simp
fix f
assume f: "J.arr f"
show "C.arr (map f)"
using f J.arr_char is_cospan by (cases f, simp_all)
show "C.dom (map f) = map (J.dom f)"
using f J.arr_char J.dom_char is_cospan by (cases f, simp_all)
show "C.cod (map f) = map (J.cod f)"
using f J.arr_char J.cod_char is_cospan by (cases f, simp_all)
next
fix f g
assume fg: "J.seq g f"
show "map (g \<cdot>\<^sub>J f) = map g \<cdot> map f"
using fg J.seq_char J.null_char J.not_arr_null is_cospan
apply (cases f; cases g, simp_all)
using C.comp_arr_dom C.comp_cod_arr by auto
qed
subsection "Category with Pullbacks"
text \<open>
A \emph{pullback} in a category @{term C} is a limit of a cospan diagram in @{term C}.
\<close>
context cospan_diagram
begin
definition mkCone
where "mkCone p0 p1 \<equiv> \<lambda>j. if j = J.AA then p0
else if j = J.BB then p1
else if j = J.AT then f0 \<cdot> p0
else if j = J.BT then f1 \<cdot> p1
else if j = J.TT then f0 \<cdot> p0
else C.null"
abbreviation is_rendered_commutative_by
where "is_rendered_commutative_by p0 p1 \<equiv> C.seq f0 p0 \<and> f0 \<cdot> p0 = f1 \<cdot> p1"
abbreviation has_as_pullback
where "has_as_pullback p0 p1 \<equiv> limit_cone (C.dom p0) (mkCone p0 p1)"
lemma cone_mkCone:
assumes "is_rendered_commutative_by p0 p1"
shows "cone (C.dom p0) (mkCone p0 p1)"
proof -
interpret E: constant_functor J.comp C \<open>C.dom p0\<close>
apply unfold_locales using assms by auto
show "cone (C.dom p0) (mkCone p0 p1)"
proof
fix f
show "\<not> J.arr f \<Longrightarrow> mkCone p0 p1 f = C.null"
using mkCone_def J.arr_char by simp
assume f: "J.arr f"
show "C.dom (mkCone p0 p1 f) = E.map (J.dom f)"
using assms f mkCone_def J.arr_char J.dom_char
apply (cases f, simp_all)
apply (metis C.dom_comp)
apply (metis C.dom_comp)
apply (metis C.dom_comp)
by (metis C.dom_comp)
show "C.cod (mkCone p0 p1 f) = map (J.cod f)"
using assms f mkCone_def J.arr_char J.cod_char is_cospan
by (cases f, auto)
show "map f \<cdot> mkCone p0 p1 (J.dom f) = mkCone p0 p1 f"
using assms f mkCone_def J.arr_char J.dom_char C.comp_ide_arr is_cospan
by (cases f, auto)
show "mkCone p0 p1 (J.cod f) \<cdot> E.map f = mkCone p0 p1 f"
using assms f mkCone_def J.arr_char J.cod_char C.comp_arr_dom
apply (cases f, auto)
apply (metis C.dom_comp C.seqE)
apply (metis C.dom_comp)
apply (metis C.dom_comp)
by (metis C.dom_comp)
qed
qed
lemma is_rendered_commutative_by_cone:
assumes "cone a \<chi>"
shows "is_rendered_commutative_by (\<chi> J.AA) (\<chi> J.BB)"
proof -
interpret \<chi>: cone J.comp C map a \<chi>
using assms by auto
show ?thesis
proof
show "C.seq f0 (\<chi> J.AA)"
by (metis C.seqI J.category_axioms J.cod_char J.seq_char \<chi>.preserves_cod
\<chi>.preserves_reflects_arr category.seqE cospan_diagram.is_cospan
cospan_diagram_axioms cospan_shape.Cod.simps(1) map.simps(1))
show "f0 \<cdot> \<chi> J.AA = f1 \<cdot> \<chi> J.BB"
by (metis J.cod_char J.dom_char \<chi>.A.map_simp \<chi>.naturality
cospan_shape.Cod.simps(4-5) cospan_shape.Dom.simps(4-5)
cospan_shape.comp.simps(2,5) cospan_shape.seq_char
map.simps(4-5))
qed
qed
lemma mkCone_cone:
assumes "cone a \<chi>"
shows "mkCone (\<chi> J.AA) (\<chi> J.BB) = \<chi>"
proof -
interpret \<chi>: cone J.comp C map a \<chi>
using assms by auto
have 1: "is_rendered_commutative_by (\<chi> J.AA) (\<chi> J.BB)"
using assms is_rendered_commutative_by_cone by blast
interpret mkCone_\<chi>: cone J.comp C map \<open>C.dom (\<chi> J.AA)\<close> \<open>mkCone (\<chi> J.AA) (\<chi> J.BB)\<close>
using assms cone_mkCone 1 by auto
show ?thesis
proof -
have "\<And>j. j = J.AA \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
using mkCone_def \<chi>.is_extensional by simp
moreover have "\<And>j. j = J.BB \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
using mkCone_def \<chi>.is_extensional by simp
moreover have "\<And>j. j = J.TT \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
using 1 mkCone_def \<chi>.is_extensional \<chi>.A.map_simp \<chi>.preserves_comp_1
cospan_shape.seq_char
by (metis J.Arr.distinct(14) J.Arr.distinct(20) J.category_axioms \<chi>.is_natural_2
category.seqE cospan_shape.Arr.distinct(25) cospan_shape.Arr.distinct(27)
cospan_shape.comp.simps(5) map.simps(5))
ultimately have "\<And>j. J.ide j \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
using J.ide_char by auto
thus "mkCone (\<chi> J.AA) (\<chi> J.BB) = \<chi>"
using mkCone_def NaturalTransformation.eqI [of J.comp C]
\<chi>.natural_transformation_axioms mkCone_\<chi>.natural_transformation_axioms
J.ide_char
by simp
qed
qed
end
locale pullback_cone =
J: cospan_shape +
C: category C +
D: cospan_diagram C f0 f1 +
limit_cone J.comp C D.map \<open>C.dom p0\<close> \<open>D.mkCone p0 p1\<close>
for C :: "'c comp" (infixr "\<cdot>" 55)
and f0 :: 'c
and f1 :: 'c
and p0 :: 'c
and p1 :: 'c
begin
(* TODO: Equalizer should be simplifiable in the same way. *)
lemma renders_commutative:
shows "D.is_rendered_commutative_by p0 p1"
using D.mkCone_def D.cospan_diagram_axioms cone_axioms
cospan_diagram.is_rendered_commutative_by_cone
by fastforce
lemma is_universal':
assumes "D.is_rendered_commutative_by p0' p1'"
shows "\<exists>!h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<and> p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
proof -
have "D.cone (C.dom p0') (D.mkCone p0' p1')"
using assms D.cone_mkCone by blast
hence 1: "\<exists>!h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<and>
D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
using is_universal [of "C.dom p0'" "D.mkCone p0' p1'"] by simp
have 2: "\<And>h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<Longrightarrow>
D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' \<longleftrightarrow>
p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
proof -
fix h
assume h: "\<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' \<longleftrightarrow>
p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
proof
assume 3: "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
show "p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
proof
show "p0 \<cdot> h = p0'"
proof -
have "p0' = D.mkCone p0' p1' J.AA"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone p0 p1) J.AA"
using 3 by simp
also have "... = p0 \<cdot> h"
using h D.mkCone_def J.arr_char cone_\<chi> by auto
finally show ?thesis by auto
qed
show "p1 \<cdot> h = p1'"
proof -
have "p1' = D.mkCone p0' p1' J.BB"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone p0 p1) J.BB"
using 3 by simp
also have "... = p1 \<cdot> h"
using h D.mkCone_def J.arr_char cone_\<chi> by auto
finally show ?thesis by auto
qed
qed
next
assume 4: "p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
proof
fix j
have "\<not> J.arr j \<Longrightarrow> D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
using h cone_axioms D.mkCone_def J.arr_char by auto
moreover have "J.arr j \<Longrightarrow>
D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
using assms h 4 cone_\<chi> D.mkCone_def J.arr_char [of J.AT] renders_commutative
C.comp_assoc
by fastforce
ultimately show "D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
using J.arr_char J.Dom.cases by blast
qed
qed
qed
thus ?thesis using 1 by blast
qed
lemma induced_arrowI':
assumes "D.is_rendered_commutative_by p0' p1'"
shows "\<guillemotleft>induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
and "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
and "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
proof -
interpret A': constant_functor J.comp C \<open>C.dom p0'\<close>
using assms by (unfold_locales, auto)
have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
using assms D.cone_mkCone [of p0' p1'] by blast
show 1: "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
proof -
have "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') =
D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) J.AA"
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
also have "... = p0'"
proof -
have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) =
D.mkCone p0' p1'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally show ?thesis by auto
qed
show 2: "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
proof -
have "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') =
D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) J.BB"
proof -
have "C.dom p0' = C.dom p1'"
using assms by (metis C.dom_comp)
thus ?thesis
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
qed
also have "... = p1'"
proof -
have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) =
D.mkCone p0' p1'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally show ?thesis by auto
qed
show "\<guillemotleft>induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
using 1 cone induced_arrowI by simp
qed
end
context category
begin
definition has_as_pullback
where "has_as_pullback f0 f1 p0 p1 \<equiv>
cospan f0 f1 \<and> cospan_diagram.has_as_pullback C f0 f1 p0 p1"
definition has_pullbacks
where "has_pullbacks = (\<forall>f0 f1. cospan f0 f1 \<longrightarrow> (\<exists>p0 p1. has_as_pullback f0 f1 p0 p1))"
end
locale category_with_pullbacks =
category +
assumes has_pullbacks: has_pullbacks
subsection "Elementary Category with Pullbacks"
text \<open>
An \emph{elementary category with pullbacks} is a category equipped with a specific
way of mapping each cospan to a span such that the resulting square commutes and
such that the span is universal for that property. It is useful to assume that the
functions mapping a cospan to the two projections of the pullback, are extensional;
that is, they yield @{term null} when applied to arguments that do not form a cospan.
\<close>
locale elementary_category_with_pullbacks =
category C
for C :: "'a comp" (infixr "\<cdot>" 55)
and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>0[_, _]")
and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>1[_, _]") +
assumes prj0_ext: "\<not> cospan f g \<Longrightarrow> \<p>\<^sub>0[f, g] = null"
and prj1_ext: "\<not> cospan f g \<Longrightarrow> \<p>\<^sub>1[f, g] = null"
and pullback_commutes [intro]: "cospan f g \<Longrightarrow> commutative_square f g \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
and universal: "commutative_square f g h k \<Longrightarrow> \<exists>!l. \<p>\<^sub>1[f, g] \<cdot> l = h \<and> \<p>\<^sub>0[f, g] \<cdot> l = k"
-
- subsection "Properties"
-
- text \<open>
- Next, we go on to develop the properties of an elementary category with pullbacks.
- \<close>
-
- context elementary_category_with_pullbacks
begin
lemma pullback_commutes':
assumes "cospan f g"
shows "f \<cdot> \<p>\<^sub>1[f, g] = g \<cdot> \<p>\<^sub>0[f, g]"
using assms commutative_square_def by blast
lemma prj0_in_hom':
assumes "cospan f g"
shows "\<guillemotleft>\<p>\<^sub>0[f, g] : dom \<p>\<^sub>0[f, g] \<rightarrow> dom g\<guillemotright>"
using assms pullback_commutes
by (metis category.commutative_squareE category_axioms in_homI)
lemma prj1_in_hom':
assumes "cospan f g"
shows "\<guillemotleft>\<p>\<^sub>1[f, g] : dom \<p>\<^sub>0[f, g] \<rightarrow> dom f\<guillemotright>"
using assms pullback_commutes
by (metis category.commutative_squareE category_axioms in_homI)
text \<open>
The following gives us a notation for the common domain of the two projections
of a pullback.
\<close>
definition pbdom (infix "\<down>\<down>" 51)
where "f \<down>\<down> g \<equiv> dom \<p>\<^sub>0[f, g]"
lemma pbdom_in_hom [intro]:
assumes "cospan f g"
shows "\<guillemotleft>f \<down>\<down> g : f \<down>\<down> g \<rightarrow> f \<down>\<down> g\<guillemotright>"
unfolding pbdom_def
using assms prj0_in_hom'
by (metis arr_dom_iff_arr arr_iff_in_hom cod_dom dom_dom in_homE)
lemma ide_pbdom [simp]:
assumes "cospan f g"
shows "ide (f \<down>\<down> g)"
using assms ide_in_hom by auto[1]
lemma prj0_in_hom [intro, simp]:
assumes "cospan f g" and "a = f \<down>\<down> g" and "b = dom g"
shows "\<guillemotleft>\<p>\<^sub>0[f, g] : a \<rightarrow> b\<guillemotright>"
unfolding pbdom_def
using assms prj0_in_hom' by (simp add: pbdom_def)
lemma prj1_in_hom [intro, simp]:
assumes "cospan f g" and "a = f \<down>\<down> g" and "b = dom f"
shows "\<guillemotleft>\<p>\<^sub>1[f, g] : a \<rightarrow> b\<guillemotright>"
unfolding pbdom_def
using assms prj1_in_hom' by (simp add: pbdom_def)
lemma prj0_simps [simp]:
assumes "cospan f g"
shows "arr \<p>\<^sub>0[f, g]" and "dom \<p>\<^sub>0[f, g] = f \<down>\<down> g" and "cod \<p>\<^sub>0[f, g] = dom g"
using assms prj0_in_hom by (blast, blast, blast)
lemma prj0_simps_arr [iff]:
shows "arr \<p>\<^sub>0[f, g] \<longleftrightarrow> cospan f g"
proof
show "cospan f g \<Longrightarrow> arr \<p>\<^sub>0[f, g]"
using prj0_in_hom by auto
show "arr \<p>\<^sub>0[f, g] \<Longrightarrow> cospan f g"
using prj0_ext not_arr_null by metis
qed
lemma prj1_simps [simp]:
assumes "cospan f g"
shows "arr \<p>\<^sub>1[f, g]" and "dom \<p>\<^sub>1[f, g] = f \<down>\<down> g" and "cod \<p>\<^sub>1[f, g] = dom f"
using assms prj1_in_hom by (blast, blast, blast)
lemma prj1_simps_arr [iff]:
shows "arr \<p>\<^sub>1[f, g] \<longleftrightarrow> cospan f g"
proof
show "cospan f g \<Longrightarrow> arr \<p>\<^sub>1[f, g]"
using prj1_in_hom by auto
show "arr \<p>\<^sub>1[f, g] \<Longrightarrow> cospan f g"
using prj1_ext not_arr_null by metis
qed
lemma span_prj:
assumes "cospan f g"
shows "span \<p>\<^sub>0[f, g] \<p>\<^sub>1[f, g]"
using assms by simp
text \<open>
We introduce a notation for tupling, which produces the induced arrow into a pullback.
In our notation, the ``$0$-side'', which we regard as the input, occurs on the right,
and the ``$1$-side'', which we regard as the output, occurs on the left.
\<close>
definition tuple ("\<langle>_ \<lbrakk>_, _\<rbrakk> _\<rangle>")
where "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<equiv> if commutative_square f g h k then
THE l. \<p>\<^sub>0[f, g] \<cdot> l = k \<and> \<p>\<^sub>1[f, g] \<cdot> l = h
else null"
lemma tuple_in_hom [intro]:
assumes "commutative_square f g h k"
shows "\<guillemotleft>\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> : dom h \<rightarrow> f \<down>\<down> g\<guillemotright>"
proof
have 1: "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k \<and> \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h"
unfolding tuple_def
using assms universal theI [of "\<lambda>l. \<p>\<^sub>0[f, g] \<cdot> l = k \<and> \<p>\<^sub>1[f, g] \<cdot> l = h"]
apply simp
by meson
show "arr \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>"
using assms 1
apply (elim commutative_squareE)
by (metis (no_types, lifting) seqE)
show "dom \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = dom h"
using assms 1
apply (elim commutative_squareE)
by (metis (no_types, lifting) dom_comp)
show "cod \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = f \<down>\<down> g"
unfolding pbdom_def
using assms 1
apply (elim commutative_squareE)
by (metis seqE)
qed
lemma tuple_is_extensional:
assumes "\<not> commutative_square f g h k"
shows "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = null"
unfolding tuple_def
using assms by simp
lemma tuple_simps [simp]:
assumes "commutative_square f g h k"
shows "arr \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>" and "dom \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = dom h" and "cod \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = f \<down>\<down> g"
using assms tuple_in_hom apply blast
using assms tuple_in_hom apply blast
using assms tuple_in_hom by blast
lemma prj_tuple [simp]:
assumes "commutative_square f g h k"
shows "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k" and "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h"
proof -
have 1: "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k \<and> \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h"
unfolding tuple_def
using assms universal theI [of "\<lambda>l. \<p>\<^sub>0[f, g] \<cdot> l = k \<and> \<p>\<^sub>1[f, g] \<cdot> l = h"]
apply simp
by meson
show "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k" using 1 by simp
show "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h" using 1 by simp
qed
lemma tuple_prj:
assumes "cospan f g" and "seq \<p>\<^sub>1[f, g] h"
shows "\<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle> = h"
proof -
have 1: "commutative_square f g (\<p>\<^sub>1[f, g] \<cdot> h) (\<p>\<^sub>0[f, g] \<cdot> h)"
using assms pullback_commutes
by (simp add: commutative_square_comp_arr)
have "\<p>\<^sub>0[f, g] \<cdot> \<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle> = \<p>\<^sub>0[f, g] \<cdot> h"
using assms 1 by simp
moreover have "\<p>\<^sub>1[f, g] \<cdot> \<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle> = \<p>\<^sub>1[f, g] \<cdot> h"
using assms 1 by simp
ultimately show ?thesis
unfolding tuple_def
using assms 1 universal [of f g "\<p>\<^sub>1[f, g] \<cdot> h" "\<p>\<^sub>0[f, g] \<cdot> h"]
theI_unique [of "\<lambda>l. \<p>\<^sub>0[f, g] \<cdot> l = \<p>\<^sub>0[f, g] \<cdot> h \<and> \<p>\<^sub>1[f, g] \<cdot> l = \<p>\<^sub>1[f, g] \<cdot> h" h]
by auto
qed
lemma tuple_prj_spc [simp]:
assumes "cospan f g"
shows "\<langle>\<p>\<^sub>1[f, g] \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g]\<rangle> = f \<down>\<down> g"
proof -
have "\<langle>\<p>\<^sub>1[f, g] \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g]\<rangle> = \<langle>\<p>\<^sub>1[f, g] \<cdot> (f \<down>\<down> g) \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> (f \<down>\<down> g)\<rangle>"
using assms comp_arr_dom by simp
thus ?thesis
using assms tuple_prj by simp
qed
lemma prj_joint_monic:
assumes "cospan f g" and "seq \<p>\<^sub>1[f, g] h" and "seq \<p>\<^sub>1[f, g] h'"
and "\<p>\<^sub>0[f, g] \<cdot> h = \<p>\<^sub>0[f, g] \<cdot> h'" and "\<p>\<^sub>1[f, g] \<cdot> h = \<p>\<^sub>1[f, g] \<cdot> h'"
shows "h = h'"
proof -
have "h = \<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle>"
using assms tuple_prj [of f g h] by simp
also have "... = \<langle>\<p>\<^sub>1[f, g] \<cdot> h' \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h'\<rangle>"
using assms by simp
also have "... = h'"
using assms tuple_prj [of f g h'] by simp
finally show ?thesis by blast
qed
text \<open>
The pullback of an identity along an arbitrary arrow is an isomorphism.
\<close>
lemma iso_pullback_ide:
assumes "cospan \<mu> \<nu>" and "ide \<mu>"
shows "iso \<p>\<^sub>0[\<mu>, \<nu>]"
proof -
have "inverse_arrows \<p>\<^sub>0[\<mu>, \<nu>] \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>"
proof
show 1: "ide (\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>)"
proof -
have "commutative_square \<mu> \<nu> \<nu> (dom \<nu>)"
using assms comp_arr_dom comp_cod_arr by auto
hence "\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> = dom \<nu>"
using assms prj_tuple(1) [of \<mu> \<nu> \<nu> "dom \<nu>"] by simp
thus ?thesis
using assms by simp
qed
show "ide (\<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>])"
proof -
have "\<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = (\<mu> \<down>\<down> \<nu>)"
proof -
have "\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = \<p>\<^sub>0[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
proof -
have "\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = (\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>) \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
using assms 1 comp_reduce by blast
also have "... = dom \<nu> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
proof -
have "commutative_square \<mu> \<nu> \<nu> (dom \<nu>)"
using assms comp_arr_dom comp_cod_arr by auto
thus ?thesis
using assms prj_tuple(1) [of \<mu> \<nu> \<nu> "dom \<nu>"] by simp
qed
also have "... = \<p>\<^sub>0[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
using assms prj0_in_hom [of \<mu> \<nu>] pullback_commutes comp_arr_dom comp_cod_arr
by (metis in_homE)
finally show ?thesis by blast
qed
moreover have "\<p>\<^sub>1[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = \<p>\<^sub>1[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
proof -
have "\<p>\<^sub>1[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = (\<p>\<^sub>1[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>) \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
by (simp add: assms(2) local.comp_assoc)
also have "... = \<nu> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
proof -
have "commutative_square \<mu> \<nu> \<nu> (dom \<nu>)"
using assms comp_arr_dom comp_cod_arr by auto
thus ?thesis
using assms prj_tuple(2) [of \<mu> \<nu> \<nu> "dom \<nu>"] by simp
qed
also have "... = \<mu> \<cdot> \<p>\<^sub>1[\<mu>, \<nu>]"
using assms pullback_commutes
by (simp add: commutative_square_def)
also have "... = \<p>\<^sub>1[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
using assms comp_arr_dom comp_cod_arr pullback_commutes by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using assms prj0_in_hom prj1_in_hom
prj_joint_monic [of \<mu> \<nu> "\<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]" "\<mu> \<down>\<down> \<nu>"]
by (metis comp_arr_dom prj1_simps(1) prj1_simps(2))
qed
thus ?thesis
using assms prj0_in_hom [of \<mu> \<nu>] ide_dom [of "\<p>\<^sub>1[\<mu>, \<nu>]"] by auto
qed
qed
thus ?thesis by auto
qed
lemma comp_tuple_arr:
assumes "commutative_square f g h k" and "seq h l"
shows "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
proof -
have "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = \<p>\<^sub>0[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
proof -
have "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = (\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>) \<cdot> l"
using comp_assoc by simp
also have "... = k \<cdot> l"
using assms prj_tuple(1) by auto
also have "... = \<p>\<^sub>0[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
proof -
have 1: "commutative_square f g (h \<cdot> l) (k \<cdot> l)"
using assms commutative_square_comp_arr by auto
show ?thesis
using assms by (metis "1" prj_tuple(1))
qed
finally show ?thesis by blast
qed
moreover have "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
proof -
have "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = (\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>) \<cdot> l"
using comp_assoc by simp
also have "... = h \<cdot> l"
using assms prj_tuple(2) by auto
also have "... = \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
proof -
have 1: "commutative_square f g (h \<cdot> l) (k \<cdot> l)"
using assms commutative_square_comp_arr by blast
show ?thesis
using assms by (metis "1" prj_tuple(2))
qed
finally show ?thesis by blast
qed
moreover have "seq \<p>\<^sub>1[f, g] (\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l)"
using assms tuple_in_hom [of f h g k] prj1_in_hom
by (intro seqI, elim seqE, auto, fastforce)
moreover have "seq \<p>\<^sub>1[f, g] \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
using assms tuple_in_hom [of f "h \<cdot> l" g "k \<cdot> l"]
using calculation(2) calculation(3) by auto
ultimately show ?thesis
using assms prj_joint_monic [of f g "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l" "\<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"]
by auto
qed
lemma pullback_arr_cod:
assumes "arr f"
shows "inverse_arrows \<p>\<^sub>1[f, cod f] \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>"
and "inverse_arrows \<p>\<^sub>0[cod f, f] \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>"
proof -
show "inverse_arrows \<p>\<^sub>1[f, cod f] \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>"
proof
have 1: "commutative_square f (cod f) (dom f) f"
using assms comp_arr_dom comp_cod_arr by auto
show "ide (\<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f])"
proof -
have "\<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] = f \<down>\<down> cod f"
proof -
have "\<p>\<^sub>0[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] = \<p>\<^sub>0[f, cod f] \<cdot> (f \<down>\<down> cod f)"
proof -
have "\<p>\<^sub>0[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] =
(\<p>\<^sub>0[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>) \<cdot> \<p>\<^sub>1[f, cod f]"
using comp_assoc by simp
also have "... = f \<cdot> \<p>\<^sub>1[f, cod f]"
using assms 1 prj_tuple(1) [of f "dom f" "cod f" f] by simp
also have "... = \<p>\<^sub>0[f, cod f] \<cdot> (f \<down>\<down> cod f)"
using assms 1 pullback_commutes [of f "cod f"] comp_arr_dom comp_cod_arr
by (metis commutative_squareE pbdom_def)
finally show ?thesis by blast
qed
moreover
have "\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] = \<p>\<^sub>1[f, cod f] \<cdot> (f \<down>\<down> cod f)"
proof -
have "\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] =
(\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>) \<cdot> \<p>\<^sub>1[f, cod f]"
proof -
have "seq \<p>\<^sub>1[f, cod f] \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>"
using assms 1 prj1_in_hom [of f "cod f"]
tuple_in_hom [of f "dom f" "cod f" f]
by auto
moreover have "seq \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<p>\<^sub>1[f, cod f]"
using assms 1 prj1_in_hom [of f "cod f"]
tuple_in_hom [of f "dom f" "cod f" f]
by auto
ultimately show ?thesis using comp_assoc by simp
qed
also have "... = dom f \<cdot> \<p>\<^sub>1[f, cod f]"
using assms 1 prj_tuple(2) [of f "dom f" "cod f" f] by simp
also have "... = \<p>\<^sub>1[f, cod f] \<cdot> (f \<down>\<down> cod f)"
using assms comp_arr_dom comp_cod_arr by simp
finally show ?thesis by blast
qed
ultimately show ?thesis
using assms
prj_joint_monic
[of f "cod f" "\<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f]" "f \<down>\<down> cod f"]
by simp
qed
thus ?thesis
using assms arr_cod cod_cod ide_dom prj1_simps_arr by simp
qed
show "ide (\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>)"
proof -
have "\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> = dom f"
using assms 1 by simp
thus ?thesis using assms by simp
qed
qed
show "inverse_arrows \<p>\<^sub>0[cod f, f] \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>"
proof
have 1: "commutative_square (cod f) f f (dom f)"
using assms comp_arr_dom comp_cod_arr by auto
show "ide (\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>)"
proof -
have "\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> = dom f"
using assms 1 prj_tuple(1) [of "cod f" f f "dom f"] by blast
thus ?thesis using assms by simp
qed
show "ide (\<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f])"
proof -
have "\<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] = cod f \<down>\<down> f"
proof -
have "\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] = \<p>\<^sub>0[cod f, f] \<cdot> (cod f \<down>\<down> f)"
proof -
have "\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] =
(\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>) \<cdot> \<p>\<^sub>0[cod f, f]"
using assms
by (metis (no_types, lifting) category.ext category_axioms comp_reduce
match_1 match_2 seqE)
also have "... = dom f \<cdot> \<p>\<^sub>0[cod f, f]"
using assms 1 prj_tuple(1) [of "cod f" f f "dom f"] by simp
also have "... = \<p>\<^sub>0[cod f, f] \<cdot> (cod f \<down>\<down> f)"
using assms comp_arr_dom comp_cod_arr by simp
finally show ?thesis
using prj0_in_hom by blast
qed
moreover
have "\<p>\<^sub>1[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] = \<p>\<^sub>1[cod f, f] \<cdot> (cod f \<down>\<down> f)"
proof -
have "\<p>\<^sub>1[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] =
(\<p>\<^sub>1[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>) \<cdot> \<p>\<^sub>0[cod f, f]"
using comp_assoc by simp
also have "... = f \<cdot> \<p>\<^sub>0[cod f, f]"
using assms 1 prj_tuple(2) [of "cod f" f f "dom f"] by simp
also have "... = \<p>\<^sub>1[cod f, f] \<cdot> (cod f \<down>\<down> f)"
using assms 1 pullback_commutes [of "cod f" f] comp_arr_dom comp_cod_arr
by (metis (mono_tags, lifting) commutative_squareE pbdom_def)
finally show ?thesis by blast
qed
ultimately show ?thesis
using assms prj_joint_monic [of "cod f" f "\<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f]"]
by simp
qed
thus ?thesis using assms by simp
qed
qed
qed
text \<open>
The pullback of a monomorphism along itself is automatically symmetric: the left
and right projections are equal.
\<close>
lemma pullback_mono_self:
assumes "mono f"
shows "\<p>\<^sub>0[f, f] = \<p>\<^sub>1[f, f]"
proof -
have "f \<cdot> \<p>\<^sub>0[f, f] = f \<cdot> \<p>\<^sub>1[f, f]"
using assms pullback_commutes [of f f]
by (metis commutative_squareE mono_implies_arr)
thus ?thesis
using assms monoE [of f "\<p>\<^sub>1[f, f]" "\<p>\<^sub>0[f, f]"]
by (metis mono_implies_arr prj0_simps(1) prj0_simps(3) seqI)
qed
lemma pullback_iso_self:
assumes "iso f"
shows "\<p>\<^sub>0[f, f] = \<p>\<^sub>1[f, f]"
using assms pullback_mono_self iso_is_section section_is_mono by simp
lemma pullback_ide_self [simp]:
assumes "ide a"
shows "\<p>\<^sub>0[a, a] = \<p>\<^sub>1[a, a]"
using assms pullback_iso_self ide_is_iso by blast
end
subsection "Agreement between the Definitions"
text \<open>
It is very easy to write locale assumptions that have unintended consequences
or that are even inconsistent. So, to keep ourselves honest, we don't just accept the
definition of ``elementary category with pullbacks'', but in fact we formally establish
the sense in which it agrees with our standard definition of ``category with pullbacks'',
which is given in terms of limit cones.
This is extra work, but it ensures that we didn't make a mistake.
\<close>
context category_with_pullbacks
begin
definition prj1
where "prj1 f g \<equiv> if cospan f g then
fst (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
else null"
definition prj0
where "prj0 f g \<equiv> if cospan f g then
snd (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
else null"
lemma prj_yields_pullback:
assumes "cospan f g"
shows "cospan_diagram.has_as_pullback C f g (prj1 f g) (prj0 f g)"
proof -
have "\<exists>x. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"
proof -
obtain p0 p1 where "cospan_diagram.has_as_pullback C f g p0 p1"
using assms has_pullbacks has_pullbacks_def has_as_pullback_def by metis
hence "cospan_diagram.has_as_pullback C f g (fst (p0, p1)) (snd (p0, p1))"
by simp
thus ?thesis by blast
qed
thus ?thesis
using assms has_pullbacks has_pullbacks_def prj0_def prj1_def
someI_ex [of "\<lambda>x. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"]
by simp
qed
interpretation elementary_category_with_pullbacks C prj0 prj1
proof
show "\<And>f g. \<not> cospan f g \<Longrightarrow> prj0 f g = null"
using prj0_def by auto
show "\<And>f g. \<not> cospan f g \<Longrightarrow> prj1 f g = null"
using prj1_def by auto
show "\<And>f g. cospan f g \<Longrightarrow> commutative_square f g (prj1 f g) (prj0 f g)"
proof
fix f g
assume fg: "cospan f g"
show "cospan f g" by fact
interpret J: cospan_shape .
interpret D: cospan_diagram C f g
using fg by (unfold_locales, auto)
let ?\<chi> = "D.mkCone (prj1 f g) (prj0 f g)"
interpret \<chi>: limit_cone J.comp C D.map \<open>dom (prj1 f g)\<close> ?\<chi>
using fg prj_yields_pullback by auto
have 1: "prj1 f g = ?\<chi> J.AA \<and> prj0 f g = ?\<chi> J.BB"
using D.mkCone_def by simp
show "span (prj1 f g) (prj0 f g)"
proof -
have "arr (prj1 f g) \<and> arr (prj0 f g)"
using 1 J.arr_char
by (metis J.seqE \<chi>.preserves_reflects_arr cospan_shape.seq_char)
moreover have "dom (prj1 f g) = dom (prj0 f g)"
using 1
by (metis D.is_rendered_commutative_by_cone D.map.simps(4) D.map.simps(5) J.seqE
\<chi>.cone_axioms \<chi>.preserves_comp_1 \<chi>.preserves_dom cospan_shape.comp.simps(2)
cospan_shape.comp.simps(5) cospan_shape.seq_char)
ultimately show ?thesis by simp
qed
show "dom f = cod (prj1 f g)"
using 1 \<chi>.preserves_cod [of J.BB] J.cod_char D.mkCone_def [of "prj1 f g" "prj0 f g"]
by (metis D.map.simps(1) D.preserves_cod J.seqE \<chi>.preserves_cod cod_dom
cospan_shape.seq_char fg)
show "f \<cdot> prj1 f g = g \<cdot> prj0 f g"
using 1 fg D.is_rendered_commutative_by_cone \<chi>.cone_axioms by force
qed
show "\<And>f g h k. commutative_square f g h k \<Longrightarrow> \<exists>!l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"
proof -
fix f g h k
assume fghk: "commutative_square f g h k"
interpret J: cospan_shape .
interpret D: cospan_diagram C f g
using fghk by (unfold_locales, auto)
let ?\<chi> = "D.mkCone (prj1 f g) (prj0 f g)"
interpret \<chi>: limit_cone J.comp C D.map \<open>dom (prj1 f g)\<close> ?\<chi>
using fghk prj_yields_pullback by auto
interpret \<chi>: pullback_cone C f g \<open>prj1 f g\<close> \<open>prj0 f g\<close> ..
have 1: "prj1 f g = ?\<chi> J.AA \<and> prj0 f g = ?\<chi> J.BB"
using D.mkCone_def by simp
show "\<exists>!l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"
proof
let ?l = "SOME l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"
show "prj1 f g \<cdot> ?l = h \<and> prj0 f g \<cdot> ?l = k"
using fghk \<chi>.is_universal' [of h k] \<chi>.renders_commutative
someI_ex [of "\<lambda>l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"]
by blast
thus "\<And>l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k \<Longrightarrow> l = ?l"
using fghk \<chi>.is_universal' [of h k] \<chi>.renders_commutative
by (metis (no_types, lifting) \<chi>.limit_cone_axioms category.in_homI category.seqE
commutative_squareE dom_comp limit_cone_def seqI)
qed
qed
qed
proposition extends_to_elementary_category_with_pullbacks:
shows "elementary_category_with_pullbacks C prj0 prj1"
..
end
context elementary_category_with_pullbacks
begin
interpretation category_with_pullbacks C
proof
show "has_pullbacks"
proof (unfold has_pullbacks_def)
have "\<And>f g. cospan f g \<Longrightarrow> \<exists>p0 p1. has_as_pullback f g p0 p1"
proof -
fix f g
assume fg: "cospan f g"
interpret J: cospan_shape .
interpret D: cospan_diagram C f g
using fg by (unfold_locales, auto)
have 2: "D.is_rendered_commutative_by \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
using fg pullback_commutes' by simp
let ?\<chi> = "D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
interpret \<chi>: cone J.comp C D.map \<open>dom \<p>\<^sub>1[f, g]\<close> ?\<chi>
using D.cone_mkCone 2 by auto
interpret \<chi>: limit_cone J.comp C D.map \<open>dom \<p>\<^sub>1[f, g]\<close> ?\<chi>
proof
fix a' \<chi>'
assume \<chi>': "D.cone a' \<chi>'"
interpret \<chi>': cone J.comp C D.map a' \<chi>'
using \<chi>' by simp
have 3: "commutative_square f g (\<chi>' J.AA) (\<chi>' J.BB)"
proof
show "cospan f g" by fact
show "span (\<chi>' J.AA) (\<chi>' J.BB)"
by (simp add: J.ide_char)
show "dom f = cod (\<chi>' J.AA)"
using \<open>span (\<chi>' J.AA) (\<chi>' J.BB)\<close> J.cod_char by auto
show "f \<cdot> \<chi>' J.AA = g \<cdot> \<chi>' J.BB"
using D.is_rendered_commutative_by_cone \<chi>'.cone_axioms by blast
qed
show "\<exists>!h. \<guillemotleft>h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
D.cones_map h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
proof
let ?h = "\<langle>\<chi>' J.AA \<lbrakk>f, g\<rbrakk> \<chi>' J.BB\<rangle>"
show h': "\<guillemotleft>?h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
proof
show h: "\<guillemotleft>?h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright>"
using fg 3 by fastforce
show "D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
proof -
have "D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g] \<in> D.cones (cod \<langle>\<chi>' J.AA \<lbrakk>f, g\<rbrakk> \<chi>' J.BB\<rangle>)"
using fg h D.cone_mkCone D.is_rendered_commutative_by_cone
\<chi>.cone_axioms
by auto
hence 4: "D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) \<in> D.cones a'"
using fg h D.cones_map_mapsto [of ?h] by blast
interpret \<chi>'h: cone J.comp C D.map a'
\<open>D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g])\<close>
using 4 by simp
show ?thesis
proof -
have "\<And>j. J.ide j \<Longrightarrow> D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) j = \<chi>' j"
proof -
fix j
show "J.ide j \<Longrightarrow> D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) j = \<chi>' j"
using fg h 3 J.ide_char D.mkCone_def [of "\<p>\<^sub>1[f, g]" "\<p>\<^sub>0[f, g]"]
\<chi>.cone_axioms
apply (cases j, simp_all)
by (metis D.map.simps(4) J.dom_eqI
\<chi>'.A.constant_functor_axioms \<chi>'.is_natural_1 \<chi>'.naturality
J.seqE constant_functor.map_simp cospan_shape.comp.simps(3)
cospan_shape.comp.simps(7) cospan_shape.seq_char
prj_tuple(2) comp_assoc)
qed
thus ?thesis
using NaturalTransformation.eqI
\<chi>'.natural_transformation_axioms \<chi>'h.natural_transformation_axioms
by blast
qed
qed
qed
show "\<And>h. \<guillemotleft>h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
D.cones_map h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>' \<Longrightarrow>
h = ?h"
proof -
fix h
assume 1: "\<guillemotleft>h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
D.cones_map h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
hence 2: "cod h = dom \<p>\<^sub>1[f, g]" using 1 by auto
show "h = ?h"
proof -
have "\<p>\<^sub>0[f, g] \<cdot> h = \<p>\<^sub>0[f, g] \<cdot> ?h"
using 1 3 fg J.arr_char \<chi>.cone_axioms J.Arr.distinct(11) D.mkCone_def
by auto
moreover have "\<p>\<^sub>1[f, g] \<cdot> h = \<p>\<^sub>1[f, g] \<cdot> ?h"
using 1 3 fg J.arr_char \<chi>.cone_axioms J.Arr.distinct(11) D.mkCone_def
by auto
ultimately show ?thesis
using fg 1 h' prj_joint_monic by blast
qed
qed
qed
qed
have "has_as_pullback f g \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
using fg has_as_pullback_def \<chi>.limit_cone_axioms by blast
thus "\<exists>p0 p1. has_as_pullback f g p0 p1"
by blast
qed
thus "\<forall>f g. cospan f g \<longrightarrow> (\<exists>p0 p1. has_as_pullback f g p0 p1)"
by simp
qed
qed
proposition is_category_with_pullbacks:
shows "category_with_pullbacks C"
..
end
sublocale elementary_category_with_pullbacks \<subseteq> category_with_pullbacks
using is_category_with_pullbacks by auto
end
diff --git a/thys/Bicategory/Coherence.thy b/thys/Bicategory/Coherence.thy
--- a/thys/Bicategory/Coherence.thy
+++ b/thys/Bicategory/Coherence.thy
@@ -1,3946 +1,3957 @@
(* Title: Coherence
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Coherence"
theory Coherence
imports Bicategory
begin
text \<open>
\sloppypar
In this section, we generalize to bicategories the proof of the Coherence Theorem
that we previously gave for monoidal categories
(see \<open>MonoidalCategory.evaluation_map.coherence\<close> in @{session MonoidalCategory}).
As was the case for the previous proof, the current proof takes a syntactic approach.
First we define a formal ``bicategorical language'' of terms constructed using
syntactic operators that correspond to the various operations (vertical and horizontal
composition, associators and unitors) found in a bicategory.
Terms of the language are classified as formal ``arrows'', ``identities'', or ``objects''
according to the syntactic operators used in their formation.
A class of terms called ``canonical'' is also defined in this way.
Functions that map ``arrows'' to their ``domain'' and ``codomain'', and to their
``source'' and ``target'' are defined by recursion on the structure of terms.
Next, we define a notion of ``normal form'' for terms in this language and we
give a recursive definition of a function that maps terms to their normal forms.
Normalization moves vertical composition inside of horizontal composition and
``flattens'' horizontal composition by associating all horizontal compositions to the right.
In addition, normalization deletes from a term any horizontal composites involving an arrow
and its source or target, replacing such composites by just the arrow itself.
We then define a ``reduction function'' that maps each identity term \<open>t\<close> to a
``canonical'' term \<open>t\<^bold>\<down>\<close> that connects \<open>t\<close> with its normal form. The definition of reduction
is also recursive, but it is somewhat more complex than normalization in that it
involves two mutually recursive functions: one that applies to any identity term
and another that applies only to terms that are the horizontal composite
of two identity terms.
The next step is to define an ``evaluation function'' that evaluates terms in a given
bicategory (which is left as an unspecified parameter). We show that evaluation respects
bicategorical structure:
the domain, codomain, source, and target mappings on terms correspond under evaluation
to the actual domain, codomain, source and target mappings on the given bicategory,
the vertical and horizontal composition on terms correspond to the actual vertical
and horizontal composition of the bicategory, and unit and associativity terms evaluate
to the actual unit and associativity isomorphisms of the bicategory.
In addition, ``object terms'' evaluate to objects (\emph{i.e.}~0-cells),
``identity terms'' evaluate to identities (\emph{i.e.}~1-cells),
``arrow terms'' evaluate to arrows (\emph{i.e.}~2-cells), and ``canonical terms'' evaluate
to canonical isomorphisms.
A term is defined to be ``coherent'' if, roughly speaking, it is a formal arrow
whose evaluation commutes with the evaluations of the reductions to normal form of
its domain and codomain.
We then prove the Coherence Theorem, expressed in the form: ``every arrow is coherent.''
This implies a more classical version of the Coherence Theorem, which says that:
``syntactically parallel arrows with the same normal form have equal evaluations''.
\<close>
subsection "Bicategorical Language"
text \<open>
For the most part, the definition of the ``bicategorical language'' of terms is
a straightforward generalization of the ``monoidal language'' that we used for
monoidal categories.
Some modifications are required, however, due to the fact that horizontal composition
in a bicategory is a partial operation, whereas the the tensor product in a monoidal
category is well-defined for all pairs of arrows.
One difference is that we have found it necessary to introduce a new class of primitive
terms whose elements represent ``formal objects'', so that there is some way to
identify the source and target of what would otherwise be an empty horizontal composite.
This was not an issue for monoidal categories, because the totality of horizontal
composition meant that there was no need for syntactically defined sources and targets.
Another difference is what we have chosen for the ``generators'' of the language
and how they are used to form primitive terms. For monoidal categories,
we supposed that we were given a category \<open>C\<close> and the syntax contained a constructor
to form a primitive term corresponding to each arrow of \<open>C\<close>.
We assumed a category as the given data, rather than something less structured,
such as a graph, because we were primarily interested in the tensor product and
the associators and unitors, and were relatively uninterested in the strictly
associative and unital composition of the underlying category.
For bicategories, we also take the vertical composition as given for the same
reasons; however, this is not yet sufficient due to the fact that horizontal
composition in a bicategory is a partial operation, in contrast to the tensor
product in a monoidal category, which is defined for all pairs of arrows.
To deal with this issue, for bicategories we assume that source and target
mappings are also given, so that the given data forms a category with
``horizontal homs''. The given source and target mappings are extended to all terms
and used to define when two terms are ``formally horizontally composable''.
\<close>
locale bicategorical_language =
category V +
horizontal_homs V src trg
for V :: "'a comp" (infixr "\<cdot>" 55)
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
begin
text \<open>
Constructor \<open>Prim\<^sub>0\<close> is used to construct ``formal objects'' and \<open>Prim\<close> is used to
construct primitive terms that are not formal objects.
\<close>
datatype (discs_sels) 't "term" =
Prim\<^sub>0 't ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sub>0")
| Prim 't ("\<^bold>\<langle>_\<^bold>\<rangle>")
| Hcomp "'t term" "'t term" (infixr "\<^bold>\<star>" 53)
| Vcomp "'t term" "'t term" (infixr "\<^bold>\<cdot>" 55)
| Lunit "'t term" ("\<^bold>\<l>\<^bold>[_\<^bold>]")
| Lunit' "'t term" ("\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
| Runit "'t term" ("\<^bold>\<r>\<^bold>[_\<^bold>]")
| Runit' "'t term" ("\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
| Assoc "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^bold>[_, _, _\<^bold>]")
| Assoc' "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[_, _, _\<^bold>]")
text \<open>
We define formal domain, codomain, source, and target functions on terms.
\<close>
primrec Src :: "'a term \<Rightarrow> 'a term"
where "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
| "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>src \<mu>\<^bold>\<rangle>\<^sub>0"
| "Src (t \<^bold>\<star> u) = Src u"
| "Src (t \<^bold>\<cdot> u) = Src t"
| "Src \<^bold>\<l>\<^bold>[t\<^bold>] = Src t"
| "Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
| "Src \<^bold>\<r>\<^bold>[t\<^bold>] = Src t"
| "Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
| "Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Src v"
| "Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Src v"
primrec Trg :: "'a term \<Rightarrow> 'a term"
where "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
| "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>trg \<mu>\<^bold>\<rangle>\<^sub>0"
| "Trg (t \<^bold>\<star> u) = Trg t"
| "Trg (t \<^bold>\<cdot> u) = Trg t"
| "Trg \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t"
| "Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
| "Trg \<^bold>\<r>\<^bold>[t\<^bold>] = Trg t"
| "Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
| "Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Trg t"
| "Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Trg t"
primrec Dom :: "'a term \<Rightarrow> 'a term"
where "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
| "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>dom \<mu>\<^bold>\<rangle>"
| "Dom (t \<^bold>\<star> u) = Dom t \<^bold>\<star> Dom u"
| "Dom (t \<^bold>\<cdot> u) = Dom u"
| "Dom \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Dom t"
| "Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
| "Dom \<^bold>\<r>\<^bold>[t\<^bold>] = Dom t \<^bold>\<star> Src t"
| "Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
| "Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Dom t \<^bold>\<star> Dom u) \<^bold>\<star> Dom v"
| "Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Dom t \<^bold>\<star> (Dom u \<^bold>\<star> Dom v)"
primrec Cod :: "'a term \<Rightarrow> 'a term"
where "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
| "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>"
| "Cod (t \<^bold>\<star> u) = Cod t \<^bold>\<star> Cod u"
| "Cod (t \<^bold>\<cdot> u) = Cod t"
| "Cod \<^bold>\<l>\<^bold>[t\<^bold>] = Cod t"
| "Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Cod t"
| "Cod \<^bold>\<r>\<^bold>[t\<^bold>] = Cod t"
| "Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Cod t \<^bold>\<star> Src t"
| "Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Cod t \<^bold>\<star> (Cod u \<^bold>\<star> Cod v)"
| "Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Cod t \<^bold>\<star> Cod u) \<^bold>\<star> Cod v"
text \<open>
A term is a ``formal arrow'' if it is constructed from primitive arrows in such a way
that horizontal and vertical composition are applied only to formally composable pairs
of terms. The definitions of ``formal identity'' and ``formal object'' follow a
similar pattern.
\<close>
primrec Arr :: "'a term \<Rightarrow> bool"
where "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
| "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
| "Arr (t \<^bold>\<star> u) = (Arr t \<and> Arr u \<and> Src t = Trg u)"
| "Arr (t \<^bold>\<cdot> u) = (Arr t \<and> Arr u \<and> Dom t = Cod u)"
| "Arr \<^bold>\<l>\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<r>\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
| "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
primrec Ide :: "'a term \<Rightarrow> bool"
where "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
| "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
| "Ide (t \<^bold>\<star> u) = (Ide t \<and> Ide u \<and> Src t = Trg u)"
| "Ide (t \<^bold>\<cdot> u) = False"
| "Ide \<^bold>\<l>\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<r>\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
| "Ide \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
primrec Obj :: "'a term \<Rightarrow> bool"
where "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
| "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle> = False"
| "Obj (t \<^bold>\<star> u) = False"
| "Obj (t \<^bold>\<cdot> u) = False"
| "Obj \<^bold>\<l>\<^bold>[t\<^bold>] = False"
| "Obj \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
| "Obj \<^bold>\<r>\<^bold>[t\<^bold>] = False"
| "Obj \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
| "Obj \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
| "Obj \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
abbreviation HSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
where "HSeq t u \<equiv> Arr t \<and> Arr u \<and> Src t = Trg u"
abbreviation VSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
where "VSeq t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Cod u"
abbreviation HPar :: "'a term => 'a term \<Rightarrow> bool"
where "HPar t u \<equiv> Arr t \<and> Arr u \<and> Src t = Src u \<and> Trg t = Trg u"
abbreviation VPar :: "'a term => 'a term \<Rightarrow> bool"
where "VPar t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Dom u \<and> Cod t = Cod u"
abbreviation HHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
where "HHom a b \<equiv> { t. Arr t \<and> Src t = a \<and> Trg t = b }"
abbreviation VHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
where "VHom f g \<equiv> { t. Arr t \<and> Dom t = f \<and> Cod t = g }"
lemma is_Prim0_Src:
shows "is_Prim\<^sub>0 (Src t)"
by (induct t; simp)
lemma is_Prim0_Trg:
shows "is_Prim\<^sub>0 (Trg t)"
by (induct t; simp)
lemma Src_Src [simp]:
shows "Arr t \<Longrightarrow> Src (Src t) = Src t"
by (induct t) auto
lemma Trg_Trg [simp]:
shows "Arr t \<Longrightarrow> Trg (Trg t) = Trg t"
by (induct t) auto
lemma Src_Trg [simp]:
shows "Arr t \<Longrightarrow> Src (Trg t) = Trg t"
by (induct t) auto
lemma Trg_Src [simp]:
shows "Arr t \<Longrightarrow> Trg (Src t) = Src t"
by (induct t) auto
lemma Dom_Src [simp]:
shows "Arr t \<Longrightarrow> Dom (Src t) = Src t"
by (induct t) auto
lemma Dom_Trg [simp]:
shows "Arr t \<Longrightarrow> Dom (Trg t) = Trg t"
by (induct t) auto
lemma Cod_Src [simp]:
shows "Arr t \<Longrightarrow> Cod (Src t) = Src t"
by (induct t) auto
lemma Cod_Trg [simp]:
shows "Arr t \<Longrightarrow> Cod (Trg t) = Trg t"
by (induct t) auto
lemma Src_Dom_Cod:
shows "Arr t \<Longrightarrow> Src (Dom t) = Src t \<and> Src (Cod t) = Src t"
using src_dom src_cod by (induct t) auto
lemma Src_Dom [simp]:
shows "Arr t \<Longrightarrow> Src (Dom t) = Src t"
using Src_Dom_Cod by blast
lemma Src_Cod [simp]:
shows "Arr t \<Longrightarrow> Src (Cod t) = Src t"
using Src_Dom_Cod by blast
lemma Trg_Dom_Cod:
shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t \<and> Trg (Cod t) = Trg t"
using trg_dom trg_cod by (induct t) auto
lemma Trg_Dom [simp]:
shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t"
using Trg_Dom_Cod by blast
lemma Trg_Cod [simp]:
shows "Arr t \<Longrightarrow> Trg (Cod t) = Trg t"
using Trg_Dom_Cod by blast
lemma VSeq_implies_HPar:
shows "VSeq t u \<Longrightarrow> HPar t u"
using Src_Dom [of t] Src_Cod [of u] Trg_Dom [of t] Trg_Cod [of u] by auto
lemma Dom_Dom [simp]:
shows "Arr t \<Longrightarrow> Dom (Dom t) = Dom t"
by (induct t, auto)
lemma Cod_Cod [simp]:
shows "Arr t \<Longrightarrow> Cod (Cod t) = Cod t"
by (induct t, auto)
lemma Dom_Cod [simp]:
shows "Arr t \<Longrightarrow> Dom (Cod t) = Cod t"
by (induct t, auto)
lemma Cod_Dom [simp]:
shows "Arr t \<Longrightarrow> Cod (Dom t) = Dom t"
by (induct t, auto)
lemma Obj_implies_Ide [simp]:
shows "Obj t \<Longrightarrow> Ide t"
by (induct t) auto
lemma Ide_implies_Arr [simp]:
shows "Ide t \<Longrightarrow> Arr t"
by (induct t, auto)
lemma Dom_Ide:
shows "Ide t \<Longrightarrow> Dom t = t"
by (induct t, auto)
lemma Cod_Ide:
shows "Ide t \<Longrightarrow> Cod t = t"
by (induct t, auto)
lemma Obj_Src [simp]:
shows "Arr t \<Longrightarrow> Obj (Src t)"
by (induct t) auto
lemma Obj_Trg [simp]:
shows "Arr t \<Longrightarrow> Obj (Trg t)"
by (induct t) auto
lemma Ide_Dom [simp]:
shows "Arr t \<Longrightarrow> Ide (Dom t)"
by (induct t, auto)
lemma Ide_Cod [simp]:
shows "Arr t \<Longrightarrow> Ide (Cod t)"
by (induct t, auto)
lemma Arr_in_Hom:
assumes "Arr t"
shows "t \<in> HHom (Src t) (Trg t)" and "t \<in> VHom (Dom t) (Cod t)"
proof -
have 1: "Arr t \<Longrightarrow> t \<in> HHom (Src t) (Trg t) \<and> t \<in> VHom (Dom t) (Cod t)"
by (induct t, auto)
show "t \<in> HHom (Src t) (Trg t)" using assms 1 by simp
show "t \<in> VHom (Dom t) (Cod t)" using assms 1 by simp
qed
lemma Ide_in_Hom:
assumes "Ide t"
shows "t \<in> HHom (Src t) (Trg t)" and "t \<in> VHom t t"
proof -
have 1: "Ide t \<Longrightarrow> t \<in> HHom (Src t) (Trg t) \<and> t \<in> VHom t t"
by (induct t, auto)
show "t \<in> HHom (Src t) (Trg t)" using assms 1 by simp
show "t \<in> VHom t t" using assms 1 by simp
qed
lemma Obj_in_Hom:
assumes "Obj t"
shows "t \<in> HHom t t" and "t \<in> VHom t t"
proof -
have 1: "Obj t \<Longrightarrow> t \<in> HHom t t \<and> t \<in> VHom t t"
by (induct t, auto)
show "t \<in> HHom t t" using assms 1 by simp
show "t \<in> VHom t t" using assms 1 by simp
qed
text \<open>
A formal arrow is ``canonical'' if the only primitive arrows used in its construction
are objects and identities.
\<close>
primrec Can :: "'a term \<Rightarrow> bool"
where "Can \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
| "Can \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
| "Can (t \<^bold>\<star> u) = (Can t \<and> Can u \<and> Src t = Trg u)"
| "Can (t \<^bold>\<cdot> u) = (Can t \<and> Can u \<and> Dom t = Cod u)"
| "Can \<^bold>\<l>\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<r>\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v)"
| "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v)"
lemma Ide_implies_Can:
shows "Ide t \<Longrightarrow> Can t"
by (induct t, auto)
lemma Can_implies_Arr:
shows "Can t \<Longrightarrow> Arr t"
by (induct t, auto)
text \<open>
Canonical arrows can be formally inverted.
\<close>
primrec Inv :: "'a term \<Rightarrow> 'a term"
where "Inv \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
| "Inv \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>inv \<mu>\<^bold>\<rangle>"
| "Inv (t \<^bold>\<star> u) = (Inv t \<^bold>\<star> Inv u)"
| "Inv (t \<^bold>\<cdot> u) = (Inv u \<^bold>\<cdot> Inv t)"
| "Inv \<^bold>\<l>\<^bold>[t\<^bold>] = \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<l>\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<r>\<^bold>[t\<^bold>] = \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<r>\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
| "Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
lemma Src_Inv [simp]:
shows "Can t \<Longrightarrow> Src (Inv t) = Src t"
using Can_implies_Arr VSeq_implies_HPar
apply (induct t, auto)
by metis
lemma Trg_Inv [simp]:
shows "Can t \<Longrightarrow> Trg (Inv t) = Trg t"
using Can_implies_Arr VSeq_implies_HPar
apply (induct t, auto)
by metis
lemma Dom_Inv [simp]:
shows "Can t \<Longrightarrow> Dom (Inv t) = Cod t"
by (induct t, auto)
lemma Cod_Inv [simp]:
shows "Can t \<Longrightarrow> Cod (Inv t) = Dom t"
by (induct t, auto)
lemma Inv_preserves_Ide:
shows "Ide t \<Longrightarrow> Ide (Inv t)"
using Ide_implies_Can by (induct t, auto)
lemma Can_Inv [simp]:
shows "Can t \<Longrightarrow> Can (Inv t)"
by (induct t, auto)
lemma Inv_in_Hom [intro]:
assumes "Can t"
shows "Inv t \<in> HHom (Src t) (Trg t)" and "Inv t \<in> VHom (Cod t) (Dom t)"
using assms Can_Inv Can_implies_Arr by simp_all
lemma Inv_Ide [simp]:
assumes "Ide a"
shows "Inv a = a"
using assms by (induct a, auto)
lemma Inv_Inv [simp]:
assumes "Can t"
shows "Inv (Inv t) = t"
using assms by (induct t, auto)
subsection "Normal Terms"
text \<open>
We call a term ``normal'' if it is either a formal object or it is constructed from
primitive arrows using only horizontal composition associated to the right.
Essentially, such terms are (typed) composable sequences of arrows of @{term V},
where the empty list is represented by a formal object and \<open>\<^bold>\<star>\<close> is used as
the list constructor.
\<close>
fun Nml :: "'a term \<Rightarrow> bool"
where "Nml \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
| "Nml \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
| "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> u) = (arr \<nu> \<and> Nml u \<and> \<not> is_Prim\<^sub>0 u \<and> \<^bold>\<langle>src \<nu>\<^bold>\<rangle>\<^sub>0 = Trg u)"
| "Nml _ = False"
lemma Nml_HcompD:
assumes "Nml (t \<^bold>\<star> u)"
shows "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" and "arr (un_Prim t)" and "Nml t" and "Nml u"
and "\<not> is_Prim\<^sub>0 u" and "\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u" and "Src t = Trg u"
proof -
have 1: "t = \<^bold>\<langle>un_Prim t\<^bold>\<rangle> \<and> arr (un_Prim t) \<and> Nml t \<and> Nml u \<and> \<not> is_Prim\<^sub>0 u \<and>
\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u"
using assms by (cases t; simp; cases u; simp)
show "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" using 1 by simp
show "arr (un_Prim t)" using 1 by simp
show "Nml t" using 1 by simp
show "Nml u" using 1 by simp
show "\<not> is_Prim\<^sub>0 u" using 1 by simp
show "\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u" using 1 by simp
show "Src t = Trg u"
using assms
apply (cases t) by simp_all
qed
lemma Nml_implies_Arr:
shows "Nml t \<Longrightarrow> Arr t"
apply (induct t, auto)
using Nml_HcompD by simp_all
lemma Nml_Src [simp]:
shows "Nml t \<Longrightarrow> Nml (Src t)"
apply (induct t, simp_all)
using Nml_HcompD by metis
lemma Nml_Trg [simp]:
shows "Nml t \<Longrightarrow> Nml (Trg t)"
apply (induct t, simp_all)
using Nml_HcompD by metis
lemma Nml_Dom [simp]:
shows "Nml t \<Longrightarrow> Nml (Dom t)"
proof (induct t, simp_all add: Nml_HcompD)
fix u v
assume I1: "Nml (Dom u)"
assume I2: "Nml (Dom v)"
assume uv: "Nml (u \<^bold>\<star> v)"
show "Nml (Dom u \<^bold>\<star> Dom v)"
proof -
have 1: "is_Prim (Dom u) \<and> arr (un_Prim (Dom u)) \<and> Dom u = \<^bold>\<langle>dom (un_Prim u)\<^bold>\<rangle>"
using uv by (cases u; simp; cases v, simp_all)
have 2: "Nml v \<and> \<not> is_Prim\<^sub>0 v \<and> \<not> is_Vcomp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
using uv by (cases u, simp_all; cases v, simp_all)
have "arr (dom (un_Prim u))"
using 1 by fastforce
moreover have "Nml (Dom v) \<and> \<not> is_Prim\<^sub>0 v"
using 2 I2 by (cases v, simp_all)
moreover have "\<^bold>\<langle>src (dom (un_Prim u))\<^bold>\<rangle>\<^sub>0 = Trg (Dom v)"
proof -
have "Trg (Dom v) = Src (Dom u)"
using uv Nml_implies_Arr by fastforce
also have "... = \<^bold>\<langle>src (dom (un_Prim u))\<^bold>\<rangle>\<^sub>0"
using 1 by fastforce
finally show ?thesis by argo
qed
moreover have "\<not> is_Prim\<^sub>0 (Dom v)"
using 2 by (cases v, simp_all)
ultimately show ?thesis using 1 2 by simp
qed
qed
lemma Nml_Cod [simp]:
shows "Nml t \<Longrightarrow> Nml (Cod t)"
proof (induct t, simp_all add: Nml_HcompD)
fix u v
assume I1: "Nml (Cod u)"
assume I2: "Nml (Cod v)"
assume uv: "Nml (u \<^bold>\<star> v)"
show "Nml (Cod u \<^bold>\<star> Cod v)"
proof -
have 1: "is_Prim (Cod u) \<and> arr (un_Prim (Cod u)) \<and> Cod u = \<^bold>\<langle>cod (un_Prim u)\<^bold>\<rangle>"
using uv by (cases u; simp; cases v, simp_all)
have 2: "Nml v \<and> \<not> is_Prim\<^sub>0 v \<and> \<not> is_Vcomp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
using uv by (cases u; simp; cases v, simp_all)
have "arr (cod (un_Prim u))"
using 1 by fastforce
moreover have "Nml (Cod v) \<and> \<not> is_Prim\<^sub>0 v"
using 2 I2 by (cases v, simp_all)
moreover have "\<^bold>\<langle>src (cod (un_Prim u))\<^bold>\<rangle>\<^sub>0 = Trg (Cod v)"
proof -
have "Trg (Cod v) = Src (Cod u)"
using uv Nml_implies_Arr by fastforce
also have "... = \<^bold>\<langle>src (cod (un_Prim u))\<^bold>\<rangle>\<^sub>0"
using 1 by fastforce
finally show ?thesis by argo
qed
moreover have "\<not> is_Prim\<^sub>0 (Cod v)"
using 2 by (cases v; simp)
ultimately show ?thesis using 1 2 by simp
qed
qed
lemma Nml_Inv [simp]:
assumes "Can t" and "Nml t"
shows "Nml (Inv t)"
proof -
have "Can t \<and> Nml t \<Longrightarrow> Nml (Inv t)"
apply (induct t, simp_all)
proof -
fix u v
assume I1: "Nml u \<Longrightarrow> Nml (Inv u)"
assume I2: "Nml v \<Longrightarrow> Nml (Inv v)"
assume uv: "Can u \<and> Can v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
show "Nml (Inv u \<^bold>\<star> Inv v)"
proof -
have u: "Arr u \<and> Can u" using uv Can_implies_Arr by blast
have v: "Arr v \<and> Can v" using uv Can_implies_Arr by blast
have 1: "\<^bold>\<langle>un_Prim u\<^bold>\<rangle> = u \<and> ide (un_Prim u) \<and> Nml u \<and> Nml v \<and> \<not> is_Prim\<^sub>0 v \<and>
\<^bold>\<langle>src (un_Prim u)\<^bold>\<rangle>\<^sub>0 = Trg v"
using uv Nml_HcompD [of u v] apply simp
using uv by (cases u, simp_all)
have 2: "\<^bold>\<langle>un_Prim (Inv u)\<^bold>\<rangle> = Inv u \<and> arr (un_Prim (Inv u)) \<and> Nml (Inv u)"
using 1 by (cases u; simp)
moreover have "Nml (Inv v) \<and> \<not> is_Prim\<^sub>0 (Inv v)"
using 1 I2 by (cases v, simp_all)
moreover have "\<^bold>\<langle>src (un_Prim (Inv u))\<^bold>\<rangle>\<^sub>0 = Trg (Inv v)"
using 1 2 v by (cases u, simp_all)
ultimately show ?thesis
by (cases u, simp_all)
qed
qed
thus ?thesis using assms by blast
qed
text \<open>
The following function defines a horizontal composition for normal terms.
If such terms are regarded as lists, this is just (typed) list concatenation.
\<close>
fun HcompNml (infixr "\<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor>" 53)
where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
| "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
| "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> u"
| "(t \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
| "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = undefined"
lemma HcompNml_Prim [simp]:
assumes "\<not> is_Prim\<^sub>0 t"
shows "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = \<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> t"
using assms by (cases t, simp_all)
lemma HcompNml_term_Prim\<^sub>0 [simp]:
assumes "Src t = Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
using assms by (cases t, simp_all)
lemma HcompNml_Nml:
assumes "Nml (t \<^bold>\<star> u)"
shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t \<^bold>\<star> u"
using assms HcompNml_Prim by (metis Nml_HcompD(1) Nml_HcompD(5))
lemma Nml_HcompNml:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
and "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u"
and "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u"
and "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u"
and "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
proof -
have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow>
Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
proof (induct t, simp_all add: Nml_HcompD(1-4))
fix \<nu> :: 'a and u :: "'a term"
assume \<nu>: "arr \<nu>"
assume u: "Nml u"
assume 1: "\<^bold>\<langle>src \<nu>\<^bold>\<rangle>\<^sub>0 = Trg u"
show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>dom \<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
Src (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>trg \<nu>\<^bold>\<rangle>\<^sub>0"
using u \<nu> 1 by (cases u, simp_all)
next
fix u v w
assume I1: "\<And>x. Nml x \<Longrightarrow> Src v = Trg x \<Longrightarrow>
Nml (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) \<and> Dom (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom x \<and>
Cod (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod x \<and>
Src (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Src x \<and> Trg (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Trg v"
assume I2: "\<And>x. Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
Nml (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom x \<and>
Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod x \<and>
Src (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Src x \<and> Trg (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Trg w"
assume vw: "Nml (v \<^bold>\<star> w)"
assume u: "Nml u"
assume wu: "Src w = Trg u"
show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Dom v \<^bold>\<star> Dom w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Cod v \<^bold>\<star> Cod w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
Src ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg v"
proof -
have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> Nml v"
using vw Nml_implies_Arr Nml_HcompD by metis
have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
using vw by (simp add: Nml_HcompD)
have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis" by (cases u; simp add: vw wu)
moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
proof -
assume 1: "\<not> is_Prim\<^sub>0 u"
have "Src v = Trg (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using u v w I2 [of u] by (cases v, simp_all)
hence "Nml (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
Dom (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
Cod (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
Src (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg v"
using u v w I1 [of "w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u"] I2 [of u] by argo
moreover have "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = (v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u"
using 1 by (cases u, simp_all)
moreover have "(Dom v \<^bold>\<star> Dom w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using v w u vw 1 I2 Nml_Dom HcompNml_Prim Nml_HcompD(1) Nml_HcompD(5)
by (cases u, simp_all)
moreover have "(Cod v \<^bold>\<star> Cod w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using v w u vw 1 I2 Nml_HcompD(1) Nml_HcompD(5) HcompNml_Prim
by (cases u, simp_all)
ultimately show ?thesis
by argo
qed
ultimately show ?thesis by blast
qed
next
fix a u
assume a: "obj a"
assume u: "Nml u"
assume au: "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = Trg u"
show "Nml (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
Dom (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
Cod (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
Src (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg (Trg u)"
using au
by (metis Cod.simps(1) Dom.simps(1) HcompNml.simps(1) Trg.simps(1) u)
qed
show "Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) " using assms 0 by blast
show "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u" using assms 0 by blast
show "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u" using assms 0 by blast
show "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u" using assms 0 by blast
show "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t" using assms 0 by blast
qed
lemma HcompNml_in_Hom [intro]:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg t)"
and "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<in> VHom (Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u) (Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)"
using assms Nml_HcompNml Nml_implies_Arr by auto
lemma Src_HcompNml:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u"
using assms Nml_HcompNml(4) by simp
lemma Trg_HcompNml:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
using assms Nml_HcompNml(5) by simp
lemma Dom_HcompNml:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u"
using assms Nml_HcompNml(2) by simp
lemma Cod_HcompNml:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u"
using assms Nml_HcompNml(3) by simp
lemma is_Hcomp_HcompNml:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
and "\<not> is_Prim\<^sub>0 t" and "\<not> is_Prim\<^sub>0 u"
shows "is_Hcomp (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
proof -
have "\<lbrakk> \<not> is_Hcomp (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u); Nml t; Nml u; Src t = Trg u; \<not> is_Prim\<^sub>0 t; \<not> is_Prim\<^sub>0 u \<rbrakk>
\<Longrightarrow> False"
proof (induct t, simp_all add: Nml_HcompD)
fix a
assume a: "obj a"
assume u: "Nml u"
assume 1: "\<not> is_Hcomp u"
assume 2: "\<not> is_Prim\<^sub>0 (Trg u)"
show "False"
using u 1 2 by (cases u; simp)
next
fix v w
assume I2: "\<not> is_Hcomp (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<Longrightarrow> False"
assume vw: "Nml (v \<^bold>\<star> w)"
assume u: "Nml u"
assume 1: "\<not> is_Hcomp ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
assume 2: "\<not> is_Prim\<^sub>0 u"
assume 3: "Src w = Trg u"
show "False"
proof -
have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle>"
using vw Nml_HcompD by force
have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
using vw Nml_HcompD [of v w] by blast
have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
proof -
have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using u v 2 by (cases u, simp_all)
also have "... = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using u w I2 by fastforce
also have "... = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using v by simp
finally show ?thesis by simp
qed
thus ?thesis using 1 by simp
qed
qed
thus ?thesis using assms by blast
qed
text \<open>
The following function defines the ``dimension'' of a term,
which is the number of inputs (or outputs) when the term is regarded as an
interconnection matrix.
For normal terms, this is just the length of the term when regarded as a list
of arrows of @{term C}.
This function is used as a ranking of terms in the subsequent associativity proof.
\<close>
primrec dim :: "'a term \<Rightarrow> nat"
where "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = 0"
| "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle> = 1"
| "dim (t \<^bold>\<star> u) = (dim t + dim u)"
| "dim (t \<^bold>\<cdot> u) = dim t"
| "dim \<^bold>\<l>\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<r>\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
| "dim \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
lemma HcompNml_assoc:
assumes "Nml t" and "Nml u" and "Nml v" and "Src t = Trg u" and "Src u = Trg v"
shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
proof -
have "\<And>n t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
proof -
fix n
show "\<And>t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
proof (induction n rule: nat_less_induct)
fix n :: nat and t :: "'a term" and u v
assume I: "\<forall>m<n. \<forall>t u v. dim t = m \<longrightarrow> Nml t \<longrightarrow> Nml u \<longrightarrow> Nml v \<longrightarrow>
Src t = Trg u \<longrightarrow> Src u = Trg v \<longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
assume dim: "dim t = n"
assume t: "Nml t"
assume u: "Nml u"
assume v: "Nml v"
assume tu: "Src t = Trg u"
assume uv: "Src u = Trg v"
show "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
proof -
have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis" by (cases t; simp)
moreover have "\<not>is_Prim\<^sub>0 t \<Longrightarrow> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
by (cases t; simp; cases u; simp)
moreover have "\<not> is_Prim\<^sub>0 t \<Longrightarrow> \<not> is_Prim\<^sub>0 u \<Longrightarrow> is_Prim\<^sub>0 v \<Longrightarrow> ?thesis"
proof -
assume 1: "\<not> is_Prim\<^sub>0 t"
assume 2: "\<not> is_Prim\<^sub>0 u"
assume 3: "is_Prim\<^sub>0 v"
have "\<not>is_Prim\<^sub>0 (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using 1 2 t u tu is_Hcomp_HcompNml [of t u]
by (cases t, simp, cases u, auto)
thus ?thesis
using 1 2 3 tu uv by (cases v, simp, cases "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u", simp_all)
qed
moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Prim t \<Longrightarrow> ?thesis"
using v by (cases t, simp_all, cases u, simp_all; cases v, simp_all)
moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Hcomp t \<Longrightarrow> ?thesis"
proof (cases t, simp_all)
fix w :: "'a term" and x :: "'a term"
assume 1: " \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v"
assume 2: "t = (w \<^bold>\<star> x)"
show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
proof -
have w: "w = \<^bold>\<langle>un_Prim w\<^bold>\<rangle>"
using t 1 2 Nml_HcompD by auto
have x: "Nml x"
using t w 1 2 by (metis Nml.simps(3))
have "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
using u v w x 1 2 by (cases u, simp_all)
also have "... = (w \<^bold>\<star> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
using t w u 1 2 HcompNml_Prim is_Hcomp_HcompNml Nml_HcompD
by (metis Src.simps(3) term.distinct_disc(3) tu)
also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
using u v w x 1 by (cases u, simp_all; cases v, simp_all)
also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v))"
proof -
have "dim x < dim t"
using 2 w by (cases w; simp)
moreover have "Src x = Trg u \<and> Src u = Trg v"
using tu uv 2 by auto
ultimately show ?thesis
using u v x dim I by simp
qed
also have "... = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
proof -
have 3: "is_Hcomp (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
using u v uv 1 is_Hcomp_HcompNml by auto
obtain u' :: "'a term" and v' where uv': "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = u' \<^bold>\<star> v'"
using 3 is_Hcomp_def by blast
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
qed
moreover have "is_Prim\<^sub>0 t \<or> is_Prim t \<or> is_Hcomp t"
using t by (cases t, simp_all)
ultimately show ?thesis by blast
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma HcompNml_Trg_Nml:
assumes "Nml t"
shows "Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
proof -
have "Nml t \<Longrightarrow> Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
proof (induct t, simp_all add: Nml_HcompD)
fix u v
assume uv: "Nml (u \<^bold>\<star> v)"
assume I1: "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
using uv Nml_HcompD by blast
have 2: "Trg (u \<^bold>\<star> v) = Trg u"
using uv by auto
show "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = u \<^bold>\<star> v"
proof -
have "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
using uv HcompNml_Nml by simp
also have "... = (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
using 1 2 HcompNml_assoc Src_Trg Nml_Trg Nml_implies_Arr by simp
also have "... = u \<^bold>\<star> v"
using I1 uv HcompNml_Nml by simp
finally show ?thesis by simp
qed
qed
thus ?thesis using assms by simp
qed
lemma HcompNml_Nml_Src:
assumes "Nml t"
shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
proof -
have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
proof (induct t, simp_all add: Nml_HcompD)
fix u v
assume uv: "Nml (u \<^bold>\<star> v)"
assume I2: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = v"
have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
using uv Nml_HcompD by blast
have 2: "Src (u \<^bold>\<star> v) = Src v"
using uv Trg_HcompNml by auto
show "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = u \<^bold>\<star> v"
proof -
have "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v"
using uv HcompNml_Nml by simp
also have "... = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v)"
using 1 2 HcompNml_assoc Trg_Src Nml_Src Nml_implies_Arr by simp
also have "... = u \<^bold>\<star> v"
using I2 uv HcompNml_Nml by simp
finally show ?thesis by simp
qed
qed
thus ?thesis using assms by simp
qed
lemma HcompNml_Obj_Nml:
assumes "Obj t" and "Nml u" and "Src t = Trg u"
shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
using assms by (cases t, simp_all add: HcompNml_Trg_Nml)
lemma HcompNml_Nml_Obj:
assumes "Nml t" and "Obj u" and "Src t = Trg u"
shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t"
using assms by (cases u, simp_all)
lemma Ide_HcompNml:
assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
shows "Ide (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using assms
by (metis (mono_tags, lifting) Nml_HcompNml(1) Nml_implies_Arr Dom_HcompNml
Ide_Dom Ide_in_Hom(2) mem_Collect_eq)
lemma Can_HcompNml:
assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
shows "Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow> Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
by (metis Ide.simps(1-2) Ide_implies_Can Can.simps(3) Nml.elims(2)
Nml.simps(2) HcompNml.simps(12) HcompNml_Prim Ide_HcompNml
Src.simps(2) term.disc(2))
show "\<And>v w u.
(\<And>u. Nml v \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> Trg w = Trg u \<Longrightarrow> Can (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<Longrightarrow>
(\<And>ua. Nml w \<Longrightarrow> Can ua \<and> Nml ua \<Longrightarrow> Trg u = Trg ua \<Longrightarrow> Can (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ua)) \<Longrightarrow>
Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w) \<Longrightarrow>
Can u \<and> Nml u \<Longrightarrow> Src w = Trg u \<Longrightarrow> Can ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
by (metis Nml_HcompD(3-4) HcompNml_Nml Nml_HcompNml(1)
HcompNml_assoc Trg_HcompNml)
qed
thus ?thesis using assms by blast
qed
lemma Inv_HcompNml:
assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
shows "Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk>
\<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg u \<rbrakk> \<Longrightarrow> Inv u = Inv (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
by (metis HcompNml.simps(1) Inv.simps(1))
show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow>
Inv (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
by (metis Ide.simps(2) HcompNml.simps(2) HcompNml_Prim Inv.simps(1,3)
Inv_Ide Inv_Inv is_Prim\<^sub>0_def)
fix v w u
assume I1: "\<And>x. Nml v \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg w = Trg x \<Longrightarrow>
Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
assume I2: "\<And>x. Nml w \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
assume wu: "Src w = Trg u"
assume u: "Can u \<and> Nml u"
have v: "Can v \<and> Nml v"
using vw Nml_HcompD by blast
have w: "Can w \<and> Nml w"
using v vw by (cases v, simp_all)
show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
proof -
have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
apply (cases u) by simp_all
moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
proof -
assume 1: "\<not> is_Prim\<^sub>0 u"
have "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u))"
using 1 by (cases u, simp_all)
also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using u v w vw wu I1 Nml_HcompNml Can_HcompNml Nml_Inv Can_Inv
by simp
also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u)"
using u v w I2 Nml_HcompNml by simp
also have "... = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
using v 1 by (cases u, simp_all)
finally show ?thesis by blast
qed
ultimately show ?thesis by blast
qed
qed
thus ?thesis using assms by blast
qed
text \<open>
The following function defines vertical composition for compatible normal terms,
by ``pushing the composition down'' to arrows of @{text V}.
\<close>
fun VcompNml :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term" (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = u"
| "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>\<nu> \<cdot> \<mu>\<^bold>\<rangle>"
| "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (w \<^bold>\<star> x) = (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<^bold>\<star> v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
| "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
| "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> _ = undefined \<^bold>\<cdot> undefined"
text \<open>
Note that the last clause above is not relevant to normal terms.
We have chosen a provably non-normal value in order to validate associativity.
\<close>
lemma Nml_VcompNml:
assumes "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
and "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
and "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
proof -
have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
proof (induct t, simp_all add: Nml_HcompD)
show "\<And>x u. obj x \<Longrightarrow> Nml u \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow>
Nml (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
Cod (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod (Cod u)"
by (metis Cod.simps(1) VcompNml.simps(1))
fix \<nu> u
assume \<nu>: "arr \<nu>"
assume u: "Nml u"
assume 1: "\<^bold>\<langle>dom \<nu>\<^bold>\<rangle> = Cod u"
show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle>"
using \<nu> u 1 by (cases u, simp_all)
next
fix u v w
assume I2: "\<And>u. \<lbrakk> Nml u; Dom w = Cod u \<rbrakk> \<Longrightarrow>
Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod w"
assume vw: "Nml (v \<^bold>\<star> w)"
have v: "Nml v"
using vw Nml_HcompD by force
have w: "Nml w"
using vw Nml_HcompD by force
assume u: "Nml u"
assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod v \<^bold>\<star> Cod w"
using u v w 1
proof (cases u, simp_all)
fix x y
assume 2: "u = x \<^bold>\<star> y"
have 4: "is_Prim x \<and> x = \<^bold>\<langle>un_Prim x\<^bold>\<rangle> \<and> arr (un_Prim x) \<and> Nml y \<and> \<not> is_Prim\<^sub>0 y"
using u 2 by (cases x, cases y, simp_all)
have 5: "is_Prim v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v) \<and> Nml w \<and> \<not> is_Prim\<^sub>0 w"
using v w vw by (cases v, simp_all)
have 6: "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
proof -
have "\<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w" using vw Nml_HcompD [of v w] by simp
thus "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
using 1 2 4 5 apply (cases u, simp_all)
by (metis Cod.simps(2) Dom.simps(2) term.simps(2))
qed
have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y"
using 2 4 5 6 VcompNml.simps(2) [of "un_Prim v" "un_Prim x"] by simp
moreover have "Nml (\<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
proof -
have "Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
using I2 4 5 6 by simp
moreover have "\<not> is_Prim\<^sub>0 (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
using vw 4 5 6 I2 Nml_Cod Nml_HcompD(5) is_Prim\<^sub>0_def
by (metis Cod.simps(1) Cod.simps(3))
moreover have "\<^bold>\<langle>src (un_Prim v \<cdot> un_Prim x)\<^bold>\<rangle>\<^sub>0 = Trg (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
using vw 4 5 6 I2 Nml_HcompD(6) Nml_implies_Arr
src.is_natural_1 src.preserves_comp_2 Trg_Cod src_cod
by (metis seqI)
ultimately show ?thesis
using 4 5 6 Nml.simps(3) [of "un_Prim v \<cdot> un_Prim x" "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"]
by simp
qed
ultimately show "Nml (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) \<and>
Dom (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Dom x \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Dom y \<and>
Cod (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Cod v \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Cod w"
using 4 5 6 I2
by (metis (no_types, lifting) Cod.simps(2) Dom.simps(2) VcompNml.simps(2)
cod_comp dom_comp seqI)
qed
qed
show "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)" using assms 0 by blast
show "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u" using assms 0 by blast
show "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t" using assms 0 by blast
qed
lemma VcompNml_in_Hom [intro]:
assumes "Nml t" and "Nml u" and "Dom t = Cod u"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg u)" and "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> VHom (Dom u) (Cod t)"
proof -
show 1: "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> VHom (Dom u) (Cod t)"
using assms Nml_VcompNml Nml_implies_Arr by simp
show "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg u)"
using assms 1 Src_Dom Trg_Dom Nml_implies_Arr by fastforce
qed
lemma Src_VcompNml:
assumes "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Src (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Src u"
using assms VcompNml_in_Hom by simp
lemma Trg_VcompNml:
assumes "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Trg (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Trg u"
using assms VcompNml_in_Hom by simp
lemma Dom_VcompNml:
assumes "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
using assms Nml_VcompNml(2) by simp
lemma Cod_VcompNml:
assumes "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
using assms Nml_VcompNml(3) by simp
lemma VcompNml_Cod_Nml [simp]:
assumes "Nml t"
shows "VcompNml (Cod t) t = t"
proof -
have "Nml t \<Longrightarrow> Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
apply (induct t)
by (auto simp add: Nml_HcompD comp_cod_arr)
thus ?thesis using assms by blast
qed
lemma VcompNml_Nml_Dom [simp]:
assumes "Nml t"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Dom t) = t"
proof -
have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
apply (induct t) by (auto simp add: Nml_HcompD comp_arr_dom)
thus ?thesis using assms by blast
qed
lemma VcompNml_Ide_Nml [simp]:
assumes "Nml t" and "Ide a" and "Dom a = Cod t"
shows "a \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
using assms Ide_in_Hom by simp
lemma VcompNml_Nml_Ide [simp]:
assumes "Nml t" and "Ide a" and "Dom t = Cod a"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> a = t"
using assms Ide_in_Hom by auto
lemma VcompNml_assoc:
assumes "Nml t" and "Nml u" and "Nml v"
and "Dom t = Cod u" and "Dom u = Cod v"
shows "(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
proof -
have "\<And>u v. \<lbrakk> Nml t; Nml u; Nml v; Dom t = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
proof (induct t, simp_all)
show "\<And>x u v. obj x \<Longrightarrow> Nml u \<Longrightarrow> Nml v \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow> Dom u = Cod v \<Longrightarrow>
u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
by (metis VcompNml.simps(1))
fix f u v
assume f: "arr f"
assume u: "Nml u"
assume v: "Nml v"
assume 1: "\<^bold>\<langle>dom f\<^bold>\<rangle> = Cod u"
assume 2: "Dom u = Cod v"
show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
using u v f 1 2 comp_assoc
apply (cases u)
apply simp_all
apply (cases v)
by simp_all
next
fix u v w x
assume I1: "\<And>u v. \<lbrakk> Nml w; Nml u; Nml v; Dom w = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume I2: "\<And>u v. \<lbrakk> Nml x; Nml u; Nml v; Dom x = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
(x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume wx: "Nml (w \<^bold>\<star> x)"
assume u: "Nml u"
assume v: "Nml v"
assume 1: "(Dom w \<^bold>\<star> Dom x) = Cod u"
assume 2: "Dom u = Cod v"
show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
proof -
have w: "Nml w"
using wx Nml_HcompD by blast
have x: "Nml x"
using wx Nml_HcompD by blast
have "is_Hcomp u"
using u 1 by (cases u) simp_all
thus ?thesis
using u v apply (cases u, simp_all, cases v, simp_all)
proof -
fix u1 u2 v1 v2
assume 3: "u = (u1 \<^bold>\<star> u2)"
assume 4: "v = (v1 \<^bold>\<star> v2)"
show "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<and>
(x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2 = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2"
proof -
have "Nml u1 \<and> Nml u2"
using u 3 Nml_HcompD by blast
moreover have "Nml v1 \<and> Nml v2"
using v 4 Nml_HcompD by blast
ultimately show ?thesis using w x I1 I2 1 2 3 4 by simp
qed
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma Ide_VcompNml:
assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Ide (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
proof -
have "\<And>u. \<lbrakk> Ide t; Ide u; Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Ide (VcompNml t u)"
by (induct t, simp_all)
thus ?thesis using assms by blast
qed
lemma Can_VcompNml:
assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
proof (induct t, simp_all)
fix t u v
assume I1: "\<And>v. \<lbrakk> Nml t; Can v \<and> Nml v; Dom t = Cod v \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume I2: "\<And>v. \<lbrakk> Nml u; Can v \<and> Nml v; Dom u = Cod v \<rbrakk> \<Longrightarrow> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume tu: "Can t \<and> Can u \<and> Src t = Trg u \<and> Nml (t \<^bold>\<star> u)"
have t: "Can t \<and> Nml t"
using tu Nml_HcompD by blast
have u: "Can u \<and> Nml u"
using tu Nml_HcompD by blast
assume v: "Can v \<and> Nml v"
assume 1: "(Dom t \<^bold>\<star> Dom u) = Cod v"
show "Can ((t \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
proof -
have 2: "(Dom t \<^bold>\<star> Dom u) = Cod v" using 1 by simp
show ?thesis
using v 2
proof (cases v; simp)
fix w x
assume wx: "v = (w \<^bold>\<star> x)"
have "Can w \<and> Nml w" using v wx Nml_HcompD Can.simps(3) by blast
moreover have "Can x \<and> Nml x" using v wx Nml_HcompD Can.simps(3) by blast
moreover have "Dom t = Cod w" using 2 wx by simp
moreover have ux: "Dom u = Cod x" using 2 wx by simp
ultimately show "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) \<and> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) \<and> Src (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) = Trg (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
using t u v tu wx I1 I2
by (metis Nml_HcompD(7) Src_VcompNml Trg_VcompNml)
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma Inv_VcompNml:
assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Dom t = Cod u"
shows "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
proof (induct t, simp_all)
show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<rbrakk> \<Longrightarrow> Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
by (simp add: Can_implies_Arr)
show "\<And>x u. \<lbrakk> ide x \<and> arr x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle> = Cod u \<rbrakk> \<Longrightarrow>
Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
by (simp add: Can_implies_Arr)
fix v w u
assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
have v: "Can v \<and> Nml w"
using vw Nml_HcompD by blast
have w: "Can w \<and> Nml w"
using vw Nml_HcompD by blast
assume I1: "\<And>x. \<lbrakk> Nml v; Can x \<and> Nml x; Dom v = Cod x \<rbrakk> \<Longrightarrow>
Inv (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv v"
assume I2: "\<And>x. \<lbrakk> Nml w; Can x \<and> Nml x; Dom w = Cod x \<rbrakk> \<Longrightarrow>
Inv (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv w"
assume u: "Can u \<and> Nml u"
assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv w)"
using v 1
proof (cases w, simp_all)
show "\<And>\<mu>. obj \<mu> \<Longrightarrow> Dom v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow> w = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> Can v \<Longrightarrow>
Inv ((v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0)"
using Nml_HcompD(5) is_Prim\<^sub>0_def vw by blast
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Dom v \<^bold>\<star> \<^bold>\<langle>dom \<mu>\<^bold>\<rangle> = Cod u \<Longrightarrow> w = \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<Longrightarrow> Can v \<Longrightarrow>
Inv ((v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> \<^bold>\<langle>inv \<mu>\<^bold>\<rangle>)"
by (metis Ide.simps(2) Can.simps(2) Nml_HcompD(1) Dom.simps(2) Inv_Ide
Dom_Inv Nml_Inv ideD(2) inv_ide VcompNml_Cod_Nml VcompNml_Nml_Dom
u vw)
show "\<And>y z. Nml (y \<^bold>\<star> z) \<Longrightarrow> Dom v \<^bold>\<star> Dom y \<^bold>\<star> Dom z = Cod u \<Longrightarrow>
w = y \<^bold>\<star> z \<Longrightarrow> Can v \<Longrightarrow>
Inv ((v \<^bold>\<star> y \<^bold>\<star> z) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv y \<^bold>\<star> Inv z)"
proof -
fix y z
assume 2: "Nml (y \<^bold>\<star> z)"
assume yz: "w = y \<^bold>\<star> z"
show "Inv ((v \<^bold>\<star> y \<^bold>\<star> z) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv y \<^bold>\<star> Inv z)"
using u vw yz I1 I2 1 2 VcompNml_Nml_Ide
apply (cases u)
apply simp_all
by (metis Nml_HcompD(3-4))
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma Can_and_Nml_implies_Ide:
assumes "Can t" and "Nml t"
shows "Ide t"
proof -
have "\<lbrakk> Can t; Nml t \<rbrakk> \<Longrightarrow> Ide t"
apply (induct t) by (simp_all add: Nml_HcompD)
thus ?thesis using assms by blast
qed
lemma VcompNml_Can_Inv [simp]:
assumes "Can t" and "Nml t"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t = Cod t"
using assms Can_and_Nml_implies_Ide Ide_in_Hom by simp
lemma VcompNml_Inv_Can [simp]:
assumes "Can t" and "Nml t"
shows "Inv t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = Dom t"
using assms Can_and_Nml_implies_Ide Ide_in_Hom by simp
text \<open>
The next fact is a syntactic version of the interchange law, for normal terms.
\<close>
lemma VcompNml_HcompNml:
assumes "Nml t" and "Nml u" and "Nml v" and "Nml w"
and "VSeq t v" and "VSeq u w" and "Src v = Trg w"
shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have "\<And>u v w. \<lbrakk> Nml t; Nml u; Nml v; Nml w; VSeq t v; VSeq u w;
Src t = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof (induct t, simp_all)
fix u v w x
assume u: "Nml u"
assume v: "Nml v"
assume w: "Nml w"
assume uw: "VSeq u w"
show "\<And>x. Arr v \<and> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod v \<Longrightarrow> (Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
using u v w uw by (cases v) simp_all
show "\<And>x. \<lbrakk> arr x; Arr v \<and> \<^bold>\<langle>dom x\<^bold>\<rangle> = Cod v; \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
proof -
fix x
assume x: "arr x"
assume 1: "Arr v \<and> \<^bold>\<langle>dom x\<^bold>\<rangle> = Cod v"
assume tu: "\<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u"
assume vw: "Src v = Trg w"
show "(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
proof -
have 2: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v)" using v 1 by (cases v) simp_all
have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
using u v w x tu uw vw 1 2 Cod.simps(3) VcompNml_Cod_Nml Dom.simps(2)
HcompNml_Prim HcompNml_term_Prim\<^sub>0 Nml_HcompNml(3) HcompNml_Trg_Nml
apply (cases u, simp_all)
by (cases w, simp_all add: Src_VcompNml)
moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
proof -
assume 3: "\<not> is_Prim\<^sub>0 u"
hence 4: "\<not> is_Prim\<^sub>0 w" using u w uw by (cases u, simp_all; cases w, simp_all)
have "(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<star> w)"
proof -
have "\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> u"
using u x 3 HcompNml_Nml by (cases u, simp_all)
moreover have "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w = v \<^bold>\<star> w"
using w 2 4 HcompNml_Nml by (cases v, simp_all; cases w, simp_all)
ultimately show ?thesis by simp
qed
also have 5: "... = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<star> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)" by simp
also have "... = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
using x u w uw vw 1 2 3 4 5
HcompNml_Nml HcompNml_Prim Nml_HcompNml(1)
by (metis Cod.simps(3) Nml.simps(3) Dom.simps(2) Dom.simps(3)
Nml_VcompNml(1) tu v)
finally show ?thesis by blast
qed
ultimately show ?thesis by blast
qed
qed
fix t1 t2
assume t12: "Nml (t1 \<^bold>\<star> t2)"
assume I1: "\<And>u v w. \<lbrakk> Nml t1; Nml u; Nml v; Nml w;
Arr v \<and> Dom t1 = Cod v; VSeq u w;
Trg t2 = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
(t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
assume I2: "\<And>u' v w. \<lbrakk> Nml t2; Nml u'; Nml v; Nml w;
Arr v \<and> Dom t2 = Cod v; VSeq u' w;
Trg u = Trg u'; Src v = Trg w \<rbrakk> \<Longrightarrow>
(t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u') \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u' \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
have t1: "t1 = \<^bold>\<langle>un_Prim t1\<^bold>\<rangle> \<and> arr (un_Prim t1) \<and> Nml t1"
using t12 by (cases t1, simp_all)
have t2: "Nml t2 \<and> \<not>is_Prim\<^sub>0 t2"
using t12 by (cases t1, simp_all)
assume vw: "Src v = Trg w"
assume tu: "Src t2 = Trg u"
assume 1: "Arr t1 \<and> Arr t2 \<and> Src t1 = Trg t2 \<and> Arr v \<and> (Dom t1 \<^bold>\<star> Dom t2) = Cod v"
show "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
proof -
have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
using u v w uw tu vw t12 I1 I2 1 Obj_Src
apply (cases u, simp_all)
by (cases w, simp_all add: Src_VcompNml)
moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
proof -
assume u': "\<not> is_Prim\<^sub>0 u"
hence w': "\<not> is_Prim\<^sub>0 w" using u w uw by (cases u, simp_all; cases w, simp_all)
show ?thesis
using 1 v
proof (cases v, simp_all)
fix v1 v2
assume v12: "v = v1 \<^bold>\<star> v2"
have v1: "v1 = \<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<and> arr (un_Prim v1) \<and> Nml v1"
using v v12 by (cases v1, simp_all)
have v2: "Nml v2 \<and> \<not> is_Prim\<^sub>0 v2"
using v v12 by (cases v1, simp_all)
have 2: "v = (\<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<^bold>\<star> v2)"
using v1 v12 by simp
show "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<star> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<^bold>\<star> t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
proof -
have 3: "(t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using u u' by (cases u, simp_all)
have 4: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w = v1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
proof -
have "Src v1 = Trg v2"
using v v12 1 Arr.simps(3) Nml_HcompD(7) by blast
moreover have "Src v2 = Trg w"
using v v12 vw by simp
ultimately show ?thesis
using v w v1 v2 v12 2 HcompNml_assoc [of v1 v2 w] HcompNml_Nml by metis
qed
have "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<star> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)
= (t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w))"
using 3 4 v12 by simp
also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w))"
proof -
have "is_Hcomp (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
using t2 u u' tu is_Hcomp_HcompNml by auto
moreover have "is_Hcomp (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)"
using v2 v12 w w' vw is_Hcomp_HcompNml by auto
ultimately show ?thesis
using u u' v w t1 v1 t12 v12 HcompNml_Prim
by (metis VcompNml.simps(2) VcompNml.simps(3) is_Hcomp_def
term.distinct_disc(3))
qed
also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
using u w tu uw vw t2 v2 1 2 Nml_implies_Arr I2 by auto
also have "... = ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<star> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have "\<not>is_Prim\<^sub>0 (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
using u w u' w' by (cases u, simp_all; cases w, simp_all)
hence "((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<star> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)
= (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w))"
by (cases "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w") simp_all
thus ?thesis by presburger
qed
finally show ?thesis by blast
qed
qed
qed
ultimately show ?thesis by blast
qed
qed
moreover have "Src t = Trg u"
using assms Src_Dom Trg_Dom Src_Cod Trg_Cod Nml_implies_Arr by metis
ultimately show ?thesis using assms by simp
qed
text \<open>
The following function reduces a formal arrow to normal form.
\<close>
fun Nmlize :: "'a term \<Rightarrow> 'a term" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
where "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
| "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle>"
| "\<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
lemma Nml_Nmlize:
assumes "Arr t"
shows "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t" and "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t"
and "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
proof -
have 0: "Arr t \<Longrightarrow> Nml \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t \<and> Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t \<and>
Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
using Nml_HcompNml Nml_VcompNml HcompNml_assoc
Src_VcompNml Trg_VcompNml VSeq_implies_HPar
apply (induct t)
apply auto
proof -
fix t
assume 1: "Arr t"
assume 2: "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>"
assume 3: "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t"
assume 4: "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t"
assume 5: "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
assume 6: "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
have 7: "Nml \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
using 2 5 Nml_Dom by fastforce
have 8: "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor>"
using 1 2 4 Nml_Trg Obj_Trg
by (metis Nml.elims(2) Nmlize.simps(1) Nmlize.simps(2) Obj.simps(3))
have 9: "Nml \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
using 2 6 Nml_Cod by fastforce
have 10: "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
using 1 2 3 Nml_Src Obj_Src
by (metis Nml.elims(2) Nmlize.simps(1) Nmlize.simps(2) Obj.simps(3))
show "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
using 2 5 7 8 Nml_implies_Arr Trg_Dom HcompNml_Trg_Nml by metis
show "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
using 2 6 8 9 Nml_implies_Arr Trg_Cod HcompNml_Trg_Nml by metis
show "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
using 2 5 7 10 Nml_implies_Arr Src_Dom HcompNml_Nml_Src by metis
show "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
using 2 6 9 10 Nml_implies_Arr Src_Cod HcompNml_Nml_Src by metis
next
fix t1 t2 t3
assume "Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>" and "Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>" and "Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
assume "Src t1 = Trg t2" and "Src t2 = Trg t3"
assume "Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2" and "Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3"
assume "Trg \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t1" and "Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2" and "Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3"
assume "Dom \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>"
and "Cod \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"
show "\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> =
(\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>"
using Nml_Dom Nml_implies_Arr Src_Dom Trg_Dom
HcompNml_assoc [of "\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>"]
\<open>Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>\<close>
\<open>Dom \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>\<close> \<open>Dom \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>\<close> \<open>Dom \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>\<close>
\<open>Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2\<close> \<open>Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2\<close>
\<open>Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3\<close> \<open>Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3\<close>
by metis
show "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> = (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"
using Nml_Cod Nml_implies_Arr Src_Cod Trg_Cod
HcompNml_assoc [of "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"]
\<open>Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>\<close>
\<open>Cod \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>\<close> \<open>Cod \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>\<close> \<open>Cod \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>\<close>
\<open>Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2\<close> \<open>Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2\<close>
\<open>Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3\<close> \<open>Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3\<close>
by metis
qed
show "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" using assms 0 by blast
show "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t" using assms 0 by blast
show "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t" using assms 0 by blast
show "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" using assms 0 by blast
show "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>" using assms 0 by blast
qed
lemma Nmlize_in_Hom [intro]:
assumes "Arr t"
shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> HHom (Src t) (Trg t)" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
using assms Nml_Nmlize Nml_implies_Arr by auto
lemma Nmlize_Src:
assumes "Arr t"
shows "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src t"
proof -
have 1: "Obj (Src t)"
using assms by simp
obtain a where a: "obj a \<and> Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
using 1 by (cases "Src t", simp_all)
show "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src t"
using a by simp
thus "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Nmlize_in_Hom by simp
qed
lemma Nmlize_Trg:
assumes "Arr t"
shows "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg t"
proof -
have 1: "Obj (Trg t)"
using assms by simp
obtain a where a: "obj a \<and> Trg t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
using 1 by (cases "Trg t", simp_all)
show "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg t"
using a by simp
thus "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Nmlize_in_Hom by simp
qed
lemma Nmlize_Dom:
assumes "Arr t"
shows "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Nmlize_in_Hom by simp
lemma Nmlize_Cod:
assumes "Arr t"
shows "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Nmlize_in_Hom by simp
lemma Ide_Nmlize_Ide:
assumes "Ide t"
shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Ide t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using Ide_HcompNml Nml_Nmlize
by (induct t, simp_all)
thus ?thesis using assms by blast
qed
lemma Ide_Nmlize_Can:
assumes "Can t"
shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Can t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using Can_implies_Arr Ide_HcompNml Nml_Nmlize Ide_VcompNml Nml_HcompNml
apply (induct t, auto simp add: Dom_Ide Cod_Ide)
by (metis Ide_VcompNml)
thus ?thesis using assms by blast
qed
lemma Can_Nmlize_Can:
assumes "Can t"
shows "Can \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Ide_Nmlize_Can Ide_implies_Can by auto
lemma Nmlize_Nml [simp]:
assumes "Nml t"
shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
proof -
have "Nml t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
apply (induct t, simp_all)
using HcompNml_Prim Nml_HcompD by metis
thus ?thesis using assms by blast
qed
lemma Nmlize_Nmlize [simp]:
assumes "Arr t"
shows "\<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Nml_Nmlize Nmlize_Nml by blast
lemma Nmlize_Hcomp:
assumes "Arr t" and "Arr u"
shows "\<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<^bold>\<rfloor>"
using assms Nmlize_Nmlize by simp
lemma Nmlize_Hcomp_Obj_Arr [simp]:
assumes "Arr u"
shows "\<^bold>\<lfloor>\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using assms by simp
lemma Nmlize_Hcomp_Arr_Obj [simp]:
assumes "Arr t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
shows "\<^bold>\<lfloor>t \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms HcompNml_Nml_Src Nmlize_in_Hom by simp
lemma Nmlize_Hcomp_Prim_Arr [simp]:
assumes "Arr u" and "\<not> is_Prim\<^sub>0 \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using assms by simp
lemma Nmlize_Hcomp_Hcomp:
assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
shows "\<^bold>\<lfloor>(t \<^bold>\<star> u) \<^bold>\<star> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>v\<^bold>\<rfloor>)\<^bold>\<rfloor>"
using assms Nml_Nmlize Nmlize_Nmlize by (simp add: HcompNml_assoc)
lemma Nmlize_Hcomp_Hcomp':
assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
shows "\<^bold>\<lfloor>t \<^bold>\<star> u \<^bold>\<star> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>v\<^bold>\<rfloor>\<^bold>\<rfloor>"
using assms Nml_Nmlize Nmlize_Nmlize by (simp add: HcompNml_assoc)
lemma Nmlize_Vcomp_Cod_Arr:
assumes "Arr t"
shows "\<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Arr t \<Longrightarrow> \<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof (induct t, simp_all)
show "\<And>x. arr x \<Longrightarrow> cod x \<cdot> x = x"
using comp_cod_arr by blast
fix t1 t2
show "\<And>t1 t2. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> HSeq t1 t2 \<Longrightarrow>
(\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
using VcompNml_HcompNml Ide_Cod Nml_Nmlize Nmlize_in_Hom
by simp
show "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> VSeq t1 t2 \<Longrightarrow>
\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
using VcompNml_assoc [of "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t2\<^bold>\<rfloor>"] Ide_Cod
Nml_Nmlize
by simp
next
show "\<And>t. \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> (\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
by (metis Arr.simps(6) Cod.simps(6) Nmlize.simps(3) Nmlize.simps(6)
Nmlize_Cod)
show "\<And>t. \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> (\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
by (simp add: Nml_Nmlize(1) Nml_Nmlize(2) Nmlize_Src(2) HcompNml_Nml_Obj)
show "\<And>t1 t2 t3. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
\<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
(\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) =
(\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
using VcompNml_HcompNml Ide_Cod HcompNml_in_Hom Nml_HcompNml
Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
by simp
show "\<And>t1 t2 t3. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
\<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
((\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) =
\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
using VcompNml_HcompNml Ide_Cod HcompNml_in_Hom Nml_HcompNml
Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
by simp
qed
thus ?thesis using assms by blast
qed
lemma Nmlize_Vcomp_Arr_Dom:
assumes "Arr t"
shows "\<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Arr t \<Longrightarrow> \<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof (induct t, simp_all)
show "\<And>x. arr x \<Longrightarrow> x \<cdot> local.dom x = x"
using comp_arr_dom by blast
fix t1 t2
show "\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> HSeq t1 t2 \<Longrightarrow>
(\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
by simp
show "\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> VSeq t1 t2 \<Longrightarrow>
(\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
using VcompNml_assoc [of "\<^bold>\<lfloor>t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>"] Ide_Dom Nml_Nmlize
by simp
next
show "\<And>t. \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
by (simp add: Nml_Nmlize(1) Nml_Nmlize(3) Nmlize_Trg(2)
HcompNml_Obj_Nml bicategorical_language.Ide_Dom
bicategorical_language_axioms)
show "\<And>t. \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
by (simp add: Nml_Nmlize(1) Nml_Nmlize(2) Nmlize_Src(2) HcompNml_Nml_Obj)
show "\<And>t1 t2 t3. \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
\<^bold>\<lfloor>t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
((\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>) =
(\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
by simp
show "\<And>t1 t2 t3. \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
\<^bold>\<lfloor>t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
(\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>) =
\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
by simp
qed
thus ?thesis using assms by blast
qed
lemma Nmlize_Inv:
assumes "Can t"
shows "\<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Can t \<Longrightarrow> \<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof (induct t, simp_all)
fix u v
assume I1: "\<^bold>\<lfloor>Inv u\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>u\<^bold>\<rfloor>"
assume I2: "\<^bold>\<lfloor>Inv v\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>"
show "Can u \<and> Can v \<and> Src u = Trg v \<Longrightarrow> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
using Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
I1 I2
by simp
show "Can u \<and> Can v \<and> Dom u = Cod v \<Longrightarrow> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
using Inv_VcompNml Nml_Nmlize Can_implies_Arr Nmlize_in_Hom Can_Nmlize_Can
I1 I2
by simp
fix w
assume I3: "\<^bold>\<lfloor>Inv w\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>"
assume uvw: "Can u \<and> Can v \<and> Can w \<and> Src u = Trg v \<and> Src v = Trg w"
show "Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>) = Inv ((\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
using uvw I1 I2 I3
Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
Nml_HcompNml Can_HcompNml HcompNml_assoc
by simp
show "(Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>))"
using uvw I1 I2 I3
Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
Nml_HcompNml Can_HcompNml HcompNml_assoc Can_Inv
by simp
qed
thus ?thesis using assms by blast
qed
subsection "Reductions"
text \<open>
Function \<open>red\<close> defined below takes a formal identity @{term t} to a canonical arrow
\<open>f\<^bold>\<down> \<in> Hom f \<^bold>\<lfloor>f\<^bold>\<rfloor>\<close>. The auxiliary function \<open>red2\<close> takes a pair @{term "(f, g)"}
of normalized formal identities and produces a canonical arrow
\<open>f \<^bold>\<Down> g \<in> Hom (f \<^bold>\<star> g) \<^bold>\<lfloor>f \<^bold>\<star> g\<^bold>\<rfloor>\<close>.
\<close>
fun red2 (infixr "\<^bold>\<Down>" 53)
where "\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<Down> u = \<^bold>\<l>\<^bold>[u\<^bold>]"
| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]"
| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> u"
| "(t \<^bold>\<star> u) \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = \<^bold>\<r>\<^bold>[t \<^bold>\<star> u\<^bold>]"
| "(t \<^bold>\<star> u) \<^bold>\<Down> v = (t \<^bold>\<Down> \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>) \<^bold>\<cdot> (t \<^bold>\<star> (u \<^bold>\<Down> v)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
| "t \<^bold>\<Down> u = undefined"
fun red ("_\<^bold>\<down>" [56] 56)
where "\<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0"
| "\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>"
| "(t \<^bold>\<star> u)\<^bold>\<down> = (if Nml (t \<^bold>\<star> u) then t \<^bold>\<star> u else (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<cdot> (t\<^bold>\<down> \<^bold>\<star> u\<^bold>\<down>))"
| "t\<^bold>\<down> = undefined"
lemma red_Nml [simp]:
assumes "Nml a"
shows "a\<^bold>\<down> = a"
using assms by (cases a, simp_all)
lemma red2_Nml:
assumes "Nml (a \<^bold>\<star> b)"
shows "a \<^bold>\<Down> b = a \<^bold>\<star> b"
proof -
have a: "a = \<^bold>\<langle>un_Prim a\<^bold>\<rangle>"
using assms Nml_HcompD by metis
have b: "Nml b \<and> \<not> is_Prim\<^sub>0 b"
using assms Nml_HcompD by metis
show ?thesis using a b
apply (cases b)
apply simp_all
apply (metis red2.simps(3))
by (metis red2.simps(4))
qed
lemma Can_red2:
assumes "Ide a" and "Nml a" and "Ide b" and "Nml b" and "Src a = Trg b"
shows "Can (a \<^bold>\<Down> b)"
and "a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>"
proof -
have 0: "\<And>b. \<lbrakk> Ide a \<and> Nml a; Ide b \<and> Nml b; Src a = Trg b \<rbrakk> \<Longrightarrow>
Can (a \<^bold>\<Down> b) \<and> a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>"
proof (induct a, simp_all add: HcompNml_Nml_Src HcompNml_Trg_Nml)
fix x b
show "Ide b \<and> Nml b \<Longrightarrow> Can (Trg b \<^bold>\<Down> b) \<and> Arr (Trg b \<^bold>\<Down> b) \<and>
Dom (Trg b \<^bold>\<Down> b) = Trg b \<^bold>\<star> b \<and> Cod (Trg b \<^bold>\<Down> b) = b"
using Ide_implies_Can Ide_in_Hom Nmlize_Nml
apply (cases b, simp_all)
proof -
fix u v
assume uv: "Ide u \<and> Ide v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
show "Can (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) \<and> Arr (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) \<and>
Dom (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) = Trg u \<^bold>\<star> u \<^bold>\<star> v \<and>
Cod (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) = u \<^bold>\<star> v"
using uv Ide_implies_Can Can_implies_Arr Ide_in_Hom
by (cases u, simp_all)
qed
show "ide x \<and> arr x \<Longrightarrow> Ide b \<and> Nml b \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg b \<Longrightarrow>
Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Arr (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Dom (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> b \<and> Cod (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) =
\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b"
using Ide_implies_Can Can_implies_Arr Nmlize_Nml Ide_in_Hom
by (cases b, simp_all)
next
fix u v w
assume uv: "Ide u \<and> Ide v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
assume vw: "Src v = Trg w"
assume w: "Ide w \<and> Nml w"
assume I1: "\<And>w. \<lbrakk> Nml u; Ide w \<and> Nml w; Trg v = Trg w \<rbrakk> \<Longrightarrow>
Can (u \<^bold>\<Down> w) \<and> Arr (u \<^bold>\<Down> w) \<and>
Dom (u \<^bold>\<Down> w) = u \<^bold>\<star> w \<and> Cod (u \<^bold>\<Down> w) = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
assume I2: "\<And>x. \<lbrakk> Nml v; Ide x \<and> Nml x; Trg w = Trg x \<rbrakk> \<Longrightarrow>
Can (v \<^bold>\<Down> x) \<and> Arr (v \<^bold>\<Down> x) \<and>
Dom (v \<^bold>\<Down> x) = v \<^bold>\<star> x \<and> Cod (v \<^bold>\<Down> x) = v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x"
show "Can ((u \<^bold>\<star> v) \<^bold>\<Down> w) \<and> Arr ((u \<^bold>\<star> v) \<^bold>\<Down> w) \<and>
Dom ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (u \<^bold>\<star> v) \<^bold>\<star> w \<and>
Cod ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
proof -
have u: "Nml u \<and> Ide u"
using uv Nml_HcompD by blast
have v: "Nml v \<and> Ide v"
using uv Nml_HcompD by blast
have "is_Prim\<^sub>0 w \<Longrightarrow> ?thesis"
proof -
assume 1: "is_Prim\<^sub>0 w"
have 2: "(u \<^bold>\<star> v) \<^bold>\<Down> w = \<^bold>\<r>\<^bold>[u \<^bold>\<star> v\<^bold>]"
using 1 by (cases w, simp_all)
have 3: "Can (u \<^bold>\<Down> v) \<and> Arr (u \<^bold>\<Down> v) \<and> Dom (u \<^bold>\<Down> v) = u \<^bold>\<star> v \<and> Cod (u \<^bold>\<Down> v) = u \<^bold>\<star> v"
using u v uv 1 2 I1 Nmlize_Nml Nmlize.simps(3) by metis
hence 4: "VSeq (u \<^bold>\<Down> v) \<^bold>\<r>\<^bold>[u \<^bold>\<star> v\<^bold>]"
using uv
by (metis (mono_tags, lifting) Arr.simps(7) Cod.simps(3) Cod.simps(7)
Nml_implies_Arr Ide_in_Hom(2) mem_Collect_eq)
have "Can ((u \<^bold>\<star> v) \<^bold>\<Down> w)"
using 1 2 3 4 uv by (simp add: Ide_implies_Can)
moreover have "Dom ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (u \<^bold>\<star> v) \<^bold>\<star> w"
using 1 2 3 4 u v w uv vw I1 Ide_in_Hom Nml_HcompNml Ide_in_Hom
by (cases w, simp_all)
moreover have "Cod ((u \<^bold>\<star> v) \<^bold>\<Down> w) = \<^bold>\<lfloor>(u \<^bold>\<star> v) \<^bold>\<star> w\<^bold>\<rfloor>"
using 1 2 3 4 uv
using Nmlize_Nml apply (cases w, simp_all)
by (metis Nmlize.simps(3) Nmlize_Nml HcompNml.simps(3))
ultimately show ?thesis using w Can_implies_Arr by (simp add: 1 uv)
qed
moreover have "\<not> is_Prim\<^sub>0 w \<Longrightarrow> ?thesis"
proof -
assume 1: "\<not> is_Prim\<^sub>0 w"
have 2: "(u \<^bold>\<star> v) \<^bold>\<Down> w = (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<^bold>\<cdot> (u \<^bold>\<star> v \<^bold>\<Down> w) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[u, v, w\<^bold>]"
using 1 u v uv w by (cases w; simp)
have 3: "Can (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<and> Dom (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> \<and>
Cod (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = \<^bold>\<lfloor>u \<^bold>\<star> (v \<^bold>\<star> w)\<^bold>\<rfloor>"
proof -
have "Can (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<and> Dom (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> \<and>
Cod (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
using w uv Ide_HcompNml Nml_HcompNml(1)
apply (cases u, simp_all)
using u v vw I1 Nmlize_in_Hom(1) [of "v \<^bold>\<star> w"] Nml_Nmlize Ide_Nmlize_Ide
by simp
moreover have "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> = \<^bold>\<lfloor>u \<^bold>\<star> (v \<^bold>\<star> w)\<^bold>\<rfloor>"
using uv u w Nmlize_Hcomp Nmlize_Nmlize Nml_implies_Arr by simp
ultimately show ?thesis by presburger
qed
have 4: "Can (v \<^bold>\<Down> w) \<and> Dom (v \<^bold>\<Down> w) = v \<^bold>\<star> w \<and> Cod (v \<^bold>\<Down> w) = \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
using v w vw 1 2 I2 by simp
hence 5: "Src (v \<^bold>\<Down> w) = Src w \<and> Trg (v \<^bold>\<Down> w) = Trg v"
using Src_Dom Trg_Dom Can_implies_Arr by fastforce
have "Can (u \<^bold>\<star> (v \<^bold>\<Down> w)) \<and> Dom (u \<^bold>\<star> (v \<^bold>\<Down> w)) = u \<^bold>\<star> (v \<^bold>\<star> w) \<and>
Cod (u \<^bold>\<star> (v \<^bold>\<Down> w)) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
using u uv vw 4 5 Ide_implies_Can Ide_in_Hom by simp
moreover have "\<^bold>\<lfloor>u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>\<^bold>\<rfloor> = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)"
using u v w 4
by (metis Ide_Dom Can_implies_Arr Ide_implies_Arr
Nml_Nmlize(1) Nmlize.simps(3) Nmlize_Nml)
also have "... = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
using u v w uv vw HcompNml_assoc by metis
also have "... = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
using u v w by (metis Nmlize.simps(3) Nmlize_Nml)
finally show ?thesis by blast
qed
moreover have "Can \<^bold>\<a>\<^bold>[u, v, w\<^bold>] \<and> Dom \<^bold>\<a>\<^bold>[u, v, w\<^bold>] = (u \<^bold>\<star> v) \<^bold>\<star> w \<and>
Cod \<^bold>\<a>\<^bold>[u, v, w\<^bold>] = u \<^bold>\<star> (v \<^bold>\<star> w)"
using uv vw w Ide_implies_Can Ide_in_Hom by auto
ultimately show ?thesis
using uv w 2 3 4 Nml_implies_Arr Nmlize_Nmlize Ide_implies_Can
Nmlize_Nml Ide_Dom Can_implies_Arr
by (metis Can.simps(4) Cod.simps(4) Dom.simps(4) Nmlize.simps(3))
qed
ultimately show ?thesis by blast
qed
qed
show "Can (a \<^bold>\<Down> b)" using assms 0 by blast
show "a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>" using 0 assms by blast
qed
lemma red2_in_Hom [intro]:
assumes "Ide u" and "Nml u" and "Ide v" and "Nml v" and "Src u = Trg v"
shows "u \<^bold>\<Down> v \<in> HHom (Src v) (Trg u)" and "u \<^bold>\<Down> v \<in> VHom (u \<^bold>\<star> v) \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
proof -
show 1: "u \<^bold>\<Down> v \<in> VHom (u \<^bold>\<star> v) \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
using assms Can_red2 Can_implies_Arr by simp
show "u \<^bold>\<Down> v \<in> HHom (Src v) (Trg u)"
using assms 1 Src_Dom [of "u \<^bold>\<Down> v"] Trg_Dom [of "u \<^bold>\<Down> v"] Can_red2 Can_implies_Arr by simp
qed
lemma red2_simps [simp]:
assumes "Ide u" and "Nml u" and "Ide v" and "Nml v" and "Src u = Trg v"
shows "Src (u \<^bold>\<Down> v) = Src v" and "Trg (u \<^bold>\<Down> v) = Trg u"
and "Dom (u \<^bold>\<Down> v) = u \<^bold>\<star> v" and "Cod (u \<^bold>\<Down> v) = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
using assms red2_in_Hom by auto
lemma Can_red:
assumes "Ide u"
shows "Can (u\<^bold>\<down>)" and "u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>"
proof -
have 0: "Ide u \<Longrightarrow> Can (u\<^bold>\<down>) \<and> u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>"
proof (induct u, simp_all add: Dom_Ide Cod_Ide)
fix v w
assume v: "Can (v\<^bold>\<down>) \<and> Arr (v\<^bold>\<down>) \<and> Dom (v\<^bold>\<down>) = v \<and> Cod (v\<^bold>\<down>) = \<^bold>\<lfloor>v\<^bold>\<rfloor>"
assume w: "Can (w\<^bold>\<down>) \<and> Arr (w\<^bold>\<down>) \<and> Dom (w\<^bold>\<down>) = w \<and> Cod (w\<^bold>\<down>) = \<^bold>\<lfloor>w\<^bold>\<rfloor>"
assume vw: "Ide v \<and> Ide w \<and> Src v = Trg w"
show "(Nml (v \<^bold>\<star> w) \<longrightarrow>
Can v \<and> Can w \<and> v \<^bold>\<star> w = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and>
(\<not> Nml (v \<^bold>\<star> w) \<longrightarrow>
Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
proof
show "Nml (v \<^bold>\<star> w) \<longrightarrow>
Can v \<and> Can w \<and> v \<^bold>\<star> w = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
using vw Nml_HcompD Ide_implies_Can Dom_Inv VcompNml_Ide_Nml Inv_Ide
Nmlize.simps(3) Nmlize_Nml
by metis
show "\<not> Nml (v \<^bold>\<star> w) \<longrightarrow>
Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
proof
assume 1: "\<not> Nml (v \<^bold>\<star> w)"
have "Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
using v w vw Can_red2 Nml_Nmlize Ide_Nmlize_Ide Nml_HcompNml Ide_HcompNml
by simp
moreover have "Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>)"
using v w vw Src_Dom Trg_Dom by metis
moreover have "Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
using v w vw Can_red2 Nml_Nmlize Ide_Nmlize_Ide by simp
ultimately show "Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and>
Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and> Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and>
Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
using Can_implies_Arr by blast
qed
qed
qed
show "Can (u\<^bold>\<down>)" using assms 0 by blast
show "u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>" using assms 0 by blast
qed
lemma red_in_Hom [intro]:
assumes "Ide t"
shows "t\<^bold>\<down> \<in> HHom (Src t) (Trg t)" and "t\<^bold>\<down> \<in> VHom t \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
show 1: "t\<^bold>\<down> \<in> VHom t \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Can_red Can_implies_Arr by simp
show "t\<^bold>\<down> \<in> HHom (Src t) (Trg t)"
using assms 1 Src_Dom [of "t\<^bold>\<down>"] Trg_Dom [of "t\<^bold>\<down>"] Can_red Can_implies_Arr by simp
qed
lemma red_simps [simp]:
assumes "Ide t"
shows "Src (t\<^bold>\<down>) = Src t" and "Trg (t\<^bold>\<down>) = Trg t"
and "Dom (t\<^bold>\<down>) = t" and "Cod (t\<^bold>\<down>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms red_in_Hom by auto
lemma red_Src:
assumes "Ide t"
shows "Src t\<^bold>\<down> = Src t"
using assms is_Prim0_Src [of t]
by (cases "Src t", simp_all)
lemma red_Trg:
assumes "Ide t"
shows "Trg t\<^bold>\<down> = Trg t"
using assms is_Prim0_Trg [of t]
by (cases "Trg t", simp_all)
lemma Nmlize_red [simp]:
assumes "Ide t"
shows "\<^bold>\<lfloor>t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Can_red Ide_Nmlize_Can Nmlize_in_Hom Ide_in_Hom by fastforce
lemma Nmlize_red2 [simp]:
assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
shows "\<^bold>\<lfloor>t \<^bold>\<Down> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor>"
using assms Can_red2 Ide_Nmlize_Can Nmlize_in_Hom [of "t \<^bold>\<Down> u"] red2_in_Hom Ide_in_Hom
by simp
end
subsection "Evaluation"
text \<open>
The following locale is concerned with the evaluation of terms of the bicategorical
language determined by \<open>C\<close>, \<open>src\<^sub>C\<close>, and \<open>trg\<^sub>C\<close> in a bicategory \<open>(V, H, \<a>, \<i>, src, trg)\<close>,
given a source and target-preserving functor from \<open>C\<close> to \<open>V\<close>.
\<close>
locale evaluation_map =
C: horizontal_homs C src\<^sub>C trg\<^sub>C +
bicategorical_language C src\<^sub>C trg\<^sub>C +
bicategory V H \<a> \<i> src trg +
E: "functor" C V E
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and src\<^sub>C :: "'c \<Rightarrow> 'c"
and trg\<^sub>C :: "'c \<Rightarrow> 'c"
and V :: "'b comp" (infixr "\<cdot>" 55)
and H :: "'b comp" (infixr "\<star>" 53)
and \<a> :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b" ("\<a>[_, _, _]")
and \<i> :: "'b \<Rightarrow> 'b" ("\<i>[_]")
and src :: "'b \<Rightarrow> 'b"
and trg :: "'b \<Rightarrow> 'b"
and E :: "'c \<Rightarrow> 'b" +
assumes preserves_src: "E (src\<^sub>C x) = src (E x)"
and preserves_trg: "E (trg\<^sub>C x) = trg (E x)"
begin
(* TODO: Figure out why this notation has to be reinstated. *)
notation Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
notation HcompNml (infixr "\<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor>" 53)
notation VcompNml (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
notation red ("_\<^bold>\<down>" [56] 56)
notation red2 (infixr "\<^bold>\<Down>" 53)
primrec eval :: "'c term \<Rightarrow> 'b" ("\<lbrace>_\<rbrace>")
where "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0\<rbrace> = E f"
| "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = E f"
| "\<lbrace>t \<^bold>\<star> u\<rbrace> = \<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>"
| "\<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
| "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<ll> \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<ll>'.map \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<rr> \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<rr>'.map \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
| "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
lemma preserves_obj:
assumes "C.obj a"
shows "obj (E a)"
proof (unfold obj_def)
show "arr (E a) \<and> src (E a) = E a"
proof
show "arr (E a)" using assms C.obj_def by simp
have "src (E a) = E (src\<^sub>C a)"
using assms preserves_src by metis
also have "... = E a"
using assms C.obj_def by simp
finally show "src (E a) = E a" by simp
qed
qed
lemma eval_in_hom':
shows "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
proof (induct t)
show "\<And>x. Arr \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> : \<lbrace>Src \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> : \<lbrace>Dom \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>\<guillemotright>"
apply (simp add: preserves_src preserves_trg)
using preserves_src preserves_trg C.objE
by (metis (full_types) C.obj_def' E.preserves_arr E.preserves_ide in_hhom_def
ide_in_hom(2))
show "\<And>x. Arr \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> : \<lbrace>Src \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> : \<lbrace>Dom \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>\<guillemotright>"
by (auto simp add: preserves_src preserves_trg)
show "\<And>t1 t2.
(Arr t1 \<Longrightarrow> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Src t1\<rbrace> \<rightarrow> \<lbrace>Trg t1\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Dom t1\<rbrace> \<Rightarrow> \<lbrace>Cod t1\<rbrace>\<guillemotright>) \<Longrightarrow>
(Arr t2 \<Longrightarrow> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Src t2\<rbrace> \<rightarrow> \<lbrace>Trg t2\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Dom t2\<rbrace> \<Rightarrow> \<lbrace>Cod t2\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr (t1 \<^bold>\<star> t2) \<Longrightarrow>
\<guillemotleft>\<lbrace>t1 \<^bold>\<star> t2\<rbrace> : \<lbrace>Src (t1 \<^bold>\<star> t2)\<rbrace> \<rightarrow> \<lbrace>Trg (t1 \<^bold>\<star> t2)\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<lbrace>t1 \<^bold>\<star> t2\<rbrace> : \<lbrace>Dom (t1 \<^bold>\<star> t2)\<rbrace> \<Rightarrow> \<lbrace>Cod (t1 \<^bold>\<star> t2)\<rbrace>\<guillemotright>"
using hcomp_in_hhom in_hhom_def vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
show "\<And>t1 t2.
(Arr t1 \<Longrightarrow> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Src t1\<rbrace> \<rightarrow> \<lbrace>Trg t1\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Dom t1\<rbrace> \<Rightarrow> \<lbrace>Cod t1\<rbrace>\<guillemotright>) \<Longrightarrow>
(Arr t2 \<Longrightarrow> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Src t2\<rbrace> \<rightarrow> \<lbrace>Trg t2\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Dom t2\<rbrace> \<Rightarrow> \<lbrace>Cod t2\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr (t1 \<^bold>\<cdot> t2) \<Longrightarrow>
\<guillemotleft>\<lbrace>t1 \<^bold>\<cdot> t2\<rbrace> : \<lbrace>Src (t1 \<^bold>\<cdot> t2)\<rbrace> \<rightarrow> \<lbrace>Trg (t1 \<^bold>\<cdot> t2)\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<lbrace>t1 \<^bold>\<cdot> t2\<rbrace> : \<lbrace>Dom (t1 \<^bold>\<cdot> t2)\<rbrace> \<Rightarrow> \<lbrace>Cod (t1 \<^bold>\<cdot> t2)\<rbrace>\<guillemotright>"
using VSeq_implies_HPar seqI' by auto
show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
proof (simp add: preserves_src preserves_trg)
fix t
assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume 1: "Arr t"
show "\<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
proof -
have "src (\<ll> \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
using t 1
by (metis (no_types, lifting) \<ll>.preserves_cod \<ll>.preserves_reflects_arr arr_cod
in_hhomE map_simp src_cod)
moreover have "trg (\<ll> \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
using t 1
by (metis (no_types, lifting) \<ll>.preserves_cod \<ll>.preserves_reflects_arr arr_cod
in_hhomE map_simp trg_cod)
moreover have "\<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
using t 1
apply (elim conjE in_hhomE)
by (intro in_homI, auto)
ultimately show ?thesis by auto
qed
qed
show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
proof (simp add: preserves_src preserves_trg)
fix t
assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume 1: "Arr t"
show "\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Cod t\<rbrace>\<guillemotright>"
proof -
have "src (\<ll>'.map \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
using t 1 \<ll>'.preserves_dom arr_dom map_simp \<ll>'.preserves_reflects_arr src_dom
by (metis (no_types, lifting) in_hhomE)
moreover have "trg (\<ll>'.map \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
using t 1 \<ll>'.preserves_dom arr_dom map_simp \<ll>'.preserves_reflects_arr trg_dom
by (metis (no_types, lifting) in_hhomE)
moreover have "\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Cod t\<rbrace>\<guillemotright>"
using t 1 \<ll>'.preserves_hom
apply (intro in_homI)
apply auto[1]
apply fastforce
by fastforce
ultimately show ?thesis by blast
qed
qed
show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
proof (simp add: preserves_src preserves_trg)
fix t
assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume 1: "Arr t"
show "\<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Src t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
proof -
have "src (\<rr> \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
using t 1 \<rr>.preserves_cod arr_cod map_simp \<rr>.preserves_reflects_arr src_cod
by (metis (no_types, lifting) in_hhomE)
moreover have "trg (\<rr> \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
using t 1 \<rr>.preserves_cod arr_cod map_simp \<rr>.preserves_reflects_arr trg_cod
by (metis (no_types, lifting) in_hhomE)
moreover have "\<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Src t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
using t 1 by force
ultimately show ?thesis by blast
qed
qed
show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
proof (simp add: preserves_src preserves_trg)
fix t
assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume 1: "Arr t"
show "\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Src t\<rbrace>\<guillemotright>"
proof -
have "src (\<rr>'.map \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
using t 1 \<rr>'.preserves_dom arr_dom map_simp \<rr>'.preserves_reflects_arr src_dom
by (metis (no_types, lifting) in_hhomE)
moreover have "trg (\<rr>'.map \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
using t 1 \<rr>'.preserves_dom arr_dom map_simp \<rr>'.preserves_reflects_arr trg_dom
by (metis (no_types, lifting) in_hhomE)
moreover have "\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Src t\<rbrace>\<guillemotright>"
using t 1 src_cod arr_cod \<rr>'.preserves_hom [of "\<lbrace>t\<rbrace>" "\<lbrace>Dom t\<rbrace>" "\<lbrace>Cod t\<rbrace>"]
apply (elim conjE in_hhomE)
by (intro in_homI, auto)
ultimately show ?thesis by blast
qed
qed
show "\<And>t u v.
(Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
(Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Src u\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>) \<Longrightarrow>
(Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
proof (simp add: preserves_src preserves_trg)
fix t u v
assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Trg u\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume u: "\<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Trg v\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
assume v: "\<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
assume tuv: "Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v"
show "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
(\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace> \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
proof -
have 1: "VVV.in_hom (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)
(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
- using t u v tuv VVV.hom_char by fastforce
+ proof -
+ have "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) \<in>
+ VxVxV.hom (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
+ using t u v tuv by simp
+ moreover have "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) \<in>
+ {\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))}"
+ using t u v tuv by fastforce
+ ultimately show ?thesis
+ using VVV.hom_char [of "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)" "(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
+ by blast
+ qed
have 4: "VVV.arr (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
using 1 VVV.ide_dom apply (elim VVV.in_homE) by force
have 5: "VVV.arr (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
using 1 VVV.ide_cod apply (elim VVV.in_homE) by force
have 2: "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
(\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace> \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
using 1 4 5 HoHV_def HoVH_def \<alpha>_def
\<alpha>.preserves_hom [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
"(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
by simp
have 3: "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>"
proof
show "arr (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
using 2 by auto
show "src (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Src v\<rbrace>"
proof -
have "src (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = src ((\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace>)"
using 2 src_dom [of "\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
also have "... = src \<lbrace>Dom v\<rbrace>"
using 4 VVV.arr_char VV.arr_char hseqI' by simp
also have "... = src (dom \<lbrace>v\<rbrace>)"
using v by auto
also have "... = \<lbrace>Src v\<rbrace>"
using v by auto
finally show ?thesis by auto
qed
show "trg (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Trg t\<rbrace>"
proof -
have "trg (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = trg ((\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace>)"
using 2 trg_dom [of "\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
also have "... = trg \<lbrace>Dom t\<rbrace>"
using 4 VVV.arr_char VV.arr_char hseqI' by simp
also have "... = trg (dom \<lbrace>t\<rbrace>)"
using t by auto
also have "... = \<lbrace>Trg t\<rbrace>"
using t by auto
finally show ?thesis by auto
qed
qed
show ?thesis using 2 3 by simp
qed
qed
show "\<And>t u v.
(Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
(Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Src u\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>) \<Longrightarrow>
(Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>) \<Longrightarrow>
Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow>
\<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
proof (simp add: preserves_src preserves_trg)
fix t u v
assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Trg u\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume u: "\<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Trg v\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
assume v: "\<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
assume tuv: "Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v"
show "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> (\<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace>) \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
proof -
have 1: "VVV.in_hom (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)
(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
using t u v tuv VVV.hom_char VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char
apply (elim conjE in_hhomE in_homE)
apply (intro VVV.in_homI)
by simp_all
have 4: "VVV.arr (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
using "1" VVV.in_hom_char by blast
have 5: "VVV.arr (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
using "1" VVV.in_hom_char by blast
have 2: "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> (\<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace>) \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
using 1 4 5 HoHV_def HoVH_def \<alpha>'.map_def
\<alpha>'.preserves_hom [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
"(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
by simp
have 3: "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>"
proof
show "arr (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
using 2 by auto
show "src (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Src v\<rbrace>"
proof -
have "src (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = src (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace>)"
using 2 src_dom [of "\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by auto
also have "... = src \<lbrace>Dom v\<rbrace>"
using 4 VVV.arr_char VV.arr_char hseqI' by simp
also have "... = src (dom \<lbrace>v\<rbrace>)"
using v by auto
also have "... = \<lbrace>Src v\<rbrace>"
using v by auto
finally show ?thesis by auto
qed
show "trg (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Trg t\<rbrace>"
proof -
have "trg (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = trg (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace>)"
using 2 trg_dom [of "\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by auto
also have "... = trg \<lbrace>Dom t\<rbrace>"
using 4 VVV.arr_char VV.arr_char hseqI' by simp
also have "... = trg (dom \<lbrace>t\<rbrace>)"
using t by auto
also have "... = \<lbrace>Trg t\<rbrace>"
using t by auto
finally show ?thesis by auto
qed
qed
show ?thesis using 2 3 by simp
qed
qed
qed
lemma eval_in_hom [intro]:
assumes "Arr t"
shows "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>" and "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
using assms eval_in_hom' by simp_all
(*
* TODO: It seems to me that the natural useful orientation of these facts is syntax
* to semantics. However, having this as the default makes it impossible to do various
* proofs by simp alone. This has to be sorted out. For right now, I am going to include
* both versions, which will have to be explicitly invoked where needed.
*)
lemma eval_simps:
assumes "Arr f"
shows "arr \<lbrace>f\<rbrace>" and "\<lbrace>Src f\<rbrace> = src \<lbrace>f\<rbrace>" and "\<lbrace>Trg f\<rbrace> = trg \<lbrace>f\<rbrace>"
and "\<lbrace>Dom f\<rbrace> = dom \<lbrace>f\<rbrace>" and "\<lbrace>Cod f\<rbrace> = cod \<lbrace>f\<rbrace>"
using assms eval_in_hom [of f] by auto
lemma eval_simps':
assumes "Arr f"
shows "arr \<lbrace>f\<rbrace>" and "src \<lbrace>f\<rbrace> = \<lbrace>Src f\<rbrace>" and "trg \<lbrace>f\<rbrace> = \<lbrace>Trg f\<rbrace>"
and "dom \<lbrace>f\<rbrace> = \<lbrace>Dom f\<rbrace>" and "cod \<lbrace>f\<rbrace> = \<lbrace>Cod f\<rbrace>"
using assms eval_in_hom by auto
lemma obj_eval_Obj:
shows "Obj t \<Longrightarrow> obj \<lbrace>t\<rbrace>"
apply (induct t)
using obj_def C.obj_def preserves_src apply auto
by metis
lemma ide_eval_Ide:
shows "Ide t \<Longrightarrow> ide \<lbrace>t\<rbrace>"
by (induct t, auto simp add: eval_simps')
lemma arr_eval_Arr [simp]:
assumes "Arr t"
shows "arr \<lbrace>t\<rbrace>"
using assms by (simp add: eval_simps')
(*
* TODO: The next few results want eval_simps oriented from syntax to semantics.
*)
lemma eval_Lunit [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>Cod t\<rbrace>] \<cdot> (trg \<lbrace>t\<rbrace> \<star> \<lbrace>t\<rbrace>)"
using assms \<ll>.is_natural_2 \<ll>_ide_simp by (simp add: eval_simps)
lemma eval_Lunit' [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
using assms \<ll>'.is_natural_2 \<ll>_ide_simp by (simp add: eval_simps)
lemma eval_Runit [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> src \<lbrace>t\<rbrace>)"
using assms \<rr>.is_natural_2 \<rr>_ide_simp by (simp add: eval_simps)
lemma eval_Runit' [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
using assms \<rr>'.is_natural_2 \<rr>_ide_simp by (simp add: eval_simps)
lemma eval_Assoc [simp]:
assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>)"
proof -
have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" by simp
also have "... = \<alpha> (VVV.cod (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) \<cdot> HoHV (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
using assms \<alpha>.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] VVV.arr_char VVV.cod_char
\<alpha>.is_extensional \<alpha>_def
by auto
also have "... = \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>)"
unfolding HoHV_def \<alpha>_def
using assms VVV.arr_char VV.arr_char VVV.cod_char \<alpha>.is_extensional
by auto
finally show ?thesis by simp
qed
lemma eval_Assoc' [simp]:
assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>)"
proof -
have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" by simp
also have "... = \<alpha>'.map (VVV.cod (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) \<cdot> HoVH (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
using assms \<alpha>'.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] VVV.arr_char VVV.cod_char
\<alpha>'.is_extensional
by simp
also have "... = \<alpha>'.map (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>)"
unfolding HoVH_def
using assms VVV.arr_char VV.arr_char VVV.cod_char \<alpha>'.is_extensional
apply simp
by (metis (no_types, lifting) comp_null(2) hseq_char hseq_char' hcomp_simps(2))
finally show ?thesis
using \<a>'_def by simp
qed
lemma eval_Lunit_Ide [simp]:
assumes "Ide t"
shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>t\<rbrace>]"
using assms \<ll>_ide_simp ide_eval_Ide by simp
lemma eval_Lunit'_Ide [simp]:
assumes "Ide t"
shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>]"
using assms \<ll>_ide_simp ide_eval_Ide by simp
lemma eval_Runit_Ide [simp]:
assumes "Ide t"
shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
using assms \<rr>_ide_simp ide_eval_Ide by simp
lemma eval_Runit'_Ide [simp]:
assumes "Ide t"
shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>]"
using assms \<rr>_ide_simp ide_eval_Ide by simp
lemma eval_Assoc_Ide [simp]:
assumes "Ide t" and "Ide u" and "Ide v" and "Src t = Trg u" and "Src u = Trg v"
shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
using assms by simp
lemma eval_Assoc'_Ide [simp]:
assumes "Ide t" and "Ide u" and "Ide v" and "Src t = Trg u" and "Src u = Trg v"
shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>]"
using assms \<a>'_def by simp
lemma iso_eval_Can:
shows "Can t \<Longrightarrow> iso \<lbrace>t\<rbrace>"
proof (induct t; simp add: fsts.intros snds.intros)
show "\<And>x. C.obj x \<Longrightarrow> iso (E x)" by auto
show "\<And>t1 t2. \<lbrakk> iso \<lbrace>t1\<rbrace>; iso \<lbrace>t2\<rbrace>; Can t1 \<and> Can t2 \<and> Src t1 = Trg t2 \<rbrakk> \<Longrightarrow>
iso (\<lbrace>t1\<rbrace> \<star> \<lbrace>t2\<rbrace>)"
using Can_implies_Arr by (simp add: eval_simps')
show "\<And>t1 t2. \<lbrakk> iso \<lbrace>t1\<rbrace>; iso \<lbrace>t2\<rbrace>; Can t1 \<and> Can t2 \<and> Dom t1 = Cod t2 \<rbrakk> \<Longrightarrow>
iso (\<lbrace>t1\<rbrace> \<cdot> \<lbrace>t2\<rbrace>)"
using Can_implies_Arr isos_compose by (simp add: eval_simps')
show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<ll> \<lbrace>t\<rbrace>)"
using \<ll>.preserves_iso by auto
show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<ll>'.map \<lbrace>t\<rbrace>)"
using \<ll>'.preserves_iso by simp
show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<rr> \<lbrace>t\<rbrace>)"
using \<rr>.preserves_iso by auto
show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<rr>'.map \<lbrace>t\<rbrace>)"
using \<rr>'.preserves_iso by simp
fix t1 t2 t3
assume t1: "iso \<lbrace>t1\<rbrace>" and t2: "iso \<lbrace>t2\<rbrace>" and t3: "iso \<lbrace>t3\<rbrace>"
assume 1: "Can t1 \<and> Can t2 \<and> Can t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3"
have 2: "VVV.iso (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>)"
proof -
have 3: "VxVxV.iso (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>)"
using t1 t2 t3 Can_implies_Arr VxVxV.iso_char VxV.iso_char by simp
moreover have "VVV.arr (VxVxV.inv (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
proof -
have "VxVxV.inv (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>) = (inv \<lbrace>t1\<rbrace>, inv \<lbrace>t2\<rbrace>, inv \<lbrace>t3\<rbrace>)"
using t1 t2 t3 3 by simp
thus ?thesis
using t1 t2 t3 1 Can_implies_Arr VVV.arr_char VV.arr_char
by (simp add: eval_simps')
qed
ultimately show ?thesis
using t1 t2 t3 1 Can_implies_Arr VVV.iso_char VVV.arr_char
by (auto simp add: eval_simps')
qed
show "iso (\<alpha> (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
using 2 \<alpha>_def \<alpha>.preserves_iso by auto
show "iso (\<alpha>'.map (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
using 2 \<alpha>'.preserves_iso by simp
qed
lemma eval_Inv_Can:
shows "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
proof (induct t)
show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<lbrace>Inv \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> = inv \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>" by auto
show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow> \<lbrace>Inv \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> = inv \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>" by simp
show "\<And>t1 t2. (Can t1 \<Longrightarrow> \<lbrace>Inv t1\<rbrace> = inv \<lbrace>t1\<rbrace>) \<Longrightarrow>
(Can t2 \<Longrightarrow> \<lbrace>Inv t2\<rbrace> = inv \<lbrace>t2\<rbrace>) \<Longrightarrow>
Can (t1 \<^bold>\<star> t2) \<Longrightarrow> \<lbrace>Inv (t1 \<^bold>\<star> t2)\<rbrace> = inv \<lbrace>t1 \<^bold>\<star> t2\<rbrace>"
using iso_eval_Can Can_implies_Arr
by (simp add: eval_simps')
show "\<And>t1 t2. (Can t1 \<Longrightarrow> \<lbrace>Inv t1\<rbrace> = inv \<lbrace>t1\<rbrace>) \<Longrightarrow>
(Can t2 \<Longrightarrow> \<lbrace>Inv t2\<rbrace> = inv \<lbrace>t2\<rbrace>) \<Longrightarrow>
Can (t1 \<^bold>\<cdot> t2) \<Longrightarrow> \<lbrace>Inv (t1 \<^bold>\<cdot> t2)\<rbrace> = inv \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
using iso_eval_Can inv_comp Can_implies_Arr
by (simp add: eval_simps')
fix t
assume I: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
show "Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
proof -
assume t: "Can \<^bold>\<l>\<^bold>[t\<^bold>]"
have "\<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]\<rbrace>" by simp
also have "... = \<ll>'.map (inv \<lbrace>t\<rbrace>)"
using t I by simp
also have "... = \<ll>'.map (cod (inv \<lbrace>t\<rbrace>)) \<cdot> inv \<lbrace>t\<rbrace>"
using t \<ll>'.is_natural_2 iso_inv_iso iso_eval_Can iso_is_arr
by (metis (no_types, lifting) Can.simps(5) map_simp)
also have "... = inv (\<lbrace>t\<rbrace> \<cdot> \<ll> (dom \<lbrace>t\<rbrace>))"
proof -
have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
moreover have "iso (\<ll> (dom \<lbrace>t\<rbrace>))"
using t 1 \<ll>.components_are_iso ide_dom by blast
moreover have "seq \<lbrace>t\<rbrace> (\<ll> (dom \<lbrace>t\<rbrace>))"
using t 1 iso_is_arr by auto
ultimately show ?thesis
using t 1 inv_comp by auto
qed
also have "... = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
using t iso_eval_Can \<ll>_ide_simp lunit_naturality Can_implies_Arr eval_Lunit
by (auto simp add: eval_simps)
finally show ?thesis by blast
qed
show "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
proof -
assume t: "Can (Lunit' t)"
have "\<lbrace>Inv (Lunit' t)\<rbrace> = \<lbrace>Lunit (Inv t)\<rbrace>" by simp
also have "... = \<ll> (inv \<lbrace>t\<rbrace>)"
using t I by simp
also have "... = inv \<lbrace>t\<rbrace> \<cdot> \<ll> (dom (inv \<lbrace>t\<rbrace>))"
using t \<ll>.is_natural_1 iso_inv_iso iso_eval_Can iso_is_arr
by (metis (no_types, lifting) Can.simps(6) map_simp)
also have "... = inv (\<ll>'.map (cod \<lbrace>t\<rbrace>) \<cdot> \<lbrace>t\<rbrace>)"
proof -
have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
moreover have "iso (\<ll>'.map (cod \<lbrace>t\<rbrace>))"
using t 1 \<ll>'.components_are_iso ide_cod by blast
moreover have "seq (\<ll>'.map (cod \<lbrace>t\<rbrace>)) \<lbrace>t\<rbrace>"
using t 1 iso_is_arr by auto
ultimately show ?thesis
using t 1 inv_comp by auto
qed
also have "... = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
using t \<ll>'.is_natural_2 iso_eval_Can iso_is_arr by force
finally show ?thesis by auto
qed
show "Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
proof -
assume t: "Can \<^bold>\<r>\<^bold>[t\<^bold>]"
have "\<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]\<rbrace>" by simp
also have "... = \<rr>'.map (inv \<lbrace>t\<rbrace>)"
using t I by simp
also have "... = \<rr>'.map (cod (inv \<lbrace>t\<rbrace>)) \<cdot> inv \<lbrace>t\<rbrace>"
using t \<rr>'.is_natural_2 map_simp iso_inv_iso iso_eval_Can iso_is_arr
by (metis (no_types, lifting) Can.simps(7))
also have "... = inv (\<lbrace>t\<rbrace> \<cdot> \<rr> (dom \<lbrace>t\<rbrace>))"
proof -
have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
moreover have "iso (\<rr> (dom \<lbrace>t\<rbrace>))"
using t 1 \<rr>.components_are_iso ide_dom by blast
moreover have "seq \<lbrace>t\<rbrace> (\<rr> (dom \<lbrace>t\<rbrace>))"
using t 1 iso_is_arr by simp
ultimately show ?thesis
using t 1 inv_comp by auto
qed
also have "... = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
using t \<rr>_ide_simp iso_eval_Can runit_naturality Can_implies_Arr eval_Runit
by (auto simp add: eval_simps)
finally show ?thesis by blast
qed
show "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
proof -
assume t: "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
have "\<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^bold>[Inv t\<^bold>]\<rbrace>"
by simp
also have "... = \<rr> (inv \<lbrace>t\<rbrace>)"
using t I by simp
also have "... = inv \<lbrace>t\<rbrace> \<cdot> \<rr> (dom (inv \<lbrace>t\<rbrace>))"
using t \<rr>.is_natural_1 map_simp iso_inv_iso iso_eval_Can iso_is_arr
by (metis (no_types, lifting) Can.simps(8))
also have "... = inv (\<rr>'.map (cod \<lbrace>t\<rbrace>) \<cdot> \<lbrace>t\<rbrace>)"
proof -
have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
moreover have "iso (\<rr>'.map (cod \<lbrace>t\<rbrace>))"
using t 1 \<rr>'.components_are_iso ide_cod by blast
moreover have "seq (\<rr>'.map (cod \<lbrace>t\<rbrace>)) \<lbrace>t\<rbrace>"
using t 1 iso_is_arr by auto
ultimately show ?thesis
using t 1 inv_comp by auto
qed
also have "... = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
using t \<rr>'.is_natural_2 iso_eval_Can iso_is_arr by auto
finally show ?thesis by auto
qed
next
fix t u v
assume I1: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
assume I2: "Can u \<Longrightarrow> \<lbrace>Inv u\<rbrace> = inv \<lbrace>u\<rbrace>"
assume I3: "Can v \<Longrightarrow> \<lbrace>Inv v\<rbrace> = inv \<lbrace>v\<rbrace>"
show "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
proof -
assume "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
hence tuv: "Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v" by simp
have "\<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]\<rbrace>" by simp
also have "... = \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] \<cdot> (inv \<lbrace>t\<rbrace> \<star> inv \<lbrace>u\<rbrace> \<star> inv \<lbrace>v\<rbrace>)"
using tuv I1 I2 I3 eval_in_hom \<alpha>'.map_ide_simp inv_in_hom iso_eval_Can assoc'_naturality
Can_implies_Arr Src_Inv Trg_Inv eval_Assoc' Dom_Inv Can_Inv cod_inv
by presburger
also have "... = inv ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>) \<cdot> \<alpha> (dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>))"
using tuv iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3) \<alpha>_def hseqI'
by (simp add: inv_comp)
also have "... = inv (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
using tuv Can_implies_Arr \<alpha>_def
by (metis assoc_is_natural_1 arr_eval_Arr eval_simps'(2) eval_simps'(3) fst_conv snd_conv)
also have "... = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>" by simp
finally show ?thesis by blast
qed
show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
proof -
assume tuv: "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
have t: "Can t" using tuv by simp
have u: "Can u" using tuv by simp
have v: "Can v" using tuv by simp
have "\<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]\<rbrace>" by simp
also have "... = (inv \<lbrace>t\<rbrace> \<star> inv \<lbrace>u\<rbrace> \<star> inv \<lbrace>v\<rbrace>) \<cdot> \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>)"
using \<alpha>_def tuv I1 I2 I3 iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3)
apply simp
using assoc_is_natural_1 arr_inv dom_inv src_inv trg_inv by presburger
also have "... = inv (\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>))"
using tuv inv_comp [of "\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>" "\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>]"]
Can_implies_Arr inv_inv iso_assoc iso_inv_iso \<alpha>_def
by (simp add: eval_simps'(2) eval_simps'(3) hseqI' iso_eval_Can)
also have 1: "... = inv (((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
using tuv assoc'_naturality [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] Can_implies_Arr
eval_simps'(2) eval_simps'(3)
by simp
also have "... = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
using tuv 1 Can_implies_Arr eval_Assoc' by auto
finally show ?thesis by blast
qed
qed
lemma eval_VcompNml:
assumes "Nml t" and "Nml u" and "VSeq t u"
shows "\<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
proof -
have "\<And>u. \<lbrakk> Nml t; Nml u; VSeq t u \<rbrakk> \<Longrightarrow> \<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
proof (induct t, simp_all add: eval_simps)
fix u a
assume u: "Nml u"
assume 1: "Arr u \<and> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = Cod u"
show "\<lbrace>u\<rbrace> = cod \<lbrace>u\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
using 1 comp_cod_arr by simp
next
fix u f
assume u: "Nml u"
assume f: "C.arr f"
assume 1: "Arr u \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
show "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = E f \<cdot> \<lbrace>u\<rbrace>"
using f u 1 preserves_comp_2 by (cases u; simp)
next
fix u v w
assume I1: "\<And>u. \<lbrakk> Nml v; Nml u; Arr u \<and> Dom v = Cod u \<rbrakk> \<Longrightarrow> \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>v\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
assume I2: "\<And>u. \<lbrakk> Nml w; Nml u; Arr u \<and> Dom w = Cod u \<rbrakk> \<Longrightarrow> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>w\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
assume vw: "Nml (v \<^bold>\<star> w)"
have v: "Nml v \<and> v = Prim (un_Prim v)"
using vw by (simp add: Nml_HcompD)
have w: "Nml w"
using vw by (simp add: Nml_HcompD)
assume u: "Nml u"
assume 1: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Arr u \<and> Dom v \<^bold>\<star> Dom w = Cod u"
show "\<lbrace>(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
using u 1 HcompNml_in_Hom apply (cases u, simp_all)
proof -
fix x y
assume 3: "u = x \<^bold>\<star> y"
have x: "Nml x"
using u 1 3 Nml_HcompD by simp
have y: "Nml y"
using u x 1 3 Nml_HcompD by simp
assume 4: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Dom v = Cod x \<and> Dom w = Cod y"
have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
using v w x y 4 HcompNml_in_Hom by simp
moreover have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>" by simp
moreover have "... = \<lbrace>v\<rbrace> \<cdot> \<lbrace>x\<rbrace> \<star> \<lbrace>w\<rbrace> \<cdot> \<lbrace>y\<rbrace>"
using v w x y 4 I1 [of x] I2 [of y] Nml_implies_Arr by simp
moreover have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
using v w x y 4 Nml_implies_Arr interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>x\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>y\<rbrace>"]
by (simp add: eval_simps')
ultimately have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)" by presburger
moreover have "arr \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<and> arr \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
using v w x y 4 VcompNml_in_Hom by simp
ultimately show "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
by simp
qed
qed
thus ?thesis using assms by blast
qed
lemma eval_red_Hcomp:
assumes "Ide a" and "Ide b"
shows "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
proof -
have "Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
proof -
assume 1: "Nml (a \<^bold>\<star> b)"
hence 2: "Nml a \<and> Nml b \<and> Src a = Trg b"
using Nml_HcompD(3-4,7) by simp
have "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>"
using 1 Nml_HcompD by simp
also have "... = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
using assms 1 2 ide_eval_Ide Nmlize_in_Hom red2_Nml Nmlize_Nml
by (simp add: eval_simps')
finally show ?thesis by simp
qed
moreover have "\<not> Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
using assms Can_red2 by (simp add: Can_red(1) iso_eval_Can)
ultimately show ?thesis by blast
qed
(* TODO: Would the following still be useful if \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 is replaced by Src t? *)
lemma eval_red2_Nml_Prim\<^sub>0:
assumes "Ide t" and "Nml t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
shows "\<lbrace>t \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
using assms \<rr>_ide_simp
apply (cases t)
apply simp_all
proof -
show "C.obj a \<Longrightarrow> t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<ll> (E a) = \<r>[E a]"
using unitor_coincidence obj_eval_Obj [of t] \<ll>_ide_simp by auto
show "\<And>b c. Ide b \<and> Ide c \<and> Src b = Trg c \<Longrightarrow> \<rr> (\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<r>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]"
using \<rr>_ide_simp by (simp add: eval_simps' ide_eval_Ide)
qed
end
text \<open>
Most of the time when we interpret the @{locale evaluation_map} locale, we are evaluating
terms formed from the arrows in a bicategory as arrows of the bicategory itself.
The following locale streamlines that use case.
\<close>
locale self_evaluation_map =
bicategory
begin
sublocale bicategorical_language V src trg ..
sublocale evaluation_map V src trg V H \<a> \<i> src trg \<open>\<lambda>\<mu>. if arr \<mu> then \<mu> else null\<close>
using src.is_extensional trg.is_extensional
by (unfold_locales, auto)
notation eval ("\<lbrace>_\<rbrace>")
notation Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
end
subsection "Coherence"
text \<open>
We define an individual term to be \emph{coherent} if it commutes, up to evaluation,
with the reductions of its domain and codomain. We then formulate the coherence theorem
as the statement ``every formal arrow is coherent''. Because reductions evaluate
to isomorphisms, this implies the standard version of coherence, which says that
``parallel canonical terms have equal evaluations''.
\<close>
context evaluation_map
begin
abbreviation coherent
where "coherent t \<equiv> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
lemma Nml_implies_coherent:
assumes "Nml t"
shows "coherent t"
using assms Nml_implies_Arr Ide_Dom Ide_Cod Nml_Dom Nml_Cod Nmlize_Nml red_Nml
by (metis Dom_Cod VcompNml_Cod_Nml arr_eval_Arr comp_arr_dom eval_VcompNml
eval_simps(4))
lemma canonical_factorization:
assumes "Arr t"
shows "coherent t \<longleftrightarrow> \<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
proof
assume 1: "coherent t"
have "inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>"
using 1 by simp
also have "... = (inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>t\<rbrace>"
using comp_assoc by simp
also have "... = \<lbrace>t\<rbrace>"
using assms red_in_Hom Ide_Cod Can_red iso_eval_Can comp_cod_arr
by (simp add: comp_inv_arr' eval_simps'(4) eval_simps'(5))
finally show "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
by presburger
next
assume 1: "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
hence "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
proof -
have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> = cod \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
inv_is_inverse Nmlize_in_Hom comp_arr_inv
by (simp add: eval_simps')
thus ?thesis
using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
Ide_Dom Nmlize_in_Hom comp_cod_arr
by (auto simp add: eval_simps')
qed
finally show "coherent t" by blast
qed
lemma coherent_iff_coherent_Inv:
assumes "Can t"
shows "coherent t \<longleftrightarrow> coherent (Inv t)"
proof
have 1: "\<And>t. Can t \<Longrightarrow> coherent t \<Longrightarrow> coherent (Inv t)"
proof -
fix t
assume "Can t"
hence t: "Can t \<and> Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and>
arr \<lbrace>t\<rbrace> \<and> iso \<lbrace>t\<rbrace> \<and> inverse_arrows \<lbrace>t\<rbrace> (inv \<lbrace>t\<rbrace>) \<and>
Can \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Arr \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> arr \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> iso \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
inverse_arrows \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<and> Inv t \<in> VHom (Cod t) (Dom t)"
using assms Can_implies_Arr Ide_Dom Ide_Cod iso_eval_Can inv_is_inverse
Nmlize_in_Hom Can_Nmlize_Can Inv_in_Hom
by simp
assume coh: "coherent t"
have "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace> = (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<cdot> \<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>"
using t comp_inv_arr red_in_Hom
comp_cod_arr [of "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>" "inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"]
by (auto simp add: eval_simps')
also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
using t eval_Inv_Can comp_assoc by auto
also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
using comp_assoc by simp
also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
using t coh by simp
also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>Inv t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
proof -
have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace> = \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
using t eval_Inv_Can red_in_Hom comp_arr_inv comp_arr_dom
by (simp add: eval_simps')
thus ?thesis
using t Nmlize_Inv eval_Inv_Can by simp
qed
finally show "coherent (Inv t)" by blast
qed
show "coherent t \<Longrightarrow> coherent (Inv t)" using assms 1 by simp
show "coherent (Inv t) \<Longrightarrow> coherent t"
proof -
assume "coherent (Inv t)"
hence "coherent (Inv (Inv t))"
using assms 1 Can_Inv by blast
thus ?thesis using assms by simp
qed
qed
text \<open>
The next two facts are trivially proved by the simplifier, so formal named facts
are not really necessary, but we include them for logical completeness of the
following development, which proves coherence by structural induction.
\<close>
lemma coherent_Prim\<^sub>0:
assumes "C.obj a"
shows "coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
by simp
lemma coherent_Prim:
assumes "Arr \<^bold>\<langle>f\<^bold>\<rangle>"
shows "coherent \<^bold>\<langle>f\<^bold>\<rangle>"
using assms by simp
lemma coherent_Lunit_Ide:
assumes "Ide t"
shows "coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
proof -
have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
using assms Ide_in_Hom Ide_Nmlize_Ide
red_in_Hom eval_in_hom ide_eval_Ide
by force
have 1: "Obj (Trg t)" using t by auto
have "\<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
using t \<ll>_ide_simp lunit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"] red_in_Hom
by (simp add: eval_simps')
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
using t 1 lunit_in_hom Nmlize_in_Hom ide_eval_Ide red_in_Hom comp_cod_arr hseqI'
by (auto simp add: eval_simps')
also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace>"
using 1 t Nml_Trg \<ll>_ide_simp by (cases "Trg t"; simp)
finally show ?thesis by simp
qed
text \<open>
Unlike many of the other results, the next one was not quite so straightforward to adapt
from @{session \<open>MonoidalCategory\<close>}.
\<close>
lemma coherent_Runit_Ide:
assumes "Ide t"
shows "coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
proof -
have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
using assms Ide_in_Hom Ide_Nmlize_Ide
red_in_Hom eval_in_hom ide_eval_Ide
by force
have "\<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
using t \<rr>_ide_simp red_in_Hom runit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"]
by (simp add: eval_simps')
also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace>"
proof -
have "\<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
using t by (cases t; simp; cases "Src t"; simp)
also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
proof -
have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<in> hom \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
using t Nmlize_in_Hom by auto
moreover have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<in> hom (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>) \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
proof -
have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<in> hom \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
proof -
have "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>Src t\<^bold>\<rfloor> \<and> \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using t Nmlize_Src Nml_Nmlize HcompNml_Nml_Src [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"]
by simp
thus ?thesis
using t Ide_Nmlize_Ide Nml_Nmlize Obj_Src red2_in_Hom(2)
by (auto simp add: eval_simps')
qed
thus ?thesis using t Nmlize_in_Hom Nmlize_Src by simp
qed
moreover have "\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace> \<in> hom (\<lbrace>t\<rbrace> \<star> \<lbrace>Src t\<rbrace>) (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
using t red_in_Hom red_Src Obj_Src hseqI'
by (auto simp add: eval_simps')
ultimately show ?thesis using comp_assoc by fastforce
qed
also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
proof -
have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>]"
proof -
have "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" using t Nml_Nmlize by blast
moreover have "is_Prim\<^sub>0 \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
using t is_Prim0_Src Nmlize_Src by presburger
ultimately show ?thesis
apply (cases "\<^bold>\<lfloor>t\<^bold>\<rfloor>"; simp; cases "\<^bold>\<lfloor>Src t\<^bold>\<rfloor>"; simp)
using t unitor_coincidence \<ll>_ide_simp \<rr>_ide_simp Nmlize_in_Hom
apply simp_all
using t is_Prim0_Src
apply (cases "\<^bold>\<lfloor>t\<^bold>\<rfloor>"; simp)
using t Nmlize_Src unitor_coincidence preserves_obj by simp
qed
moreover have "\<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<in> hom (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>) \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
using t Nmlize_in_Hom by (auto simp add: eval_simps'(2))
ultimately show ?thesis
using comp_cod_arr [of "\<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>]"] by fastforce
qed
also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
using t red_Src by auto
finally show ?thesis by argo
qed
finally show ?thesis by blast
qed
lemma coherent_Lunit'_Ide:
assumes "Ide a"
shows "coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
using assms Ide_implies_Can coherent_Lunit_Ide
coherent_iff_coherent_Inv [of "Lunit a"]
by simp
lemma coherent_Runit'_Ide:
assumes "Ide a"
shows "coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
using assms Ide_implies_Can coherent_Runit_Ide
coherent_iff_coherent_Inv [of "Runit a"]
by simp
lemma red2_Nml_Src:
assumes "Ide t" and "Nml t"
shows "\<lbrace>t \<^bold>\<Down> Src t\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
using assms eval_red2_Nml_Prim\<^sub>0 is_Prim0_Src [of t]
by (cases "Src t"; simp)
lemma red2_Trg_Nml:
assumes "Ide t" and "Nml t"
shows "\<lbrace>Trg t \<^bold>\<Down> t\<rbrace> = \<l>[\<lbrace>t\<rbrace>]"
using assms is_Prim0_Trg [of t] \<ll>_ide_simp ide_eval_Ide
by (cases "Trg t"; simp)
lemma coherence_key_fact:
assumes "Ide a \<and> Nml a" and "Ide b \<and> Nml b" and "Ide c \<and> Nml c"
and "Src a = Trg b" and "Src b = Trg c"
shows "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
(\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "is_Prim\<^sub>0 b \<Longrightarrow> ?thesis"
proof -
assume b: "is_Prim\<^sub>0 b"
have "\<lbrace>a \<^bold>\<Down> c\<rbrace> \<cdot> (\<r>[\<lbrace>a\<rbrace>] \<star> \<lbrace>c\<rbrace>) = (\<lbrace>a \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<l>[\<lbrace>c\<rbrace>])) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>Trg c\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "Src b = Trg b"
using b by (cases b; simp)
thus ?thesis
using assms triangle [of "\<lbrace>c\<rbrace>" "\<lbrace>a\<rbrace>"] ide_eval_Ide comp_assoc
by (simp add: eval_simps')
qed
thus ?thesis
using assms b HcompNml_Nml_Src [of a] HcompNml_Trg_Nml red2_Nml_Src [of a]
red2_Trg_Nml
by (cases b, simp_all)
qed
moreover have "\<lbrakk> \<not> is_Prim\<^sub>0 b; is_Prim\<^sub>0 c \<rbrakk> \<Longrightarrow> ?thesis"
proof -
assume b: "\<not> is_Prim\<^sub>0 b"
assume c: "is_Prim\<^sub>0 c"
have "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> Src b\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> src \<lbrace>b\<rbrace>)"
using assms b c by (cases c, simp_all add: eval_simps')
also have "... = \<r>[\<lbrace>a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>] \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> src \<lbrace>b\<rbrace>)"
using assms red2_Nml_Src [of "a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b"] Nml_HcompNml(1) Src_HcompNml Ide_HcompNml
by simp
also have "... = \<lbrace>a \<^bold>\<Down> b\<rbrace> \<cdot> \<r>[\<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>]"
proof -
have "\<guillemotleft>\<lbrace>a \<^bold>\<Down> b\<rbrace> : \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace> \<Rightarrow> \<lbrace>a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>\<guillemotright>"
using assms red2_in_Hom eval_in_hom [of "a \<^bold>\<Down> b"] by simp
thus ?thesis
using assms runit_naturality
by (metis (no_types, lifting) arr_dom in_homE src_dom hcomp_simps(1))
qed
also have "... = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "(\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] =
(\<lbrace>a \<^bold>\<Down> b\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<r>[\<lbrace>b\<rbrace>])) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, src \<lbrace>b\<rbrace>]"
using assms c red2_Nml_Src [of b]
by (cases c, simp_all add: eval_simps')
thus ?thesis
using assms runit_hcomp ide_eval_Ide comp_assoc
by (simp add: eval_simps')
qed
finally show ?thesis by blast
qed
moreover have "\<lbrakk> \<not> is_Prim\<^sub>0 b; \<not> is_Prim\<^sub>0 c \<rbrakk> \<Longrightarrow> ?thesis"
proof -
assume b': "\<not> is_Prim\<^sub>0 b"
hence b: "Ide b \<and> Nml b \<and> Arr b \<and> \<not> is_Prim\<^sub>0 b \<and>
ide \<lbrace>b\<rbrace> \<and> arr \<lbrace>b\<rbrace> \<and> \<^bold>\<lfloor>b\<^bold>\<rfloor> = b \<and> b\<^bold>\<down> = b \<and> Dom b = b \<and> Cod b = b"
using assms Ide_Nmlize_Ide Ide_in_Hom ide_eval_Ide by simp
assume c': "\<not> is_Prim\<^sub>0 c"
hence c: "Ide c \<and> Nml c \<and> Arr c \<and> \<not> is_Prim\<^sub>0 c \<and>
ide \<lbrace>c\<rbrace> \<and> arr \<lbrace>c\<rbrace> \<and> \<^bold>\<lfloor>c\<^bold>\<rfloor> = c \<and> c\<^bold>\<down> = c \<and> Dom c = c \<and> Cod c = c"
using assms Ide_Nmlize_Ide Ide_in_Hom ide_eval_Ide by simp
have "\<And>a. Ide a \<and> Nml a \<and> Src a = Trg b \<Longrightarrow>
\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
= (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
fix a :: "'c term"
show "Ide a \<and> Nml a \<and> Src a = Trg b \<Longrightarrow>
\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
= (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
apply (induct a)
using b c HcompNml_in_Hom
apply (simp_all add: HcompNml_Nml_Src HcompNml_Trg_Nml)
proof -
fix f
assume f: "C.ide f \<and> C.arr f \<and> \<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0 = Trg b"
show "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
(\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
((E f \<star> \<lbrace>b\<rbrace>) \<star> \<lbrace>c\<rbrace>)"
proof -
have "((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
((E f \<star> \<lbrace>b\<rbrace>) \<star> \<lbrace>c\<rbrace>) =
((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
(\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
using f b red2_Nml by simp
also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
(\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
proof -
have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> = E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>"
using assms(5) b c is_Hcomp_HcompNml red2_Nml Nml_HcompNml(1)
is_Hcomp_def
by (metis eval.simps(2) eval.simps(3) red2.simps(4))
thus ?thesis by argo
qed
also have "... = \<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
using b c \<alpha>_def by (cases c, simp_all)
finally show ?thesis by argo
qed
also have "... = ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "src (E f) = trg \<lbrace>b\<rbrace>"
using b f preserves_src
by (cases "Trg b", auto simp add: eval_simps')
thus ?thesis
using assms b c f comp_arr_dom comp_assoc
by (auto simp add: eval_simps')
qed
also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms f b c Ide_HcompNml HcompNml_Prim Nml_HcompNml
is_Hcomp_HcompNml [of b c] \<alpha>_def
by (cases "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
finally show ?thesis by blast
qed
next
fix x
assume x: "C.obj x \<and> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg b"
show "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>Trg b \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
(\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have 1: "Trg (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c) = Trg b"
using assms b c Trg_HcompNml by blast
have 2: "\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> = \<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]"
using assms b c 1 Nml_HcompNml red2_Trg_Nml [of "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c"] Ide_HcompNml
by simp
have "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>Trg b \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<l>[\<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
using b c 1 2 HcompNml_Trg_Nml red2_Trg_Nml Trg_HcompNml by simp
also have "... = \<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms b c lunit_hcomp [of "\<lbrace>b\<rbrace>" "\<lbrace>c\<rbrace>"]
by (metis (no_types, lifting) eval_simps'(3) eval_simps(2))
also have "... = (\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using comp_assoc by simp
also have "... = (\<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>] \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms b c lunit_naturality [of "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] red2_in_Hom
by (simp add: eval_simps')
also have "... = (\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using b c 1 2 HcompNml_Trg_Nml red2_Trg_Nml Trg_HcompNml comp_assoc
by simp
finally show ?thesis
by blast
qed
next
fix d e
assume I: "Nml e \<Longrightarrow> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
= (\<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
assume de: "Ide d \<and> Ide e \<and> Src d = Trg e \<and> Nml (d \<^bold>\<star> e) \<and> Src e = Trg b"
show "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
= (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
let ?f = "un_Prim d"
have "is_Prim d"
using de Nml_HcompD
by (metis term.disc(12))
hence "d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f"
using de by (cases d; simp)
hence d: "Ide d \<and> Arr d \<and> Dom d = d \<and> Cod d = d \<and> Nml d \<and>
d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f \<and> ide \<lbrace>d\<rbrace> \<and> arr \<lbrace>d\<rbrace>"
using de ide_eval_Ide Nml_Nmlize(1) Ide_in_Hom Nml_HcompD [of d e]
by simp
have "Nml e \<and> \<not> is_Prim\<^sub>0 e"
using de Nml_HcompD by metis
hence e: "Ide e \<and> Arr e \<and> Dom e = e \<and> Cod e = e \<and> Nml e \<and>
\<not> is_Prim\<^sub>0 e \<and> ide \<lbrace>e\<rbrace> \<and> arr \<lbrace>e\<rbrace>"
using de Ide_in_Hom ide_eval_Ide by simp
have 1: "is_Hcomp (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<and> is_Hcomp (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c) \<and> is_Hcomp (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)"
using assms b c e de is_Hcomp_HcompNml [of e b] Nml_HcompNml
is_Hcomp_HcompNml [of b c] is_Hcomp_HcompNml [of e "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c"]
by auto
have eb: "Src e = Trg b"
using assms b c e de by argo
have bc: "Src b = Trg c"
using assms b c by simp
have 4: "is_Hcomp ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)"
using assms b c e eb de 1 is_Hcomp_HcompNml [of e b]
is_Hcomp_HcompNml [of "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b" c] is_Hcomp_HcompNml [of e b]
Nml_HcompNml(1) [of e b] Src_HcompNml
by auto
have "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
= ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
proof -
have "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>
= (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<Down> c"
using b c d e de 1 HcompNml_Nml Nml_HcompNml HcompNml_assoc
HcompNml_Prim
by (metis term.distinct_disc(4))
also have "... = (d \<^bold>\<Down> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b, c\<^bold>]"
using b c d e de 1 Nml_HcompNml Nmlize_Nml
by (cases c, simp_all)
also have "... = (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b, c\<^bold>]"
using d 4
apply (cases d, simp_all)
by (cases "(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
finally show ?thesis
using b c d e HcompNml_in_Hom red2_in_Hom
Nml_HcompNml Ide_HcompNml \<alpha>_def
by simp
qed
moreover have "\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace>
= (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]"
proof -
have "(d \<^bold>\<star> e) \<^bold>\<Down> b = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
using b c d e de 1 HcompNml_Prim Nmlize_Nml
by (cases b, simp_all)
also have "... = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
using b c d e de 1 HcompNml_Nml Nml_HcompNml
apply (cases d, simp_all)
by (cases "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b", simp_all)
finally show ?thesis
using b d e HcompNml_in_Hom red2_in_Hom \<alpha>_def by simp
qed
ultimately show ?thesis by argo
qed
also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
proof -
have "(\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>
= ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
using assms b c d e de eb HcompNml_in_Hom red2_in_Hom comp_cod_arr
Ide_HcompNml Nml_HcompNml comp_assoc
interchange [of "\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]" "\<lbrace>c\<rbrace>" "\<lbrace>c\<rbrace>"]
by (auto simp add: eval_simps' hseqI')
moreover have "(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] =
(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] =
((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
using comp_assoc by simp
thus ?thesis
using assms b c d e de eb HcompNml_in_Hom red2_in_Hom
Ide_HcompNml Nml_HcompNml comp_cod_arr
by (simp add: eval_simps' hseqI')
qed
ultimately show ?thesis by argo
qed
also have "... = (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
using assms b c d e de HcompNml_in_Hom red2_in_Hom
Ide_HcompNml Nml_HcompNml ide_eval_Ide
assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<lbrace>c\<rbrace>"]
comp_permute [of "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]" "(\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>"
"\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"]
comp_assoc
by (simp add: eval_simps' hseqI')
also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>))) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
using comp_assoc by simp
also have "... = (((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
(\<lbrace>d\<rbrace> \<star> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>])) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
using assms b c d e de eb I HcompNml_in_Hom red2_in_Hom
Ide_HcompNml Nml_HcompNml whisker_left [of "\<lbrace>d\<rbrace>"]
interchange [of "\<lbrace>d\<rbrace>" "\<lbrace>d\<rbrace>" "\<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>"]
by (auto simp add: eval_simps' hseqI')
also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
((\<lbrace>d\<rbrace> \<star> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>))"
using comp_assoc by simp
also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>))) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms b c d e de pentagon
by (simp add: eval_simps')
also have "... = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
((\<lbrace>d\<rbrace> \<star> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]) \<cdot>
\<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using comp_assoc by simp
also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>)) \<cdot>
(\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>] \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms d e de HcompNml_in_Hom red2_in_Hom Ide_HcompNml Nml_HcompNml
assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e\<rbrace>" "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] comp_cod_arr [of "\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>"]
by (simp add: eval_simps' hseqI')
also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]) \<cdot>
((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using comp_assoc by simp
also have "... = \<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>
= (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]"
proof -
have "(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)
= (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>\<rfloor>)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
using e 1 by (cases "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c") auto
also have "... = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
using assms Nml_HcompNml Nmlize_Nml by simp
also have "... = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
using d 1
apply (cases "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
by (cases d, simp_all)
finally show ?thesis
using \<alpha>_def by simp
qed
thus ?thesis by simp
qed
also have "... = (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using comp_assoc by simp
finally show ?thesis by auto
qed
qed
qed
thus ?thesis using assms(1,4) by blast
qed
ultimately show ?thesis by blast
qed
lemma coherent_Assoc_Ide:
assumes "Ide a" and "Ide b" and "Ide c" and "Src a = Trg b" and "Src b = Trg c"
shows "coherent \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
proof -
have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
using assms Ide_in_Hom Ide_Nmlize_Ide ide_eval_Ide red_in_Hom eval_in_hom(2)
by force
have b: "Ide b \<and> Arr b \<and> Dom b = b \<and> Cod b = b \<and>
ide \<lbrace>b\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>b\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>b\<rbrace> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>"
using assms Ide_in_Hom Ide_Nmlize_Ide ide_eval_Ide red_in_Hom(2)
eval_in_hom(2) [of "b\<^bold>\<down>"]
by auto
have c: "Ide c \<and> Arr c \<and> Dom c = c \<and> Cod c = c \<and>
ide \<lbrace>c\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>c\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>c\<rbrace> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"
using assms Ide_in_Hom Ide_Nmlize_Ide red_in_Hom eval_in_hom(2) [of "c\<^bold>\<down>"]
ide_eval_Ide
by auto
have "\<lbrace>Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace>
= (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace> \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)) \<cdot>
\<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms a b c red_in_Hom red2_in_Hom Nml_Nmlize Ide_Nmlize_Ide
\<alpha>_def eval_red_Hcomp interchange [of "\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>" "\<lbrace>a\<^bold>\<down>\<rbrace>"] comp_cod_arr [of "\<lbrace>a\<^bold>\<down>\<rbrace>"]
by (simp add: eval_simps' hseqI')
also have "... = ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> \<a>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>]) \<cdot>
((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
using assms red_in_Hom Ide_HcompNml assoc_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>" "\<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"] comp_assoc
by (simp add: eval_simps')
also have "... = (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
using assms Nml_Nmlize Ide_Nmlize_Ide coherence_key_fact by simp
also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace>"
using assms a b c red_in_Hom red2_in_Hom Ide_Nmlize_Ide
Nml_Nmlize eval_red_Hcomp HcompNml_assoc
interchange [of "\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>" "\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"]
comp_cod_arr [of "\<lbrace>c\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"]
apply (simp add: eval_simps' hseqI')
proof -
have "seq \<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>))"
using assms c red_in_Hom red2_in_Hom Nml_HcompNml Ide_Nmlize_Ide Ide_HcompNml
Nml_Nmlize
by (simp_all add: eval_simps' hseqI')
moreover have
"cod (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)) =
\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"
using assms c red_in_Hom red2_in_Hom Nml_HcompNml Ide_Nmlize_Ide Ide_HcompNml
Nml_Nmlize HcompNml_assoc
by (simp add: eval_simps' hseqI')
ultimately
show "(\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>) =
\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot>
\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
using comp_cod_arr comp_assoc by simp
qed
finally show ?thesis by blast
qed
lemma coherent_Assoc'_Ide:
assumes "Ide a" and "Ide b" and "Ide c" and "Src a = Trg b" and "Src b = Trg c"
shows "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]"
using assms Ide_implies_Can coherent_Assoc_Ide Inv_Ide coherent_iff_coherent_Inv
Can.simps(10) Inv.simps(10)
by presburger
lemma eval_red2_naturality:
assumes "Nml t" and "Nml u" and "Src t = Trg u"
shows "\<lbrace>Cod t \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom t \<^bold>\<Down> Dom u\<rbrace>"
proof -
have *: "\<And>t u. Nml (t \<^bold>\<star> u) \<Longrightarrow> arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>u\<rbrace>"
using Nml_implies_Arr Nml_HcompD by simp
have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis"
using assms Nml_implies_Arr is_Prim0_Trg \<ll>.naturality [of "\<lbrace>u\<rbrace>"]
by (cases t, simp_all add: eval_simps', cases "Trg t", simp_all)
moreover have "\<not> is_Prim\<^sub>0 t \<and> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
using assms Nml_implies_Arr eval_red2_Nml_Prim\<^sub>0 runit_naturality [of "\<lbrace>t\<rbrace>"]
by (cases u, simp_all add: eval_simps')
moreover have "\<not> is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
using assms * Nml_implies_Arr
apply (induct t, simp_all)
proof -
fix f
assume f: "C.arr f"
assume "\<not> is_Prim\<^sub>0 u"
hence u: "\<not> is_Prim\<^sub>0 u \<and>
Nml u \<and> Nml (Dom u) \<and> Nml (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms(2) Nml_implies_Arr ide_eval_Ide by simp
hence 1: "\<not> is_Prim\<^sub>0 (Dom u) \<and> \<not> is_Prim\<^sub>0 (Cod u)"
using u by (cases u, simp_all)
assume "\<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0 = Trg u"
hence "\<lbrace>\<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0\<rbrace> = \<lbrace>Trg u\<rbrace>" by simp
hence fu: "src (E f) = trg \<lbrace>u\<rbrace>"
using f u preserves_src Nml_implies_Arr
by (simp add: eval_simps')
show "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> \<cdot> (E f \<star> \<lbrace>u\<rbrace>) = (E f \<star> \<lbrace>u\<rbrace>) \<cdot> \<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace>"
proof -
have "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> = E (C.cod f) \<star> cod \<lbrace>u\<rbrace>"
using f u 1 Nml_implies_Arr
by (cases "Cod u", simp_all add: eval_simps')
moreover have "\<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace> = E (C.dom f) \<star> dom \<lbrace>u\<rbrace>"
using f u 1 Nml_implies_Arr
by (cases "Dom u", simp_all add: eval_simps')
moreover have "E f \<star> \<lbrace>u\<rbrace> \<in> hom (E (C.dom f) \<star> \<lbrace>Dom u\<rbrace>) (E (C.cod f) \<star> \<lbrace>Cod u\<rbrace>)"
using f u fu Nml_implies_Arr
by (auto simp add: eval_simps' hseqI')
ultimately show ?thesis
using f u comp_arr_dom comp_cod_arr
by (simp add: fu hseqI')
qed
next
fix v w
assume I2: "\<lbrakk> \<not> is_Prim\<^sub>0 w; Nml w \<rbrakk> \<Longrightarrow>
\<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"
assume "\<not> is_Prim\<^sub>0 u"
hence u: "\<not> is_Prim\<^sub>0 u \<and> Arr u \<and> Arr (Dom u) \<and> Arr (Cod u) \<and>
Nml u \<and> Nml (Dom u) \<and> Nml (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms(2) Nml_implies_Arr ide_eval_Ide by simp
assume vw: "Nml (v \<^bold>\<star> w)"
assume wu: "Src w = Trg u"
let ?f = "un_Prim v"
have "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f"
using vw by (metis Nml_HcompD(1) Nml_HcompD(2))
hence "Arr v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr ?f \<and> Nml v" by (cases v; simp)
hence v: "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f \<and> Arr v \<and> Arr (Dom v) \<and> Arr (Cod v) \<and> Nml v \<and>
Nml (Dom v) \<and> Nml (Cod v) \<and>
arr \<lbrace>v\<rbrace> \<and> arr \<lbrace>Dom v\<rbrace> \<and> arr \<lbrace>Cod v\<rbrace> \<and> ide \<lbrace>Dom v\<rbrace> \<and> ide \<lbrace>Cod v\<rbrace>"
using vw * by (cases v, simp_all)
have "Nml w \<and> \<not> is_Prim\<^sub>0 w"
using vw v by (metis Nml.simps(3))
hence w: "\<not> is_Prim\<^sub>0 w \<and> Arr w \<and> Arr (Dom w) \<and> Arr (Cod w) \<and>
Nml w \<and> Nml (Dom w) \<and> Nml (Cod w) \<and>
Ide (Dom w) \<and> Ide (Cod w) \<and>
arr \<lbrace>w\<rbrace> \<and> arr \<lbrace>Dom w\<rbrace> \<and> arr \<lbrace>Cod w\<rbrace> \<and> ide \<lbrace>Dom w\<rbrace> \<and> ide \<lbrace>Cod w\<rbrace>"
using vw * Nml_implies_Arr ide_eval_Ide by simp
have u': "\<not> is_Prim\<^sub>0 (Dom u) \<and> \<not> is_Prim\<^sub>0 (Cod u)"
using u by (cases u, simp_all)
have w': "\<not> is_Prim\<^sub>0 (Dom w) \<and> \<not> is_Prim\<^sub>0 (Cod w)"
using w by (cases w, simp_all)
have vw': "Src v = Trg w"
using vw Nml_HcompD(7) by simp
have X: "Nml (Dom v \<^bold>\<star> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u))"
using u u' v w w' wu vw is_Hcomp_HcompNml Nml_HcompNml
apply (cases v, simp_all)
apply (cases "Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u", simp_all)
apply (cases "Dom v", simp_all)
by (metis Src_Dom Trg_Dom term.disc(21))
have Y: "Nml (Cod v \<^bold>\<star> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u))"
using u u' w w' wu vw is_Hcomp_HcompNml Nml_HcompNml
apply (cases v, simp_all)
apply (cases "Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u", simp_all)
apply (cases "Cod v", simp_all)
by (metis Src_Cod Trg_Cod term.disc(21))
show "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)
= \<lbrace>(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
proof -
have "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)
= (\<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
\<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
proof -
have "(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u
= (Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Cod v \<^bold>\<star> Cod w \<^bold>\<Down> Cod u) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[Cod v, Cod w, Cod u\<^bold>]"
using u v w by (cases u, simp_all)
hence "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace>
= \<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
\<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
using u v w \<alpha>_def by simp
thus ?thesis by presburger
qed
also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
\<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
using u v w Y red2_Nml by simp
also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot>
((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
using u v w vw' wu comp_cod_arr red2_in_Hom HcompNml_in_Hom comp_reduce
by (simp add: eval_simps' hseqI')
also have "... = (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>] \<cdot>
((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
using comp_assoc by simp
also have "... = (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u v w vw' wu assoc_naturality [of "\<lbrace>v\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>u\<rbrace>"]
by (simp add: eval_simps')
also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>)) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using comp_assoc by simp
also have
"... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using v w u vw' wu I2 red2_in_Hom HcompNml_in_Hom comp_cod_arr
interchange [of "\<lbrace>Cod v\<rbrace>" "\<lbrace>v\<rbrace>" "\<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>" "\<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>"]
by (simp add: eval_simps')
also have "... = ((\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>)) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using v w u vw' wu red2_in_Hom HcompNml_in_Hom comp_arr_dom
interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>Dom v\<rbrace>" "\<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>" "\<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"]
by (simp add: eval_simps')
also have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using comp_assoc by simp
also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u u' v w vw' wu is_Hcomp_HcompNml HcompNml_Prim [of "w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u" ?f]
by force
also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
(\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
proof -
have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>] =
(\<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace>) \<cdot>
(\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u v w vw' wu comp_arr_dom Nml_HcompNml HcompNml_in_Hom
by (simp add: eval_simps')
also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
(\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using comp_assoc by simp
finally show ?thesis by blast
qed
also have "... = \<lbrace>(v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
proof -
have "(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u
= (Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Dom v \<^bold>\<star> (Dom w \<^bold>\<Down> Dom u)) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[Dom v, Dom w, Dom u\<^bold>]"
using u u' v w vw' wu by (cases u, simp_all)
hence
"\<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>
= \<lbrace>Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u)\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u v w \<alpha>_def by simp
also have
"... = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using X HcompNml_Nml red2_Nml by presburger
finally have
"\<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>
= \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
by blast
thus ?thesis
using assms v w vw' wu HcompNml_assoc by presburger
qed
finally show ?thesis
using vw HcompNml_Nml by simp
qed
qed
ultimately show ?thesis by blast
qed
lemma coherent_Hcomp:
assumes "Arr t" and "Arr u" and "Src t = Trg u" and "coherent t" and "coherent u"
shows "coherent (t \<^bold>\<star> u)"
proof -
have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
using assms Ide_Nmlize_Ide ide_eval_Ide by auto
have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms Ide_Nmlize_Ide ide_eval_Ide by auto
have "\<lbrace>Cod (t \<^bold>\<star> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)
= (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Cod u\<^bold>\<down>\<rbrace>)) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)"
using t u eval_red_Hcomp by simp
also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Cod u\<^bold>\<down>\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using assms t u Nmlize_in_Hom red_in_Hom
interchange [of "\<lbrace>Cod t\<^bold>\<down>\<rbrace>" "\<lbrace>t\<rbrace>" "\<lbrace>Cod u\<^bold>\<down>\<rbrace>" "\<lbrace>u\<rbrace>"]
interchange [of "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>" "\<lbrace>Dom t\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>" "\<lbrace>Dom u\<^bold>\<down>\<rbrace>"]
by (simp add: eval_simps')
also have "... = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>)) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using comp_assoc by simp
also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using assms t u Nml_Nmlize Nmlize_in_Hom
eval_red2_naturality [of "Nmlize t" "Nmlize u"]
by simp
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<star> Dom u)\<^bold>\<down>\<rbrace>"
using t u eval_red_Hcomp by simp
finally have "\<lbrace>Cod (t \<^bold>\<star> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<star> Dom u)\<^bold>\<down>\<rbrace>"
by blast
thus ?thesis using t u by simp
qed
lemma coherent_Vcomp:
assumes "Arr t" and "Arr u" and "Dom t = Cod u"
and "coherent t" and "coherent u"
shows "coherent (t \<^bold>\<cdot> u)"
proof -
have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
using assms Ide_Nmlize_Ide ide_eval_Ide by auto
have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms Ide_Nmlize_Ide ide_eval_Ide by auto
have "\<lbrace>Cod (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
using t u by simp
also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
proof -
have "seq \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<lbrace>t\<rbrace>"
using assms t red_in_Hom
by (intro seqI, auto simp add: eval_simps')
moreover have "seq \<lbrace>t\<rbrace> \<lbrace>u\<rbrace>"
using assms t u by (auto simp add: eval_simps')
ultimately show ?thesis
using comp_assoc by auto
qed
also have "... = \<lbrace>\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace>"
using t u assms red_in_Hom Nml_Nmlize comp_assoc
by (simp add: eval_simps' Nml_implies_Arr eval_VcompNml)
finally show "coherent (t \<^bold>\<cdot> u)" by blast
qed
text \<open>
The main result: ``Every formal arrow is coherent.''
\<close>
theorem coherence:
assumes "Arr t"
shows "coherent t"
proof -
have "Arr t \<Longrightarrow> coherent t"
proof (induct t)
show "\<And>a. Arr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0" by simp
show "\<And>\<mu>. Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<Longrightarrow> coherent \<^bold>\<langle>\<mu>\<^bold>\<rangle>" by simp
fix u v
show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<star> v)
\<Longrightarrow> coherent (u \<^bold>\<star> v)"
using coherent_Hcomp by simp
show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<cdot> v)
\<Longrightarrow> coherent (u \<^bold>\<cdot> v)"
using coherent_Vcomp by simp
next
fix t
assume I: "Arr t \<Longrightarrow> coherent t"
show Lunit: "Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
using I Ide_Dom coherent_Lunit_Ide Ide_in_Hom
coherent_Vcomp [of t "\<^bold>\<l>\<^bold>[Dom t\<^bold>]"] Nmlize_Vcomp_Arr_Dom
eval_in_hom \<ll>.is_natural_1 [of "\<lbrace>t\<rbrace>"]
by force
show Runit: "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
using I Ide_Dom coherent_Runit_Ide Ide_in_Hom ide_eval_Ide
coherent_Vcomp [of t "\<^bold>\<r>\<^bold>[Dom t\<^bold>]"] Nmlize_Vcomp_Arr_Dom \<rr>_ide_simp
eval_in_hom \<rr>.is_natural_1 [of "\<lbrace>t\<rbrace>"]
by force
show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
proof -
assume "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
hence t: "Arr t" by simp
have "coherent (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
using t I Ide_Cod coherent_Lunit'_Ide Ide_in_Hom coherent_Vcomp [of "\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
Arr.simps(6) Dom.simps(6) Dom_Cod Ide_implies_Arr
by presburger
moreover have "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t\<rbrace>"
using t \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
by (simp add: eval_simps(5))
ultimately show ?thesis
using t Nmlize_Vcomp_Cod_Arr by simp
qed
show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
proof -
assume "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
hence t: "Arr t" by simp
have "coherent (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
using t I Ide_Cod coherent_Runit'_Ide Ide_in_Hom coherent_Vcomp [of "\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
Arr.simps(8) Dom.simps(8) Dom_Cod Ide_implies_Arr
by presburger
moreover have "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t\<rbrace>"
using t \<rr>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
by (simp add: eval_simps(5))
ultimately show ?thesis
using t Nmlize_Vcomp_Cod_Arr by simp
qed
next
fix t u v
assume I1: "Arr t \<Longrightarrow> coherent t"
assume I2: "Arr u \<Longrightarrow> coherent u"
assume I3: "Arr v \<Longrightarrow> coherent v"
show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
proof -
assume tuv: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
have t: "Arr t" using tuv by simp
have u: "Arr u" using tuv by simp
have v: "Arr v" using tuv by simp
have tu: "Src t = Trg u" using tuv by simp
have uv: "Src u = Trg v" using tuv by simp
have "coherent ((t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
proof -
have "Arr (t \<^bold>\<star> u \<^bold>\<star> v) \<and> coherent (t \<^bold>\<star> u \<^bold>\<star> v)"
using t u v tu uv tuv I1 I2 I3 coherent_Hcomp Arr.simps(3) Trg.simps(3)
by presburger
moreover have "Arr \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v tu uv Ide_Dom by simp
moreover have "coherent \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v tu uv Src_Dom Trg_Dom Ide_Dom coherent_Assoc_Ide by metis
moreover have "Dom (t \<^bold>\<star> u \<^bold>\<star> v) = Cod \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v by simp
ultimately show ?thesis
using t u v coherent_Vcomp by blast
qed
moreover have "VPar \<^bold>\<a>\<^bold>[t, u, v\<^bold>] ((t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
using t u v tu uv Ide_Dom by simp
moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>(t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
proof -
have "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>
= (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>)"
proof -
have 1: "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Nml \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Nml \<^bold>\<lfloor>v\<^bold>\<rfloor> \<and>
Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>"
using t u v Nml_Nmlize by blast
moreover have "Nml (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>)"
using 1 t u tu Nmlize_Src Nmlize_Trg Nml_HcompNml(1)
by presburger
moreover have "\<And>t. Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using t Nmlize_Vcomp_Arr_Dom by simp
moreover have "Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor>"
using Nml_Nmlize tuv by blast
ultimately show ?thesis
using t u v tu uv tuv 1 HcompNml_assoc Nml_HcompNml
Nml_Nmlize VcompNml_Nml_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
by auto
qed
thus ?thesis
using t u v Nmlize_Vcomp_Arr_Dom VcompNml_HcompNml Nml_Nmlize
by simp
qed
moreover have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>(t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
using t u v tu uv Ide_Dom comp_cod_arr ide_eval_Ide \<alpha>_def
apply (simp add: eval_simps')
using assoc_is_natural_1 arr_eval_Arr eval_simps'(2-4) by presburger
ultimately show "coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]" by argo
qed
show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
proof -
assume tuv: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
have t: "Arr t" using tuv by simp
have u: "Arr u" using tuv by simp
have v: "Arr v" using tuv by simp
have tu: "Src t = Trg u" using tuv by simp
have uv: "Src u = Trg v" using tuv by simp
have "coherent (((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
proof -
have "Arr ((t \<^bold>\<star> u) \<^bold>\<star> v) \<and> coherent ((t \<^bold>\<star> u) \<^bold>\<star> v)"
using t u v tu uv tuv I1 I2 I3 coherent_Hcomp Arr.simps(3) Src.simps(3)
by presburger
moreover have "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v tu uv Ide_Dom by simp
moreover have "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v tu uv Src_Dom Trg_Dom Ide_Dom coherent_Assoc'_Ide
by metis
moreover have "Dom ((t \<^bold>\<star> u) \<^bold>\<star> v) = Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v by simp
ultimately show ?thesis
using t u v coherent_Vcomp by metis
qed
moreover have "VPar \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] (((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
using t u v tu uv Ide_Dom by simp
moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
using t u v tu uv Nmlize_Vcomp_Arr_Dom VcompNml_HcompNml Nml_Nmlize
HcompNml_assoc Nml_HcompNml HcompNml_in_Hom
VcompNml_Nml_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
by simp
moreover have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
proof -
have 1: "VVV.arr (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
using tuv \<alpha>'.preserves_reflects_arr arr_eval_Arr eval.simps(10)
by (metis (no_types, lifting))
have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
proof -
have "VVV.arr (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
using tuv \<alpha>'.preserves_reflects_arr arr_eval_Arr eval.simps(10)
by (metis (no_types, lifting))
thus ?thesis
using t u v \<alpha>'.is_natural_1 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] HoHV_def \<a>'_def
by simp
qed
also have "... = \<lbrace>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
by (simp add: eval_simps'(4) t u v \<a>'_def)
finally show ?thesis by blast
qed
ultimately show "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]" by argo
qed
qed
thus ?thesis using assms by blast
qed
corollary eval_eqI:
assumes "VPar t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
using assms coherence canonical_factorization by simp
text \<open>
The following allows us to prove that two 1-cells in a bicategory are isomorphic
simply by expressing them as the evaluations of terms having the same normalization.
The benefits are: (1) we do not have to explicitly exhibit the isomorphism,
which is canonical and is obtained by evaluating the reductions of the terms
to their normalizations, and (2) the normalizations can be computed automatically
by the simplifier.
\<close>
lemma canonically_isomorphicI:
assumes "f = \<lbrace>t\<rbrace>" and "g = \<lbrace>u\<rbrace>" and "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "f \<cong> g"
proof -
have "f \<cong> \<lbrace>t\<rbrace>"
using assms isomorphic_reflexive ide_eval_Ide by blast
also have "... \<cong> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
proof -
have "\<guillemotleft>\<lbrace>t\<^bold>\<down>\<rbrace> : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>\<guillemotright> \<and> iso \<lbrace>t\<^bold>\<down>\<rbrace>"
using assms(1,3) Can_red iso_eval_Can red_in_Hom(2) eval_in_hom(2) by fastforce
thus ?thesis
using isomorphic_def by blast
qed
also have "... \<cong> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>"
using assms isomorphic_reflexive
by (simp add: Ide_Nmlize_Ide ide_eval_Ide)
also have "... \<cong> \<lbrace>u\<rbrace>"
proof -
have "\<guillemotleft>\<lbrace>u\<^bold>\<down>\<rbrace> : \<lbrace>u\<rbrace> \<Rightarrow> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>\<guillemotright> \<and> iso \<lbrace>u\<^bold>\<down>\<rbrace>"
using assms(2,4) Can_red iso_eval_Can red_in_Hom(2) eval_in_hom(2) by fastforce
thus ?thesis
using isomorphic_def isomorphic_symmetric by blast
qed
also have "... \<cong> g"
using assms isomorphic_reflexive ide_eval_Ide by blast
finally show ?thesis by simp
qed
end
end
diff --git a/thys/Bicategory/ConcreteCategory.thy b/thys/Bicategory/ConcreteCategory.thy
deleted file mode 100644
--- a/thys/Bicategory/ConcreteCategory.thy
+++ /dev/null
@@ -1,420 +0,0 @@
-(* Title: ConcreteCategory
- Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
- Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
-*)
-
-section "Concrete Categories"
-
-text \<open>
- This theory developed in this section provides a uniform way to construct a category from
- specified sets of objects and arrows, and proves that the identities and arrows of the
- constructed category are appropriately in bijective correspondence with the given sets.
- This is a general tool that would more properly appear in @{session \<open>Category3\<close>}
- (see \cite{Category3-AFP}) and it will likely eventually be moved there.
-\<close>
-
-theory ConcreteCategory
-imports Category3.Category
-begin
-
- datatype ('o, 'a) arr =
- Null
- | MkArr 'o 'o 'a
-
- locale concrete_category =
- fixes Obj :: "'o set"
- and Hom :: "'o \<Rightarrow> 'o \<Rightarrow> 'a set"
- and Id :: "'o \<Rightarrow> 'a"
- and Comp :: "'o \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>'a"
- assumes Id_in_Hom: "A \<in> Obj \<Longrightarrow> Id A \<in> Hom A A"
- and Comp_in_Hom: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; f \<in> Hom A B; g \<in> Hom B C \<rbrakk>
- \<Longrightarrow> Comp C B A g f \<in> Hom A C"
- and Comp_Hom_Id: "\<lbrakk> A \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B A A f (Id A) = f"
- and Comp_Id_Hom: "\<lbrakk> B \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B B A (Id B) f = f"
- and Comp_assoc: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; D \<in> Obj;
- f \<in> Hom A B; g \<in> Hom B C; h \<in> Hom C D \<rbrakk> \<Longrightarrow>
- Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
- begin
-
- abbreviation MkIde :: "'o \<Rightarrow> ('o, 'a) arr"
- where "MkIde A \<equiv> MkArr A A (Id A)"
-
- fun Dom :: "('o, 'a) arr \<Rightarrow> 'o"
- where "Dom (MkArr A _ _) = A"
- | "Dom _ = undefined"
-
- fun Cod
- where "Cod (MkArr _ B _) = B"
- | "Cod _ = undefined"
-
- fun Map
- where "Map (MkArr _ _ F) = F"
- | "Map _ = undefined"
-
- abbreviation Arr
- where "Arr f \<equiv> f \<noteq> Null \<and> Dom f \<in> Obj \<and> Cod f \<in> Obj \<and> Map f \<in> Hom (Dom f) (Cod f)"
-
- abbreviation Ide
- where "Ide a \<equiv> a \<noteq> Null \<and> Dom a \<in> Obj \<and> Cod a = Dom a \<and> Map a = Id (Dom a)"
-
- definition comp :: "('o, 'a) arr comp"
- where "comp g f \<equiv> if Arr f \<and> Arr g \<and> Dom g = Cod f then
- MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
- else
- Null"
-
- interpretation partial_magma comp
- using comp_def by (unfold_locales, metis)
-
- lemma null_char:
- shows "null = Null"
- proof -
- let ?P = "\<lambda>n. \<forall>f. comp n f = n \<and> comp f n = n"
- have "Null = null"
- using comp_def null_def the1_equality [of ?P] by metis
- thus ?thesis by simp
- qed
-
- lemma ide_char:
- shows "ide f \<longleftrightarrow> Ide f"
- proof
- assume f: "Ide f"
- show "ide f"
- proof (unfold ide_def)
- have "comp f f \<noteq> null"
- using f comp_def null_char Id_in_Hom by auto
- moreover have "\<forall>g. (comp g f \<noteq> null \<longrightarrow> comp g f = g) \<and>
- (comp f g \<noteq> null \<longrightarrow> comp f g = g)"
- proof
- fix g
- have "comp g f \<noteq> null \<longrightarrow> comp g f = g"
- using f comp_def null_char Comp_Hom_Id Id_in_Hom
- by (cases g, auto)
- moreover have "comp f g \<noteq> null \<longrightarrow> comp f g = g"
- using f comp_def null_char Comp_Id_Hom Id_in_Hom
- by (cases g, auto)
- ultimately show "(comp g f \<noteq> null \<longrightarrow> comp g f = g) \<and>
- (comp f g \<noteq> null \<longrightarrow> comp f g = g)"
- by blast
- qed
- ultimately show "comp f f \<noteq> null \<and>
- (\<forall>g. (comp g f \<noteq> null \<longrightarrow> comp g f = g) \<and>
- (comp f g \<noteq> null \<longrightarrow> comp f g = g))"
- by blast
- qed
- next
- assume f: "ide f"
- have 1: "Arr f \<and> Dom f = Cod f"
- using f ide_def comp_def null_char by metis
- moreover have "Map f = Id (Dom f)"
- proof -
- let ?g = "MkIde (Dom f)"
- have g: "Arr f \<and> Arr ?g \<and> Dom ?g = Cod f"
- using 1 Id_in_Hom
- by (intro conjI, simp_all)
- hence 2: "comp ?g f \<noteq> null"
- using 1 comp_def null_char by simp
- have "comp ?g f = MkArr (Dom f) (Dom f) (Map f)"
- using g comp_def Comp_Id_Hom by auto
- moreover have "comp ?g f = ?g"
- using f 2 ide_def by blast
- ultimately show ?thesis by simp
- qed
- ultimately show "Ide f" by auto
- qed
-
- lemma ide_MkIde [simp]:
- assumes "A \<in> Obj"
- shows "ide (MkIde A)"
- using assms ide_char Id_in_Hom by simp
-
- lemma in_domains_char:
- shows "a \<in> domains f \<longleftrightarrow> Arr f \<and> a = MkIde (Dom f)"
- proof
- assume a: "a \<in> domains f"
- have "Ide a"
- using a domains_def ide_char comp_def null_char by auto
- moreover have "Arr f \<and> Dom f = Cod a"
- proof -
- have "comp f a \<noteq> null"
- using a domains_def by simp
- thus ?thesis
- using a domains_def comp_def [of f a] null_char by metis
- qed
- ultimately show "Arr f \<and> a = MkIde (Dom f)"
- by (cases a, auto)
- next
- assume a: "Arr f \<and> a = MkIde (Dom f)"
- show "a \<in> domains f"
- using a Id_in_Hom comp_def null_char domains_def by auto
- qed
-
- lemma in_codomains_char:
- shows "b \<in> codomains f \<longleftrightarrow> Arr f \<and> b = MkIde (Cod f)"
- proof
- assume b: "b \<in> codomains f"
- have "Ide b"
- using b codomains_def ide_char comp_def null_char by auto
- moreover have "Arr f \<and> Dom b = Cod f"
- proof -
- have "comp b f \<noteq> null"
- using b codomains_def by simp
- thus ?thesis
- using b codomains_def comp_def [of b f] null_char by metis
- qed
- ultimately show "Arr f \<and> b = MkIde (Cod f)"
- by (cases b, auto)
- next
- assume b: "Arr f \<and> b = MkIde (Cod f)"
- show "b \<in> codomains f"
- using b Id_in_Hom comp_def null_char codomains_def by auto
- qed
-
- lemma arr_char:
- shows "arr f \<longleftrightarrow> Arr f"
- using arr_def in_domains_char in_codomains_char by auto
-
- lemma arrI:
- assumes "f \<noteq> Null" and "Dom f \<in> Obj" "Cod f \<in> Obj" "Map f \<in> Hom (Dom f) (Cod f)"
- shows "arr f"
- using assms arr_char by blast
-
- lemma arrE:
- assumes "arr f"
- and "\<lbrakk> f \<noteq> Null; Dom f \<in> Obj; Cod f \<in> Obj; Map f \<in> Hom (Dom f) (Cod f) \<rbrakk> \<Longrightarrow> T"
- shows T
- using assms arr_char by simp
-
- lemma arr_MkArr [simp]:
- assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
- shows "arr (MkArr A B f)"
- using assms arr_char by simp
-
- lemma MkArr_Map:
- assumes "arr f"
- shows "MkArr (Dom f) (Cod f) (Map f) = f"
- using assms arr_char by (cases f, auto)
-
- lemma Arr_comp:
- assumes "arr f" and "arr g" and "Dom g = Cod f"
- shows "Arr (comp g f)"
- unfolding comp_def
- using assms arr_char Comp_in_Hom by simp
-
- lemma Dom_comp [simp]:
- assumes "arr f" and "arr g" and "Dom g = Cod f"
- shows "Dom (comp g f) = Dom f"
- unfolding comp_def
- using assms arr_char by simp
-
- lemma Cod_comp [simp]:
- assumes "arr f" and "arr g" and "Dom g = Cod f"
- shows "Cod (comp g f) = Cod g"
- unfolding comp_def
- using assms arr_char by simp
-
- lemma Map_comp [simp]:
- assumes "arr f" and "arr g" and "Dom g = Cod f"
- shows "Map (comp g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
- unfolding comp_def
- using assms arr_char by simp
-
- lemma seq_char:
- shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> Dom g = Cod f"
- using arr_char not_arr_null null_char comp_def Arr_comp by metis
-
- interpretation category comp
- proof
- show "\<And>g f. comp g f \<noteq> null \<Longrightarrow> seq g f"
- using arr_char comp_def null_char Comp_in_Hom by auto
- show 1: "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
- using in_domains_char in_codomains_char by auto
- show "\<And>f g h. seq h g \<Longrightarrow> seq (comp h g) f \<Longrightarrow> seq g f"
- by (auto simp add: seq_char)
- show "\<And>f g h. seq h (comp g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
- using seq_char comp_def Comp_in_Hom by (metis Cod_comp)
- show "\<And>f g h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (comp h g) f"
- using Comp_in_Hom
- by (auto simp add: comp_def seq_char)
- show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
- using seq_char comp_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
- by auto
- qed
-
- proposition is_category:
- shows "category comp"
- ..
-
- lemma dom_char:
- shows "dom f = (if arr f then MkIde (Dom f) else null)"
- using dom_def in_domains_char dom_in_domains has_domain_iff_arr by auto
-
- lemma cod_char:
- shows "cod f = (if arr f then MkIde (Cod f) else null)"
- using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto
-
- lemma comp_char:
- shows "comp g f = (if seq g f then
- MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
- else
- null)"
- using comp_def seq_char arr_char null_char by auto
-
- lemma in_hom_char:
- shows "in_hom f a b \<longleftrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
- proof
- show "in_hom f a b \<Longrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
- using arr_char dom_char cod_char by auto
- show "arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b \<Longrightarrow> in_hom f a b"
- using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
- qed
-
- lemma Dom_in_Obj:
- assumes "arr f"
- shows "Dom f \<in> Obj"
- using assms arr_char by simp
-
- lemma Cod_in_Obj:
- assumes "arr f"
- shows "Cod f \<in> Obj"
- using assms arr_char by simp
-
- lemma Map_in_Hom:
- assumes "arr f"
- shows "Map f \<in> Hom (Dom f) (Cod f)"
- using assms arr_char by simp
-
- lemma MkArr_in_hom:
- assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
- shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
- using assms arr_char dom_char cod_char ide_MkIde by auto
-
- lemma Dom_dom [simp]:
- assumes "arr f"
- shows "Dom (dom f) = Dom f"
- using assms MkArr_Map dom_char by simp
-
- lemma Cod_dom [simp]:
- assumes "arr f"
- shows "Cod (dom f) = Dom f"
- using assms MkArr_Map dom_char by simp
-
- lemma Dom_cod [simp]:
- assumes "arr f"
- shows "Dom (cod f) = Cod f"
- using assms MkArr_Map cod_char by simp
-
- lemma Cod_cod [simp]:
- assumes "arr f"
- shows "Cod (cod f) = Cod f"
- using assms MkArr_Map cod_char by simp
-
- lemma Map_dom [simp]:
- assumes "arr f"
- shows "Map (dom f) = Id (Dom f)"
- using assms MkArr_Map dom_char by simp
-
- lemma Map_cod [simp]:
- assumes "arr f"
- shows "Map (cod f) = Id (Cod f)"
- using assms MkArr_Map cod_char by simp
-
- lemma Map_ide:
- assumes "ide a"
- shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
- proof -
- show "Map a = Id (Dom a)"
- using assms ide_char dom_char [of a] Map_dom ideD(1) by metis
- show "Map a = Id (Cod a)"
- using assms ide_char dom_char [of a] Map_cod ideD(1) by metis
- qed
-
- (*
- * TODO: The next two ought to be simps, but they cause looping when they find themselves
- * in combination with dom_char and cod_char.
- *)
- lemma MkIde_Dom:
- assumes "arr a"
- shows "MkIde (Dom a) = dom a"
- using assms arr_char dom_char by (cases a, auto)
-
- lemma MkIde_Cod:
- assumes "arr a"
- shows "MkIde (Cod a) = cod a"
- using assms arr_char cod_char by (cases a, auto)
-
- lemma MkIde_Dom' [simp]:
- assumes "ide a"
- shows "MkIde (Dom a) = a"
- using assms MkIde_Dom by simp
-
- lemma MkIde_Cod' [simp]:
- assumes "ide a"
- shows "MkIde (Cod a) = a"
- using assms MkIde_Cod by simp
-
- lemma dom_MkArr [simp]:
- assumes "arr (MkArr A B F)"
- shows "dom (MkArr A B F) = MkIde A"
- using assms dom_char by simp
-
- lemma cod_MkArr [simp]:
- assumes "arr (MkArr A B F)"
- shows "cod (MkArr A B F) = MkIde B"
- using assms cod_char by simp
-
- lemma comp_MkArr [simp]:
- assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
- shows "comp (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
- using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp
-
- proposition bij_betw_ide_Obj:
- shows "MkIde \<in> Obj \<rightarrow> Collect ide"
- and "Dom \<in> Collect ide \<rightarrow> Obj"
- and "A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
- and "a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
- and "bij_betw Dom (Collect ide) Obj"
- proof -
- show 1: "MkIde \<in> Obj \<rightarrow> Collect ide"
- using ide_MkIde by simp
- show 2: "Dom \<in> Collect ide \<rightarrow> Obj"
- using arr_char ideD(1) by simp
- show 3: "\<And>A. A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
- by simp
- show 4: "\<And>a. a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
- using MkIde_Dom by simp
- show "bij_betw Dom (Collect ide) Obj"
- using 1 2 3 4 bij_betwI by blast
- qed
-
- proposition bij_betw_hom_Hom:
- assumes "ide a" and "ide b"
- shows "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
- and "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
- and "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
- and "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
- and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
- proof -
- show 1: "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
- using Map_in_Hom cod_char dom_char in_hom_char by fastforce
- show 2: "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
- using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
- show 3: "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
- using MkArr_Map by auto
- show 4: "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
- by simp
- show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
- using 1 2 3 4 bij_betwI by blast
- qed
-
- lemma arr_eqI:
- assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
- shows "t = t'"
- using assms MkArr_Map by metis
-
- end
-
- sublocale concrete_category \<subseteq> category comp
- using is_category by auto
-
-end
diff --git a/thys/Bicategory/InternalAdjunction.thy b/thys/Bicategory/InternalAdjunction.thy
--- a/thys/Bicategory/InternalAdjunction.thy
+++ b/thys/Bicategory/InternalAdjunction.thy
@@ -1,3466 +1,3454 @@
(* Title: InternalAdjunction
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Adjunctions in a Bicategory"
theory InternalAdjunction
imports CanonicalIsos Strictness
begin
text \<open>
An \emph{internal adjunction} in a bicategory is a four-tuple \<open>(f, g, \<eta>, \<epsilon>)\<close>,
where \<open>f\<close> and \<open>g\<close> are antiparallel 1-cells and \<open>\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>\<close> and
\<open>\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>\<close> are 2-cells, such that the familiar ``triangle''
(or ``zig-zag'') identities are satisfied. We state the triangle identities
in two equivalent forms, each of which is convenient in certain situations.
\<close>
locale adjunction_in_bicategory =
adjunction_data_in_bicategory +
assumes triangle_left: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
and triangle_right: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
begin
lemma triangle_left':
shows "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
using triangle_left triangle_equiv_form by simp
lemma triangle_right':
shows "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
using triangle_right triangle_equiv_form by simp
end
text \<open>
Internal adjunctions have a number of properties, which we now develop,
that generalize those of ordinary adjunctions involving functors and
natural transformations.
\<close>
context bicategory
begin
lemma adjunction_unit_determines_counit:
assumes "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>"
and "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>'"
shows "\<epsilon> = \<epsilon>'"
proof -
interpret E: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using assms(1) by auto
interpret E': adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
using assms(2) by auto
text \<open>
Note that since we want to prove the the result for an arbitrary bicategory,
not just in for a strict bicategory, the calculation is a little more involved
than one might expect from a treatment that suppresses canonical isomorphisms.
\<close>
have "\<epsilon> \<cdot> \<r>[f \<star> g] = \<r>[trg f] \<cdot> (\<epsilon> \<star> trg f)"
using runit_naturality [of \<epsilon>] by simp
have 1: "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
using E.antipar runit_hcomp by simp
have "\<epsilon> = \<epsilon> \<cdot> (f \<star> \<r>[g] \<cdot> (g \<star> \<epsilon>') \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g])"
using E'.triangle_right' comp_arr_dom by simp
also have "... = \<epsilon> \<cdot> (f \<star> \<r>[g]) \<cdot> (f \<star> g \<star> \<epsilon>') \<cdot> (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar whisker_left hseqI' by simp
also have "... = \<epsilon> \<cdot> ((f \<star> \<r>[g]) \<cdot> (f \<star> g \<star> \<epsilon>')) \<cdot> (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using comp_assoc by simp
also have "... = \<epsilon> \<cdot> \<r>[f \<star> g] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> g \<star> \<epsilon>')) \<cdot>
(f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
proof -
have "f \<star> \<r>[g] = \<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g]"
using E.antipar(1) runit_hcomp(3) by auto
thus ?thesis
using comp_assoc by simp
qed
also have "... = (\<epsilon> \<cdot> \<r>[f \<star> g]) \<cdot> ((f \<star> g) \<star> \<epsilon>') \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
(f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar E'.counit_in_hom assoc'_naturality [of f g \<epsilon>'] comp_assoc by simp
also have "... = \<r>[trg f] \<cdot> ((\<epsilon> \<star> trg f) \<cdot> ((f \<star> g) \<star> \<epsilon>')) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
(f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar E.counit_in_hom runit_naturality [of \<epsilon>] comp_assoc by simp
also have "... = (\<l>[src g] \<cdot> (src g \<star> \<epsilon>')) \<cdot> (\<epsilon> \<star> f \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
(f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
proof -
have "(\<epsilon> \<star> trg f) \<cdot> ((f \<star> g) \<star> \<epsilon>') = (src g \<star> \<epsilon>') \<cdot> (\<epsilon> \<star> f \<star> g)"
using E.antipar interchange E.counit_in_hom comp_arr_dom comp_cod_arr
by (metis E'.counit_simps(1-3) E.counit_simps(1-3))
thus ?thesis
using E.antipar comp_assoc unitor_coincidence by simp
qed
also have "... = \<epsilon>' \<cdot> \<l>[f \<star> g] \<cdot> (\<epsilon> \<star> f \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
(f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
proof -
have "\<l>[src g] \<cdot> (src g \<star> \<epsilon>') = \<epsilon>' \<cdot> \<l>[f \<star> g]"
using E.antipar lunit_naturality [of \<epsilon>'] by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> (\<epsilon> \<star> f \<star> g)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
(f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar lunit_hcomp comp_assoc by simp
also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f \<star> g, f, g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
(f \<star> \<a>[g, f, g])) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar assoc'_naturality [of \<epsilon> f g] comp_assoc by simp
also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g \<star> f, g] \<cdot> (f \<star> \<eta> \<star> g)) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
proof -
have "\<a>\<^sup>-\<^sup>1[f \<star> g, f, g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot> (f \<star> \<a>[g, f, g]) =
(\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, g]"
using 1 E.antipar iso_assoc' iso_inv_iso pentagon' comp_assoc
invert_side_of_triangle(2)
[of "\<a>\<^sup>-\<^sup>1[f \<star> g, f, g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g]"
"(\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, g]" "f \<star> \<a>\<^sup>-\<^sup>1[g, f, g]"]
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot>
((f \<star> \<eta>) \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg g, g] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar assoc'_naturality [of f \<eta> g] comp_assoc by simp
also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot>
((f \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[f] \<star> g)"
proof -
have "\<a>\<^sup>-\<^sup>1[f, trg g, g] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g]) = \<r>\<^sup>-\<^sup>1[f] \<star> g"
proof -
have "\<r>\<^sup>-\<^sup>1[f] \<star> g = inv (\<r>[f] \<star> g)"
using E.antipar by simp
also have "... = inv ((f \<star> \<l>[g]) \<cdot> \<a>[f, trg g, g])"
using E.antipar by (simp add: triangle)
also have "... = \<a>\<^sup>-\<^sup>1[f, trg g, g] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
using E.antipar hseqI' inv_comp by simp
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = \<epsilon>' \<cdot> (\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] \<star> g)"
using E.antipar whisker_right hseqI' by simp
also have "... = \<epsilon>'"
using E.triangle_left' comp_arr_dom by simp
finally show ?thesis by simp
qed
end
subsection "Adjoint Transpose"
context adjunction_in_bicategory
begin
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
text \<open>
Just as for an ordinary adjunction between categories, an adjunction in a bicategory
determines bijections between hom-sets. There are two versions of this relationship:
depending on whether the transposition is occurring on the left (\emph{i.e.}~``output'')
side or the right (\emph{i.e.}~``input'') side.
\<close>
definition trnl\<^sub>\<eta>
where "trnl\<^sub>\<eta> v \<mu> \<equiv> (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
definition trnl\<^sub>\<epsilon>
where "trnl\<^sub>\<epsilon> u \<nu> \<equiv> \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)"
lemma adjoint_transpose_left:
assumes "ide u" and "ide v" and "src f = trg v" and "src g = trg u"
shows "trnl\<^sub>\<eta> v \<in> hom (f \<star> v) u \<rightarrow> hom v (g \<star> u)"
and "trnl\<^sub>\<epsilon> u \<in> hom v (g \<star> u) \<rightarrow> hom (f \<star> v) u"
and "\<guillemotleft>\<mu> : f \<star> v \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) = \<mu>"
and "\<guillemotleft>\<nu> : v \<Rightarrow> g \<star> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) = \<nu>"
and "bij_betw (trnl\<^sub>\<eta> v) (hom (f \<star> v) u) (hom v (g \<star> u))"
and "bij_betw (trnl\<^sub>\<epsilon> u) (hom v (g \<star> u)) (hom (f \<star> v) u)"
proof -
show A: "trnl\<^sub>\<eta> v \<in> hom (f \<star> v) u \<rightarrow> hom v (g \<star> u)"
using assms antipar trnl\<^sub>\<eta>_def by fastforce
show B: "trnl\<^sub>\<epsilon> u \<in> hom v (g \<star> u) \<rightarrow> hom (f \<star> v) u"
using assms antipar trnl\<^sub>\<epsilon>_def by fastforce
show C: "\<And>\<mu>. \<guillemotleft>\<mu> : f \<star> v \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) = \<mu>"
proof -
fix \<mu>
assume \<mu>: "\<guillemotleft>\<mu> : f \<star> v \<Rightarrow> u\<guillemotright>"
have "trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) =
\<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v])"
using trnl\<^sub>\<eta>_def trnl\<^sub>\<epsilon>_def by simp
also have "... = \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> g \<star> \<mu>)) \<cdot> (f \<star> \<a>[g, f, v]) \<cdot>
(f \<star> \<eta> \<star> v) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
using assms \<mu> antipar whisker_left comp_assoc hseqI' by auto
also have "... = \<l>[u] \<cdot> ((\<epsilon> \<star> u) \<cdot> ((f \<star> g) \<star> \<mu>)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot>
(f \<star> \<eta> \<star> v) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
using assms \<mu> antipar assoc'_naturality [of f g \<mu>] comp_assoc by fastforce
also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot>
(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot>
(f \<star> \<eta> \<star> v) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
proof -
have "(\<epsilon> \<star> u) \<cdot> ((f \<star> g) \<star> \<mu>) = (trg u \<star> \<mu>) \<cdot> (\<epsilon> \<star> f \<star> v)"
using assms \<mu> antipar comp_cod_arr comp_arr_dom
interchange [of "trg u" \<epsilon> \<mu> "f \<star> v"] interchange [of \<epsilon> "f \<star> g" u \<mu>]
by auto
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot> \<a>[trg f, f, v] \<cdot>
((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<star> v) \<cdot>
\<a>\<^sup>-\<^sup>1[f, trg v, v] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
proof -
have 1: "(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot> (f \<star> \<eta> \<star> v) =
\<a>[trg f, f, v] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg v, v]"
proof -
have "(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot> (f \<star> \<eta> \<star> v) =
(\<epsilon> \<star> f \<star> v) \<cdot>
\<a>[f \<star> g, f, v] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, v] \<cdot>
(f \<star> \<eta> \<star> v)"
proof -
have "(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot> (f \<star> \<eta> \<star> v) =
(\<epsilon> \<star> f \<star> v) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v])) \<cdot> (f \<star> \<eta> \<star> v)"
using comp_assoc by simp
also have "... = (\<epsilon> \<star> f \<star> v) \<cdot>
\<a>[f \<star> g, f, v] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, v] \<cdot>
(f \<star> \<eta> \<star> v)"
proof -
have "\<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) =
\<a>[f \<star> g, f, v] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, v]"
using assms antipar canI_associator_0 whisker_can_left_0 whisker_can_right_0
canI_associator_hcomp(1-3)
by simp
thus ?thesis
using comp_assoc by simp
qed
finally show ?thesis by blast
qed
also have "... = ((\<epsilon> \<star> f \<star> v) \<cdot> \<a>[f \<star> g, f, v]) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> ((f \<star> \<eta>) \<star> v) \<cdot>
\<a>\<^sup>-\<^sup>1[f, trg v, v]"
using assms \<mu> antipar assoc'_naturality [of f \<eta> v] comp_assoc by simp
also have "... = (\<a>[trg f, f, v] \<cdot> ((\<epsilon> \<star> f) \<star> v)) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> ((f \<star> \<eta>) \<star> v) \<cdot>
\<a>\<^sup>-\<^sup>1[f, trg v, v]"
using assms \<mu> antipar assoc_naturality [of \<epsilon> f v] by simp
also have "... = \<a>[trg f, f, v] \<cdot>
(((\<epsilon> \<star> f) \<star> v) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> ((f \<star> \<eta>) \<star> v)) \<cdot>
\<a>\<^sup>-\<^sup>1[f, trg v, v]"
using comp_assoc by simp
also have "... = \<a>[trg f, f, v] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg v, v]"
using assms \<mu> antipar whisker_right hseqI' by simp
finally show ?thesis by simp
qed
show ?thesis
using 1 comp_assoc by metis
qed
also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot>
\<a>[trg f, f, v] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg v, v] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
using assms \<mu> antipar triangle_left by simp
also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot> can (\<^bold>\<langle>trg u\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>v\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>v\<^bold>\<rangle>)"
using assms \<mu> antipar canI_unitor_0 canI_associator_1
canI_associator_1(1-2) [of f v] whisker_can_right_0 whisker_can_left_0
by simp
also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> v]"
unfolding can_def using assms antipar comp_arr_dom comp_cod_arr \<ll>_ide_simp
by simp
also have "... = (\<l>[u] \<cdot> \<l>\<^sup>-\<^sup>1[u]) \<cdot> \<mu>"
using assms \<mu> lunit'_naturality [of \<mu>] comp_assoc by auto
also have "... = \<mu>"
using assms \<mu> comp_cod_arr iso_lunit comp_arr_inv inv_is_inverse by auto
finally show "trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) = \<mu>" by simp
qed
show D: "\<And>\<nu>. \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) = \<nu>"
proof -
fix \<nu>
assume \<nu>: "\<guillemotleft>\<nu> : v \<Rightarrow> g \<star> u\<guillemotright>"
have "trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) =
(g \<star> \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
using trnl\<^sub>\<eta>_def trnl\<^sub>\<epsilon>_def by simp
also have "... = (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> (g \<star> f \<star> \<nu>) \<cdot>
\<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
using assms \<nu> antipar interchange [of g "g \<cdot> g \<cdot> g"] comp_assoc hseqI' by auto
also have "... = ((g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot>
\<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u)) \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
proof -
have "(g \<star> f \<star> \<nu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v] =
\<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
proof -
have "(g \<star> f \<star> \<nu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v] =
\<a>[g, f, g \<star> u] \<cdot> ((g \<star> f) \<star> \<nu>) \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
proof -
have "(g \<star> f \<star> \<nu>) \<cdot> \<a>[g, f, v] = \<a>[g, f, g \<star> u] \<cdot> ((g \<star> f) \<star> \<nu>)"
using assms \<nu> antipar assoc_naturality [of g f \<nu>] by auto
thus ?thesis
using assms comp_assoc by metis
qed
also have "... = \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
proof -
have "((g \<star> f) \<star> \<nu>) \<cdot> (\<eta> \<star> v) = (\<eta> \<star> g \<star> u) \<cdot> (trg v \<star> \<nu>)"
using assms \<nu> antipar comp_arr_dom comp_cod_arr
interchange [of "g \<star> f" \<eta> \<nu> v] interchange [of \<eta> "trg v" "g \<star> u" \<nu>]
by auto
thus ?thesis
using comp_assoc by metis
qed
finally show ?thesis by blast
qed
thus ?thesis using comp_assoc by simp
qed
also have "... = \<l>[g \<star> u] \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
proof -
have "(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) =
\<l>[g \<star> u]"
proof -
have "(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) =
(g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot>
((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<star> u) \<cdot>
\<a>\<^sup>-\<^sup>1[trg v, g, u]"
proof -
have "(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) =
(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot>
((\<eta> \<star> g \<star> u) \<cdot> \<a>[trg v, g, u]) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
using assms antipar comp_arr_dom comp_assoc hseqI' comp_assoc_assoc'(1) by simp
also have "... = (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot>
(\<a>[g \<star> f, g, u] \<cdot> ((\<eta> \<star> g) \<star> u)) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
using assms antipar assoc_naturality [of \<eta> g u] by simp
also have "... = (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot>
((g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
((\<eta> \<star> g) \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
using comp_assoc by simp
also have "... = (g \<star> \<l>[u]) \<cdot> ((\<a>[g, trg u, u] \<cdot> \<a>\<^sup>-\<^sup>1[g, trg u, u]) \<cdot> (g \<star> \<epsilon> \<star> u)) \<cdot>
((g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
((\<eta> \<star> g) \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
proof -
have "(\<a>[g, trg u, u] \<cdot> \<a>\<^sup>-\<^sup>1[g, trg u, u]) \<cdot> (g \<star> \<epsilon> \<star> u) = g \<star> \<epsilon> \<star> u"
using assms antipar comp_cod_arr hseqI' comp_assoc_assoc'(1) by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<a>\<^sup>-\<^sup>1[g, trg u, u] \<cdot> (g \<star> \<epsilon> \<star> u)) \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u] \<cdot>
((\<eta> \<star> g) \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
using comp_assoc by simp
also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (((g \<star> \<epsilon>) \<star> u) \<cdot> (\<a>\<^sup>-\<^sup>1[g, f \<star> g, u] \<cdot>
(g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
((\<eta> \<star> g) \<star> u)) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
using assms antipar assoc'_naturality [of g \<epsilon> u] comp_assoc by simp
also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot>
((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<star> u) \<cdot>
\<a>\<^sup>-\<^sup>1[trg v, g, u]"
proof -
have "\<a>\<^sup>-\<^sup>1[g, f \<star> g, u] \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u] =
\<a>[g, f, g] \<star> u"
using assms antipar canI_associator_0 whisker_can_left_0 whisker_can_right_0
canI_associator_hcomp
by simp
hence "((g \<star> \<epsilon>) \<star> u) \<cdot>
(\<a>\<^sup>-\<^sup>1[g, f \<star> g, u] \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
((\<eta> \<star> g) \<star> u) =
(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<star> u"
using assms antipar whisker_right hseqI' by simp
thus ?thesis by simp
qed
finally show ?thesis by blast
qed
also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg g, g, u]"
using assms antipar triangle_right by simp
also have "... = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>) (\<^bold>\<langle>trg g\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>)"
proof -
have "(g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg g, g, u] =
((g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg g, g, u])"
using comp_assoc by simp
moreover have "... = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>) (\<^bold>\<langle>trg g\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>)"
using assms antipar canI_unitor_0 canI_associator_1 [of g u] inv_can
whisker_can_left_0 whisker_can_right_0
by simp
ultimately show ?thesis by simp
qed
also have "... = \<l>[g \<star> u]"
unfolding can_def using assms comp_arr_dom comp_cod_arr \<ll>_ide_simp by simp
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = (\<l>[g \<star> u] \<cdot> \<l>\<^sup>-\<^sup>1[g \<star> u]) \<cdot> \<nu>"
using assms \<nu> lunit'_naturality comp_assoc by auto
also have "... = \<nu>"
using assms \<nu> comp_cod_arr iso_lunit comp_arr_inv inv_is_inverse by auto
finally show "trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) = \<nu>" by simp
qed
show "bij_betw (trnl\<^sub>\<eta> v) (hom (f \<star> v) u) (hom v (g \<star> u))"
using A B C D by (intro bij_betwI, auto)
show "bij_betw (trnl\<^sub>\<epsilon> u) (hom v (g \<star> u)) (hom (f \<star> v) u)"
using A B C D by (intro bij_betwI, auto)
qed
lemma trnl\<^sub>\<epsilon>_comp:
assumes "ide u" and "seq \<mu> \<nu>" and "src f = trg \<mu>"
shows "trnl\<^sub>\<epsilon> u (\<mu> \<cdot> \<nu>) = trnl\<^sub>\<epsilon> u \<mu> \<cdot> (f \<star> \<nu>)"
using assms trnl\<^sub>\<epsilon>_def whisker_left [of f \<mu> \<nu>] comp_assoc by auto
definition trnr\<^sub>\<eta>
where "trnr\<^sub>\<eta> v \<mu> \<equiv> (\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
definition trnr\<^sub>\<epsilon>
where "trnr\<^sub>\<epsilon> u \<nu> \<equiv> \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g)"
lemma adjoint_transpose_right:
assumes "ide u" and "ide v" and "src v = trg g" and "src u = trg f"
shows "trnr\<^sub>\<eta> v \<in> hom (v \<star> g) u \<rightarrow> hom v (u \<star> f)"
and "trnr\<^sub>\<epsilon> u \<in> hom v (u \<star> f) \<rightarrow> hom (v \<star> g) u"
and "\<guillemotleft>\<mu> : v \<star> g \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) = \<mu>"
and "\<guillemotleft>\<nu> : v \<Rightarrow> u \<star> f\<guillemotright> \<Longrightarrow> trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) = \<nu>"
and "bij_betw (trnr\<^sub>\<eta> v) (hom (v \<star> g) u) (hom v (u \<star> f))"
and "bij_betw (trnr\<^sub>\<epsilon> u) (hom v (u \<star> f)) (hom (v \<star> g) u)"
proof -
show A: "trnr\<^sub>\<eta> v \<in> hom (v \<star> g) u \<rightarrow> hom v (u \<star> f)"
using assms antipar trnr\<^sub>\<eta>_def by fastforce
show B: "trnr\<^sub>\<epsilon> u \<in> hom v (u \<star> f) \<rightarrow> hom (v \<star> g) u"
using assms antipar trnr\<^sub>\<epsilon>_def by fastforce
show C: "\<And>\<mu>. \<guillemotleft>\<mu> : v \<star> g \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) = \<mu>"
proof -
fix \<mu>
assume \<mu>: "\<guillemotleft>\<mu> : v \<star> g \<Rightarrow> u\<guillemotright>"
have "trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) =
\<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> ((\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v] \<star> g)"
unfolding trnr\<^sub>\<epsilon>_def trnr\<^sub>\<eta>_def by simp
also have "... = \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> (\<a>[u, f, g] \<cdot> ((\<mu> \<star> f) \<star> g)) \<cdot>
(\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
using assms \<mu> antipar whisker_right comp_assoc hseqI' by auto
also have "... = \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> ((\<mu> \<star> f \<star> g) \<cdot> \<a>[v \<star> g, f, g]) \<cdot>
(\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
using assms \<mu> antipar assoc_naturality [of \<mu> f g] by auto
also have "... = \<r>[u] \<cdot> ((u \<star> \<epsilon>) \<cdot> (\<mu> \<star> f \<star> g)) \<cdot> \<a>[v \<star> g, f, g] \<cdot>
(\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
using comp_assoc by auto
also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot> ((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot>
(\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
proof -
have "(u \<star> \<epsilon>) \<cdot> (\<mu> \<star> f \<star> g) = (\<mu> \<star> src u) \<cdot> ((v \<star> g) \<star> \<epsilon>)"
using assms \<mu> antipar comp_arr_dom comp_cod_arr
interchange [of \<mu> "v \<star> g" "src u" \<epsilon>] interchange [of u \<mu> \<epsilon> "f \<star> g"]
by auto
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot>
(((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g)) \<cdot>
(\<r>\<^sup>-\<^sup>1[v] \<star> g)"
using comp_assoc by simp
also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot>
(\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot>
\<a>[v, src v, g]) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
proof -
have "((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) =
\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> \<a>[v, src v, g]"
proof -
have "((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) =
((\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> \<a>[v, g, src u]) \<cdot> ((v \<star> g) \<star> \<epsilon>)) \<cdot>
\<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g)"
using assms antipar comp_cod_arr hseqI' comp_assoc_assoc'(2) by simp
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (\<a>[v, g, src u] \<cdot> ((v \<star> g) \<star> \<epsilon>)) \<cdot>
\<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g)"
using comp_assoc by simp
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> ((v \<star> g \<star> \<epsilon>) \<cdot> \<a>[v, g, f \<star> g]) \<cdot>
\<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot>
(\<a>\<^sup>-\<^sup>1[v, g \<star> f, g] \<cdot> \<a>[v, g \<star> f, g]) \<cdot> ((v \<star> \<eta>) \<star> g)"
proof -
have "\<a>[v, g, src u] \<cdot> ((v \<star> g) \<star> \<epsilon>) = (v \<star> g \<star> \<epsilon>) \<cdot> \<a>[v, g, f \<star> g]"
using assms antipar assoc_naturality [of v g \<epsilon>] by simp
moreover have "(\<a>\<^sup>-\<^sup>1[v, g \<star> f, g] \<cdot> \<a>[v, g \<star> f, g]) \<cdot> ((v \<star> \<eta>) \<star> g) = (v \<star> \<eta>) \<star> g"
using assms antipar comp_cod_arr hseqI' comp_assoc_assoc'(2) by simp
ultimately show ?thesis by simp
qed
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> g \<star> \<epsilon>) \<cdot>
\<a>[v, g, f \<star> g] \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot>
\<a>\<^sup>-\<^sup>1[v, g \<star> f, g] \<cdot> \<a>[v, g \<star> f, g] \<cdot> ((v \<star> \<eta>) \<star> g)"
using comp_assoc by simp
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> ((v \<star> g \<star> \<epsilon>) \<cdot>
(\<a>[v, g, f \<star> g] \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot>
\<a>\<^sup>-\<^sup>1[v, g \<star> f, g]) \<cdot> (v \<star> \<eta> \<star> g)) \<cdot> \<a>[v, src v, g]"
using assms antipar assoc_naturality [of v \<eta> g] comp_assoc by simp
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot>
((v \<star> g \<star> \<epsilon>) \<cdot> (v \<star> \<a>[g, f, g]) \<cdot> (v \<star> \<eta> \<star> g)) \<cdot>
\<a>[v, src v, g]"
proof -
have "\<a>[v, g, f \<star> g] \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[v, g \<star> f, g] =
v \<star> \<a>[g, f, g]"
using assms antipar canI_associator_0 canI_associator_hcomp
whisker_can_left_0 whisker_can_right_0
by simp
thus ?thesis
using assms antipar whisker_left by simp
qed
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot>
(v \<star> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot>
\<a>[v, src v, g]"
using assms antipar whisker_left hseqI' by simp
finally show ?thesis by simp
qed
thus ?thesis by auto
qed
also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot>
\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot>
\<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
using triangle_right comp_assoc by simp
also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot> \<r>\<^sup>-\<^sup>1[v \<star> g]"
proof -
have "\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g) = \<r>\<^sup>-\<^sup>1[v \<star> g]"
proof -
have "\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g) =
\<a>\<^sup>-\<^sup>1[v, g, trg f] \<cdot> can (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
using assms canI_unitor_0 canI_associator_1(2-3) whisker_can_left_0(1)
whisker_can_right_0
by simp
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src g] \<cdot> can (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
using antipar by simp
(* TODO: There should be an alternate version of whisker_can_left for this. *)
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src g] \<cdot> (v \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>g\<^bold>\<rangle>)"
using assms canI_unitor_0(2) whisker_can_left_0 by simp
also have "... = \<a>\<^sup>-\<^sup>1[v, g, src g] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g])"
using assms canI_unitor_0(2) by simp
also have "... = \<r>\<^sup>-\<^sup>1[v \<star> g]"
using assms runit_hcomp(2) by simp
finally have "\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g) =
\<r>\<^sup>-\<^sup>1[v \<star> g]"
by simp
thus ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = (\<r>[u] \<cdot> \<r>\<^sup>-\<^sup>1[u]) \<cdot> \<mu>"
using assms \<mu> runit'_naturality [of \<mu>] comp_assoc by auto
also have "... = \<mu>"
using \<mu> comp_cod_arr iso_runit inv_is_inverse comp_arr_inv by auto
finally show "trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) = \<mu>" by simp
qed
show D: "\<And>\<nu>. \<guillemotleft>\<nu> : v \<Rightarrow> u \<star> f\<guillemotright> \<Longrightarrow> trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) = \<nu>"
proof -
fix \<nu>
assume \<nu>: "\<guillemotleft>\<nu> : v \<Rightarrow> u \<star> f\<guillemotright>"
have "trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) =
(\<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
unfolding trnr\<^sub>\<eta>_def trnr\<^sub>\<epsilon>_def by simp
also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
(((\<nu> \<star> g) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f]) \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using assms \<nu> antipar whisker_right [of f] comp_assoc hseqI' by auto
also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
(\<a>\<^sup>-\<^sup>1[u \<star> f, g, f] \<cdot> (\<nu> \<star> g \<star> f)) \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using assms \<nu> antipar assoc'_naturality [of \<nu> g f] by auto
also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[u \<star> f, g, f] \<cdot> ((\<nu> \<star> g \<star> f) \<cdot> (v \<star> \<eta>)) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using comp_assoc by simp
also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[u \<star> f, g, f] \<cdot> (((u \<star> f) \<star> \<eta>) \<cdot> (\<nu> \<star> src v)) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
proof -
have "(\<nu> \<star> g \<star> f) \<cdot> (v \<star> \<eta>) = ((u \<star> f) \<star> \<eta>) \<cdot> (\<nu> \<star> src v)"
using assms \<nu> antipar interchange [of "u \<star> f" \<nu> \<eta> "src v"]
interchange [of \<nu> v "g \<star> f" \<eta>] comp_arr_dom comp_cod_arr
by auto
thus ?thesis by simp
qed
also have "... = ((\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot>
((\<a>[u, f, g] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u \<star> f, g, f]) \<cdot>
((u \<star> f) \<star> \<eta>)) \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using comp_assoc by simp
also have "... = ((\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot>
(\<a>\<^sup>-\<^sup>1[u, f \<star> g, f] \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> \<a>[u, f, g \<star> f]) \<cdot>
((u \<star> f) \<star> \<eta>)) \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using assms antipar canI_associator_hcomp canI_associator_0 whisker_can_left_0
whisker_can_right_0
by simp
also have "... = ((\<r>[u] \<star> f) \<cdot> (((u \<star> \<epsilon>) \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[u, f \<star> g, f]) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> (\<a>[u, f, g \<star> f]) \<cdot>
((u \<star> f) \<star> \<eta>)) \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using comp_assoc by simp
also have "... = ((\<r>[u] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot> (u \<star> \<epsilon> \<star> f)) \<cdot>
(u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> ((u \<star> f \<star> \<eta>) \<cdot> \<a>[u, f, src f])) \<cdot>
(\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using assms antipar assoc'_naturality [of u \<epsilon> f] assoc_naturality [of u f \<eta>]
by auto
also have "... = (\<r>[u] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot>
((u \<star> \<epsilon> \<star> f) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> (u \<star> f \<star> \<eta>)) \<cdot> \<a>[u, f, src f] \<cdot>
(\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using comp_assoc by simp
also have "... = (\<r>[u] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot>
(u \<star> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<a>[u, f, src f] \<cdot>
(\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using assms antipar whisker_left hseqI' by auto
also have "... = ((\<r>[u] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot> (u \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<a>[u, f, src f])) \<cdot>
(\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
using assms antipar triangle_left comp_assoc by simp
also have "... = \<r>[u \<star> f] \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
proof -
have "(\<r>[u] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot> (u \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<a>[u, f, src f] =
((u \<star> \<l>[f]) \<cdot> (\<a>[u, src u, f] \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f])) \<cdot>
(u \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<a>[u, f, src f]"
using assms ide_left ide_right antipar triangle comp_assoc by metis
also have "... = (u \<star> \<r>[f]) \<cdot> \<a>[u, f, src f]"
using assms antipar canI_associator_1 canI_unitor_0 whisker_can_left_0
whisker_can_right_0 canI_associator_1
by simp
also have "... = \<r>[u \<star> f]"
using assms antipar runit_hcomp by simp
finally show ?thesis by simp
qed
also have "... = (\<r>[u \<star> f] \<cdot> \<r>\<^sup>-\<^sup>1[u \<star> f]) \<cdot> \<nu>"
using assms \<nu> runit'_naturality [of \<nu>] comp_assoc by auto
also have "... = \<nu>"
using assms \<nu> comp_cod_arr comp_arr_inv inv_is_inverse iso_runit by auto
finally show "trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) = \<nu>" by auto
qed
show "bij_betw (trnr\<^sub>\<eta> v) (hom (v \<star> g) u) (hom v (u \<star> f))"
using A B C D by (intro bij_betwI, auto)
show "bij_betw (trnr\<^sub>\<epsilon> u) (hom v (u \<star> f)) (hom (v \<star> g) u)"
using A B C D by (intro bij_betwI, auto)
qed
lemma trnr\<^sub>\<eta>_comp:
assumes "ide v" and "seq \<mu> \<nu>" and "src \<mu> = trg f"
shows "trnr\<^sub>\<eta> v (\<mu> \<cdot> \<nu>) = (\<mu> \<star> f) \<cdot> trnr\<^sub>\<eta> v \<nu>"
using assms trnr\<^sub>\<eta>_def whisker_right comp_assoc by auto
end
text \<open>
It is useful to have at hand the simpler versions of the preceding results that
hold in a normal bicategory and in a strict bicategory.
\<close>
locale adjunction_in_normal_bicategory =
normal_bicategory +
adjunction_in_bicategory
begin
lemma triangle_left:
shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = f"
using triangle_left strict_lunit strict_runit by simp
lemma triangle_right:
shows "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = g"
using triangle_right strict_lunit strict_runit by simp
lemma trnr\<^sub>\<eta>_eq:
assumes "ide u" and "ide v"
and "src v = trg g" and "src u = trg f"
and "\<mu> \<in> hom (v \<star> g) u"
shows "trnr\<^sub>\<eta> v \<mu> = (\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>)"
unfolding trnr\<^sub>\<eta>_def
using assms antipar strict_runit' comp_arr_ide [of "\<r>\<^sup>-\<^sup>1[v]" "v \<star> \<eta>"] hcomp_arr_obj hseqI'
by auto
lemma trnr\<^sub>\<epsilon>_eq:
assumes "ide u" and "ide v"
and "src v = trg g" and "src u = trg f"
and "\<nu> \<in> hom v (u \<star> f)"
shows "trnr\<^sub>\<epsilon> u \<nu> = (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g)"
unfolding trnr\<^sub>\<epsilon>_def
using assms antipar strict_runit comp_ide_arr hcomp_arr_obj hseqI' by auto
lemma trnl\<^sub>\<eta>_eq:
assumes "ide u" and "ide v"
and "src f = trg v" and "src g = trg u"
and "\<mu> \<in> hom (f \<star> v) u"
shows "trnl\<^sub>\<eta> v \<mu> = (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v)"
using assms trnl\<^sub>\<eta>_def antipar strict_lunit comp_arr_dom hcomp_obj_arr hseqI' by auto
lemma trnl\<^sub>\<epsilon>_eq:
assumes "ide u" and "ide v"
and "src f = trg v" and "src g = trg u"
and "\<nu> \<in> hom v (g \<star> u)"
shows "trnl\<^sub>\<epsilon> u \<nu> = (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)"
using assms trnl\<^sub>\<epsilon>_def antipar strict_lunit comp_cod_arr hcomp_obj_arr hseqI' by auto
end
locale adjunction_in_strict_bicategory =
strict_bicategory +
adjunction_in_normal_bicategory
begin
lemma triangle_left:
shows "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
using ide_left ide_right antipar triangle_left strict_assoc' comp_cod_arr
by (metis dom_eqI ideD(1) seqE)
lemma triangle_right:
shows "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
using ide_left ide_right antipar triangle_right strict_assoc comp_cod_arr
by (metis ideD(1) ideD(2) seqE)
lemma trnr\<^sub>\<eta>_eq:
assumes "ide u" and "ide v"
and "src v = trg g" and "src u = trg f"
and "\<mu> \<in> hom (v \<star> g) u"
shows "trnr\<^sub>\<eta> v \<mu> = (\<mu> \<star> f) \<cdot> (v \<star> \<eta>)"
proof -
have "trnr\<^sub>\<eta> v \<mu> = (\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>)"
using assms trnr\<^sub>\<eta>_eq [of u v \<mu>] by simp
also have "... = (\<mu> \<star> f) \<cdot> (v \<star> \<eta>)"
proof -
have "\<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) = (v \<star> \<eta>)"
proof -
have "ide \<a>\<^sup>-\<^sup>1[v, g, f]"
using assms antipar strict_assoc' by simp
moreover have "seq \<a>\<^sup>-\<^sup>1[v, g, f] (v \<star> \<eta>)"
using assms antipar hseqI' by simp
ultimately show ?thesis
using comp_ide_arr by simp
qed
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
lemma trnr\<^sub>\<epsilon>_eq:
assumes "ide u" and "ide v"
and "src v = trg g" and "src u = trg f"
and "\<nu> \<in> hom v (u \<star> f)"
shows "trnr\<^sub>\<epsilon> u \<nu> = (u \<star> \<epsilon>) \<cdot> (\<nu> \<star> g)"
proof -
have "trnr\<^sub>\<epsilon> u \<nu> = (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g)"
using assms trnr\<^sub>\<epsilon>_eq [of u v \<nu>] by simp
also have "... = (u \<star> \<epsilon>) \<cdot> (\<nu> \<star> g)"
proof -
have "\<a>[u, f, g] \<cdot> (\<nu> \<star> g) = (\<nu> \<star> g)"
proof -
have "ide \<a>[u, f, g]"
using assms antipar strict_assoc by simp
moreover have "seq \<a>[u, f, g] (\<nu> \<star> g)"
using assms antipar by force
ultimately show ?thesis
using comp_ide_arr by simp
qed
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
lemma trnl\<^sub>\<eta>_eq:
assumes "ide u" and "ide v"
and "src f = trg v" and "src g = trg u"
and "\<mu> \<in> hom (f \<star> v) u"
shows "trnl\<^sub>\<eta> v \<mu> = (g \<star> \<mu>) \<cdot> (\<eta> \<star> v)"
proof -
have "trnl\<^sub>\<eta> v \<mu> = (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v)"
using assms trnl\<^sub>\<eta>_eq [of u v \<mu>] by simp
also have "... = (g \<star> \<mu>) \<cdot> (\<eta> \<star> v)"
proof -
have "seq \<a>[g, f, v] (\<eta> \<star> v)"
using assms antipar unit_in_hom hseqI'
apply (intro seqI hseqI) by auto
thus ?thesis
using assms antipar trnl\<^sub>\<eta>_eq strict_assoc comp_ide_arr [of "\<a>[g, f, v]" "\<eta> \<star> v"]
by simp
qed
finally show ?thesis by blast
qed
lemma trnl\<^sub>\<epsilon>_eq:
assumes "ide u" and "ide v"
and "src f = trg v" and "src g = trg u"
and "\<nu> \<in> hom v (g \<star> u)"
shows "trnl\<^sub>\<epsilon> u \<nu> = (\<epsilon> \<star> u) \<cdot> (f \<star> \<nu>)"
proof -
have "trnl\<^sub>\<epsilon> u \<nu> = (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)"
using assms trnl\<^sub>\<epsilon>_eq [of u v \<nu>] by simp
also have "... = ((\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> (f \<star> \<nu>)"
using comp_assoc by simp
also have "... = (\<epsilon> \<star> u) \<cdot> (f \<star> \<nu>)"
proof -
have "seq (\<epsilon> \<star> u) \<a>\<^sup>-\<^sup>1[f, g, u]"
using assms antipar unit_in_hom hseqI'
apply (intro seqI hseqI) by auto
thus ?thesis
using assms antipar trnl\<^sub>\<epsilon>_eq strict_assoc' comp_arr_ide ide_left ide_right
by metis
qed
finally show ?thesis by simp
qed
end
subsection "Preservation Properties for Adjunctions"
text \<open>
Here we show that adjunctions are preserved under isomorphisms of the
left and right adjoints.
\<close>
context bicategory
begin
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
definition adjoint_pair
where "adjoint_pair f g \<equiv> \<exists>\<eta> \<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
(* These would normally be called "maps", but that name is too heavily used already. *)
abbreviation is_left_adjoint
where "is_left_adjoint f \<equiv> \<exists>g. adjoint_pair f g"
abbreviation is_right_adjoint
where "is_right_adjoint g \<equiv> \<exists>f. adjoint_pair f g"
lemma adjoint_pair_antipar:
assumes "adjoint_pair f g"
shows "ide f" and "ide g" and "src f = trg g" and "src g = trg f"
proof -
obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using A by auto
show "ide f" by simp
show "ide g" by simp
show "src f = trg g" using A.antipar by simp
show "src g = trg f" using A.antipar by simp
qed
lemma left_adjoint_is_ide:
assumes "is_left_adjoint f"
shows "ide f"
using assms adjoint_pair_antipar by auto
lemma right_adjoint_is_ide:
assumes "is_right_adjoint f"
shows "ide f"
using assms adjoint_pair_antipar by auto
lemma adjunction_preserved_by_iso_right:
assumes "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
shows "adjunction_in_bicategory V H \<a> \<i> src trg f g' ((\<phi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
proof
interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using assms by auto
show "ide f" by simp
show "ide g'"
using assms(2) isomorphic_def by auto
show "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<eta> : src f \<Rightarrow> g' \<star> f\<guillemotright>"
using assms A.antipar by fastforce
show "\<guillemotleft>\<epsilon> \<cdot> (f \<star> inv \<phi>) : f \<star> g' \<Rightarrow> src g'\<guillemotright>"
proof
show "\<guillemotleft>f \<star> inv \<phi> : f \<star> g' \<Rightarrow> f \<star> g\<guillemotright>"
using assms A.antipar by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g'\<guillemotright>"
using assms A.counit_in_hom A.antipar by auto
qed
show "(\<epsilon> \<cdot> (f \<star> inv \<phi>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g', f] \<cdot> (f \<star> (\<phi> \<star> f) \<cdot> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
proof -
have "(\<epsilon> \<cdot> (f \<star> inv \<phi>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g', f] \<cdot> (f \<star> (\<phi> \<star> f) \<cdot> \<eta>) =
(\<epsilon> \<star> f) \<cdot> (((f \<star> inv \<phi>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g', f]) \<cdot> (f \<star> \<phi> \<star> f) \<cdot> (f \<star> \<eta>)"
using assms A.antipar whisker_right whisker_left hseqI' comp_assoc by auto
also have "... = (\<epsilon> \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> inv \<phi> \<star> f)) \<cdot> (f \<star> \<phi> \<star> f) \<cdot> (f \<star> \<eta>)"
using assms A.antipar assoc'_naturality [of f "inv \<phi>" f] by auto
also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> ((f \<star> inv \<phi> \<star> f) \<cdot> (f \<star> \<phi> \<star> f)) \<cdot> (f \<star> \<eta>)"
using comp_assoc by simp
also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> g \<star> f) \<cdot> (f \<star> \<eta>)"
using assms A.antipar comp_inv_arr inv_is_inverse hseqI' whisker_left
whisker_right [of f "inv \<phi>" \<phi>]
by auto
also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)"
using assms A.antipar comp_cod_arr hseqI' by simp
also have "... = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
using A.triangle_left by simp
finally show ?thesis by simp
qed
show "(g' \<star> \<epsilon> \<cdot> (f \<star> inv \<phi>)) \<cdot> \<a>[g', f, g'] \<cdot> ((\<phi> \<star> f) \<cdot> \<eta> \<star> g') = \<r>\<^sup>-\<^sup>1[g'] \<cdot> \<l>[g']"
proof -
have "(g' \<star> \<epsilon> \<cdot> (f \<star> inv \<phi>)) \<cdot> \<a>[g', f, g'] \<cdot> ((\<phi> \<star> f) \<cdot> \<eta> \<star> g') =
(g' \<star> \<epsilon>) \<cdot> ((g' \<star> f \<star> inv \<phi>) \<cdot> \<a>[g', f, g']) \<cdot> ((\<phi> \<star> f) \<star> g') \<cdot> (\<eta> \<star> g')"
using assms hseqI' A.antipar whisker_left whisker_right comp_assoc by auto
also have "... = (g' \<star> \<epsilon>) \<cdot> (\<a>[g', f, g] \<cdot> ((g' \<star> f) \<star> inv \<phi>)) \<cdot> ((\<phi> \<star> f) \<star> g') \<cdot> (\<eta> \<star> g')"
using assms A.antipar assoc_naturality [of g' f "inv \<phi>"] by auto
also have "... = (g' \<star> \<epsilon>) \<cdot> \<a>[g', f, g] \<cdot> (((g' \<star> f) \<star> inv \<phi>) \<cdot> ((\<phi> \<star> f) \<star> g')) \<cdot> (\<eta> \<star> g')"
using comp_assoc by simp
also have "... = (g' \<star> \<epsilon>) \<cdot> (\<a>[g', f, g] \<cdot> ((\<phi> \<star> f) \<star> g)) \<cdot> ((g \<star> f) \<star> inv \<phi>) \<cdot> (\<eta> \<star> g')"
proof -
have "((g' \<star> f) \<star> inv \<phi>) \<cdot> ((\<phi> \<star> f) \<star> g') = (\<phi> \<star> f) \<star> inv \<phi>"
using assms A.antipar comp_arr_dom comp_cod_arr hseqI'
interchange [of "g' \<star> f" "\<phi> \<star> f" "inv \<phi>" g']
by auto
also have "... = ((\<phi> \<star> f) \<star> g) \<cdot> ((g \<star> f) \<star> inv \<phi>)"
using assms A.antipar comp_arr_dom comp_cod_arr
interchange [of "\<phi> \<star> f" "g \<star> f" g "inv \<phi>"] hseqI'
by auto
finally show ?thesis
using comp_assoc by simp
qed
also have "... = ((g' \<star> \<epsilon>) \<cdot> (\<phi> \<star> f \<star> g)) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> (trg g \<star> inv \<phi>)"
proof -
have "\<a>[g', f, g] \<cdot> ((\<phi> \<star> f) \<star> g) = (\<phi> \<star> f \<star> g) \<cdot> \<a>[g, f, g]"
using assms A.antipar assoc_naturality [of \<phi> f g] by auto
moreover have "((g \<star> f) \<star> inv \<phi>) \<cdot> (\<eta> \<star> g') = (\<eta> \<star> g) \<cdot> (trg g \<star> inv \<phi>)"
using assms A.antipar comp_arr_dom comp_cod_arr
interchange [of "g \<star> f" \<eta> "inv \<phi>" g'] interchange [of \<eta> "trg g" g "inv \<phi>"]
by auto
ultimately show ?thesis
using comp_assoc by simp
qed
also have "... = ((\<phi> \<star> src g) \<cdot> (g \<star> \<epsilon>)) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> (trg g \<star> inv \<phi>)"
using assms A.antipar comp_arr_dom comp_cod_arr
interchange [of g' \<phi> \<epsilon> "f \<star> g"] interchange [of \<phi> g "src g" \<epsilon>]
by auto
also have "... = (\<phi> \<star> src g) \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> (trg g \<star> inv \<phi>)"
using comp_assoc by simp
also have "... = ((\<phi> \<star> src g) \<cdot> \<r>\<^sup>-\<^sup>1[g]) \<cdot> \<l>[g] \<cdot> (trg g \<star> inv \<phi>)"
using assms A.antipar A.triangle_right comp_cod_arr comp_assoc
by simp
also have "... = (\<r>\<^sup>-\<^sup>1[g'] \<cdot> \<phi>) \<cdot> inv \<phi> \<cdot> \<l>[g']"
using assms A.antipar runit'_naturality [of \<phi>] lunit_naturality [of "inv \<phi>"]
by auto
also have "... = \<r>\<^sup>-\<^sup>1[g'] \<cdot> (\<phi> \<cdot> inv \<phi>) \<cdot> \<l>[g']"
using comp_assoc by simp
also have "... = \<r>\<^sup>-\<^sup>1[g'] \<cdot> \<l>[g']"
using assms comp_cod_arr comp_arr_inv' by auto
finally show ?thesis by simp
qed
qed
lemma adjunction_preserved_by_iso_left:
assumes "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
shows "adjunction_in_bicategory V H \<a> \<i> src trg f' g ((g \<star> \<phi>) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
proof
interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using assms by auto
show "ide g" by simp
show "ide f'"
using assms(2) isomorphic_def by auto
show "\<guillemotleft>(g \<star> \<phi>) \<cdot> \<eta> : src f' \<Rightarrow> g \<star> f'\<guillemotright>"
proof
show "\<guillemotleft>\<eta> : src f' \<Rightarrow> g \<star> f\<guillemotright>"
using assms A.unit_in_hom by auto
show "\<guillemotleft>g \<star> \<phi> : g \<star> f \<Rightarrow> g \<star> f'\<guillemotright>"
using assms A.antipar by fastforce
qed
show "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) : f' \<star> g \<Rightarrow> src g\<guillemotright>"
proof
show "\<guillemotleft>inv \<phi> \<star> g : f' \<star> g \<Rightarrow> f \<star> g\<guillemotright>"
using assms A.antipar by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>"
using assms A.antipar by auto
qed
show "(g \<star> \<epsilon> \<cdot> (inv \<phi> \<star> g)) \<cdot> \<a>[g, f', g] \<cdot> ((g \<star> \<phi>) \<cdot> \<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
proof -
have "(g \<star> \<epsilon> \<cdot> (inv \<phi> \<star> g)) \<cdot> \<a>[g, f', g] \<cdot> ((g \<star> \<phi>) \<cdot> \<eta> \<star> g) =
(g \<star> \<epsilon>) \<cdot> ((g \<star> inv \<phi> \<star> g) \<cdot> \<a>[g, f', g]) \<cdot> ((g \<star> \<phi>) \<star> g) \<cdot> (\<eta> \<star> g)"
using assms A.antipar whisker_left whisker_right hseqI' comp_assoc by auto
also have "... = (g \<star> \<epsilon>) \<cdot> (\<a>[g, f, g] \<cdot> ((g \<star> inv \<phi>) \<star> g)) \<cdot> ((g \<star> \<phi>) \<star> g) \<cdot> (\<eta> \<star> g)"
using assms A.antipar assoc_naturality [of g "inv \<phi>" g] by auto
also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (((g \<star> inv \<phi>) \<star> g) \<cdot> ((g \<star> \<phi>) \<star> g)) \<cdot> (\<eta> \<star> g)"
using comp_assoc by simp
also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> ((g \<star> f) \<star> g) \<cdot> (\<eta> \<star> g)"
using assms A.antipar comp_inv_arr inv_is_inverse hseqI' whisker_right
whisker_left [of g "inv \<phi>" \<phi>]
by auto
also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)"
using assms A.antipar comp_cod_arr hseqI' by simp
also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
using A.triangle_right by simp
finally show ?thesis by simp
qed
show "(\<epsilon> \<cdot> (inv \<phi> \<star> g) \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f', g, f'] \<cdot> (f' \<star> (g \<star> \<phi>) \<cdot> \<eta>) = \<l>\<^sup>-\<^sup>1[f'] \<cdot> \<r>[f']"
proof -
have "(\<epsilon> \<cdot> (inv \<phi> \<star> g) \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f', g, f'] \<cdot> (f' \<star> (g \<star> \<phi>) \<cdot> \<eta>) =
(\<epsilon> \<star> f') \<cdot> (((inv \<phi> \<star> g) \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f', g, f']) \<cdot> (f' \<star> g \<star> \<phi>) \<cdot> (f' \<star> \<eta>)"
using assms hseqI' A.antipar whisker_right whisker_left comp_assoc
by auto
also have "... = (\<epsilon> \<star> f') \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> (inv \<phi> \<star> g \<star> f')) \<cdot> (f' \<star> g \<star> \<phi>) \<cdot> (f' \<star> \<eta>)"
using assms A.antipar assoc'_naturality [of "inv \<phi>" g f'] by auto
also have "... = (\<epsilon> \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> ((inv \<phi> \<star> g \<star> f') \<cdot> (f' \<star> g \<star> \<phi>)) \<cdot> (f' \<star> \<eta>)"
using comp_assoc by simp
also have "... = (\<epsilon> \<star> f') \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> (f \<star> g \<star> \<phi>)) \<cdot> (inv \<phi> \<star> g \<star> f) \<cdot> (f' \<star> \<eta>)"
proof -
- have "(inv \<phi> \<star> g \<star> f') \<cdot> (f' \<star> g \<star> \<phi>) = inv \<phi> \<star> g \<star> \<phi>"
- using assms A.antipar comp_arr_dom comp_cod_arr hseqI'
+ have "(inv \<phi> \<star> g \<star> f') \<cdot> (f' \<star> g \<star> \<phi>) = (f \<star> g \<star> \<phi>) \<cdot> (inv \<phi> \<star> g \<star> f)"
+ using assms(2-3) A.antipar comp_arr_dom comp_cod_arr hseqI'
interchange [of "inv \<phi>" f' "g \<star> f'" "g \<star> \<phi>"]
- by auto
- also have "... = (f \<star> g \<star> \<phi>) \<cdot> (inv \<phi> \<star> g \<star> f)"
- using assms A.antipar comp_arr_dom comp_cod_arr hseqI'
interchange [of f "inv \<phi>" "g \<star> \<phi>" "g \<star> f"]
by auto
- finally show ?thesis
+ thus ?thesis
using comp_assoc by simp
qed
also have "... = ((\<epsilon> \<star> f') \<cdot> ((f \<star> g) \<star> \<phi>)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> (inv \<phi> \<star> src f)"
proof -
have "\<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> (f \<star> g \<star> \<phi>) = ((f \<star> g) \<star> \<phi>) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f]"
using assms A.antipar assoc'_naturality [of f g \<phi>] by auto
moreover have "(inv \<phi> \<star> g \<star> f) \<cdot> (f' \<star> \<eta>) = (f \<star> \<eta>) \<cdot> (inv \<phi> \<star> src f)"
using assms A.antipar comp_arr_dom comp_cod_arr
interchange [of "inv \<phi>" f' "g \<star> f" \<eta>] interchange [of f "inv \<phi>" \<eta> "src f"]
by auto
ultimately show ?thesis
using comp_assoc by simp
qed
also have "... = ((trg f \<star> \<phi>) \<cdot> (\<epsilon> \<star> f)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> (inv \<phi> \<star> src f)"
using assms A.antipar comp_arr_dom comp_cod_arr
interchange [of \<epsilon> "f \<star> g" f' \<phi>] interchange [of "trg f" \<epsilon> \<phi> f]
by auto
also have "... = (trg f \<star> \<phi>) \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> (inv \<phi> \<star> src f)"
using comp_assoc by simp
also have "... = ((trg f \<star> \<phi>) \<cdot> \<l>\<^sup>-\<^sup>1[f]) \<cdot> \<r>[f] \<cdot> (inv \<phi> \<star> src f)"
using assms A.antipar A.triangle_left comp_cod_arr comp_assoc
by simp
also have "... = (\<l>\<^sup>-\<^sup>1[f'] \<cdot> \<phi>) \<cdot> inv \<phi> \<cdot> \<r>[f']"
using assms A.antipar lunit'_naturality runit_naturality [of "inv \<phi>"] by auto
also have "... = \<l>\<^sup>-\<^sup>1[f'] \<cdot> (\<phi> \<cdot> inv \<phi>) \<cdot> \<r>[f']"
using comp_assoc by simp
also have "... = \<l>\<^sup>-\<^sup>1[f'] \<cdot> \<r>[f']"
using assms comp_cod_arr comp_arr_inv inv_is_inverse by auto
finally show ?thesis by simp
qed
qed
lemma adjoint_pair_preserved_by_iso:
assumes "adjoint_pair f g"
and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
and "\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<psi>"
shows "adjoint_pair f' g'"
proof -
obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
have "adjunction_in_bicategory V H \<a> \<i> src trg f g' ((\<psi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<psi>))"
using assms A adjunction_preserved_by_iso_right by blast
hence "adjunction_in_bicategory V H \<a> \<i> src trg f' g'
((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>) ((\<epsilon> \<cdot> (f \<star> inv \<psi>)) \<cdot> (inv \<phi> \<star> g'))"
using assms adjunction_preserved_by_iso_left by blast
thus ?thesis using adjoint_pair_def by auto
qed
lemma left_adjoint_preserved_by_iso:
assumes "is_left_adjoint f"
and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
shows "is_left_adjoint f'"
proof -
obtain g where g: "adjoint_pair f g"
using assms by auto
have "adjoint_pair f' g"
using assms g adjoint_pair_preserved_by_iso [of f g \<phi> f' g g]
adjoint_pair_antipar [of f g]
by auto
thus ?thesis by auto
qed
lemma right_adjoint_preserved_by_iso:
assumes "is_right_adjoint g"
and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
shows "is_right_adjoint g'"
proof -
obtain f where f: "adjoint_pair f g"
using assms by auto
have "adjoint_pair f g'"
using assms f adjoint_pair_preserved_by_iso [of f g f f \<phi> g']
adjoint_pair_antipar [of f g]
by auto
thus ?thesis by auto
qed
lemma left_adjoint_preserved_by_iso':
assumes "is_left_adjoint f" and "f \<cong> f'"
shows "is_left_adjoint f'"
using assms isomorphic_def left_adjoint_preserved_by_iso by blast
lemma right_adjoint_preserved_by_iso':
assumes "is_right_adjoint g" and "g \<cong> g'"
shows "is_right_adjoint g'"
using assms isomorphic_def right_adjoint_preserved_by_iso by blast
lemma obj_self_adjunction:
assumes "obj a"
shows "adjunction_in_bicategory V H \<a> \<i> src trg a a \<l>\<^sup>-\<^sup>1[a] \<r>[a]"
proof
show 1: "ide a"
using assms by auto
show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[a] : src a \<Rightarrow> a \<star> a\<guillemotright>"
using assms 1 by auto
show "\<guillemotleft>\<r>[a] : a \<star> a \<Rightarrow> src a\<guillemotright>"
using assms 1 by fastforce
show "(\<r>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] \<cdot> (a \<star> \<l>\<^sup>-\<^sup>1[a]) = \<l>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a]"
using assms 1 canI_unitor_1 canI_associator_1(2) canI_associator_3
whisker_can_right_1 whisker_can_left_1 can_Ide_self
by simp
show "(a \<star> \<r>[a]) \<cdot> \<a>[a, a, a] \<cdot> (\<l>\<^sup>-\<^sup>1[a] \<star> a) = \<r>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a]"
using assms 1 canI_unitor_1 canI_associator_1(2) canI_associator_3
whisker_can_right_1 whisker_can_left_1 can_Ide_self
by simp
qed
lemma obj_is_self_adjoint:
assumes "obj a"
shows "adjoint_pair a a" and "is_left_adjoint a" and "is_right_adjoint a"
using assms obj_self_adjunction adjoint_pair_def by auto
end
subsection "Pseudofunctors and Adjunctions"
context pseudofunctor
begin
lemma preserves_adjunction:
assumes "adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
shows "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
proof -
interpret adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
using assms by auto
interpret A: adjunction_data_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>F f\<close> \<open>F g\<close> \<open>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)\<close>
\<open>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)\<close>
using adjunction_data_in_bicategory_axioms preserves_adjunction_data by auto
show "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
proof
show "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
D.lunit' (F f) \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
proof -
have 1: "D.iso (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)))"
using antipar C.VV.ide_char C.VV.arr_char D.iso_is_arr FF_def
by (intro D.isos_compose D.seqI, simp_all)
have "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
proof -
have "\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] =
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))"
proof -
have "\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))) =
D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f))"
proof -
have "D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F f]) =
D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f))"
using antipar assoc_coherence by simp
moreover
have "D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F f]) =
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)))"
proof -
have "D.seq (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))) \<a>\<^sub>D[F f, F g, F f]"
using antipar by fastforce
thus ?thesis
using 1 antipar D.comp_assoc
D.inv_comp [of "\<a>\<^sub>D[F f, F g, F f]" "\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))"]
by auto
qed
ultimately show ?thesis by simp
qed
moreover have 2: "D.iso (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f))"
using antipar D.isos_compose C.VV.ide_char C.VV.arr_char \<Phi>_simps(4) D.hseqI'
by simp
ultimately have "\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] =
D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
(\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)))"
using 1 2 antipar D.invert_side_of_triangle(2) D.inv_inv D.iso_inv_iso D.arr_inv
by metis
moreover have "D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) =
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
proof -
have "D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) =
D.inv (\<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
- using antipar D.isos_compose C.VV.ide_char C.VV.arr_char \<Phi>_simps(4) D.hseqI'
- preserves_inv D.inv_comp D.iso_is_arr
- by simp
+ using antipar D.isos_compose C.VV.arr_char \<Phi>_simps(4) D.hseqI'
+ preserves_inv D.inv_comp
+ by simp
also have "... = (D.inv (\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
using antipar D.inv_comp C.VV.ide_char C.VV.arr_char \<Phi>_simps(4) D.hseqI'
by simp
also have "... = ((D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
using antipar C.VV.ide_char C.VV.arr_char by simp
also have "... = (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
using D.comp_assoc by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
proof -
have "... = ((D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D
((F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)))"
proof -
have "D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f =
(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)"
using ide_left ide_right antipar D.whisker_right \<Psi>_char(2)
by (metis A.counit_simps(1) A.ide_left D.comp_assoc)
moreover have "F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) =
(F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
using antipar \<Psi>_char(2) D.whisker_left by simp
ultimately show ?thesis by simp
qed
also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
(((\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
(((F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)))) \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)))"
using D.comp_assoc by simp
also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
proof -
have "((F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)))) \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)"
proof -
have "(F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) = F f \<star>\<^sub>D F (g \<star>\<^sub>C f)"
using antipar \<Psi>_char(2) D.comp_arr_inv D.inv_is_inverse
D.whisker_left [of "F f" "\<Phi> (g, f)" "D.inv (\<Phi> (g, f))"]
by simp
moreover have "D.seq (F f \<star>\<^sub>D F (g \<star>\<^sub>C f)) (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
using antipar by fastforce
ultimately show ?thesis
using D.comp_cod_arr by auto
qed
moreover have "((\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, f)) =
D.inv (\<Phi> (f \<star>\<^sub>C g, f))"
using antipar D.comp_arr_inv D.inv_is_inverse D.comp_cod_arr
D.whisker_right [of "F f" "\<Phi> (f, g)" "D.inv (\<Phi> (f, g))"]
by simp
ultimately show ?thesis by simp
qed
finally show ?thesis by simp
qed
also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D
D.inv (\<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D
((\<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]) \<cdot>\<^sub>D
((\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C f))) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>)) \<cdot>\<^sub>D
\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
proof -
have "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
((D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F \<epsilon> \<star>\<^sub>D F f)) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
((F f \<star>\<^sub>D F \<eta>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)))"
using antipar D.comp_assoc D.whisker_left D.whisker_right \<Psi>_char(2)
by simp
moreover have "F \<epsilon> \<star>\<^sub>D F f = D.inv (\<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f)"
using antipar \<Phi>.naturality [of "(\<epsilon>, f)"] C.VV.arr_char FF_def C.hseqI'
D.invert_side_of_triangle(1)
by simp
moreover have "F f \<star>\<^sub>D F \<eta> = D.inv (\<Phi> (f, g \<star>\<^sub>C f)) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f)"
using antipar \<Phi>.naturality [of "(f, \<eta>)"] C.VV.arr_char FF_def C.hseqI'
D.invert_side_of_triangle(1)
by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = ((D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))) \<cdot>\<^sub>D
(F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>)) \<cdot>\<^sub>D
\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
using antipar D.comp_arr_inv' D.comp_cod_arr C.hseqI' D.comp_assoc by simp
also have "... = D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) \<cdot>\<^sub>D
\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
proof -
have "(D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f)) =
D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
proof -
have "D.iso (\<Phi> (trg\<^sub>C f, f))"
using antipar by simp
moreover have "D.iso (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
using antipar \<Psi>_char(2) by simp
moreover have "D.seq (\<Phi> (trg\<^sub>C f, f)) (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
using antipar D.iso_is_arr calculation(2)
apply (intro D.seqI D.hseqI) by auto
ultimately show ?thesis
using antipar D.inv_comp \<Psi>_char(2) by simp
qed
moreover have "F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>) =
F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>))"
using antipar C.hseqI' by simp
ultimately show ?thesis by simp
qed
also have "... = (D.lunit' (F f) \<cdot>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D
F (C.lunit' f \<cdot>\<^sub>C \<r>\<^sub>C[f]) \<cdot>\<^sub>D
(D.inv (F \<r>\<^sub>C[f]) \<cdot>\<^sub>D \<r>\<^sub>D[F f])"
proof -
have "F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) = F (C.lunit' f \<cdot>\<^sub>C \<r>\<^sub>C[f])"
using triangle_left by simp
moreover have "D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) =
D.lunit' (F f) \<cdot>\<^sub>D F \<l>\<^sub>C[f]"
proof -
have 0: "D.iso (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
using \<Psi>_char(2) D.hseqI'
apply (intro D.isos_compose D.seqI) by auto
show ?thesis
proof -
have 1: "D.iso (F \<l>\<^sub>C[f])"
using C.iso_lunit preserves_iso by auto
moreover have "D.iso (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
by (metis (no_types) A.ide_left D.iso_lunit ide_left lunit_coherence)
moreover have "D.inv (D.inv (F \<l>\<^sub>C[f])) = F \<l>\<^sub>C[f]"
using 1 D.inv_inv by blast
ultimately show ?thesis
by (metis 0 D.inv_comp D.invert_side_of_triangle(2) D.iso_inv_iso
D.iso_is_arr ide_left lunit_coherence)
qed
qed
moreover have "\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) = D.inv (F \<r>\<^sub>C[f]) \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
using ide_left runit_coherence preserves_iso C.iso_runit D.invert_side_of_triangle(1)
by (metis A.ide_left D.runit_simps(1))
ultimately show ?thesis by simp
qed
also have "... = D.lunit' (F f) \<cdot>\<^sub>D
((F \<l>\<^sub>C[f] \<cdot>\<^sub>D F (C.lunit' f)) \<cdot>\<^sub>D (F \<r>\<^sub>C[f] \<cdot>\<^sub>D D.inv (F \<r>\<^sub>C[f]))) \<cdot>\<^sub>D
\<r>\<^sub>D[F f]"
using D.comp_assoc by simp
also have "... = D.lunit' (F f) \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
using D.comp_cod_arr C.iso_runit C.iso_lunit preserves_iso D.comp_arr_inv'
preserves_inv
by force
finally show ?thesis by blast
qed
show "(F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g) =
D.runit' (F g) \<cdot>\<^sub>D \<l>\<^sub>D[F g]"
proof -
have "\<a>\<^sub>D[F g, F f, F g] =
D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g)"
proof -
have "D.iso (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)))"
using antipar D.iso_is_arr
by (intro D.isos_compose D.seqI, auto)
have "F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g) =
\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D \<a>\<^sub>D[F g, F f, F g]"
using antipar assoc_coherence by simp
moreover have "D.seq (F \<a>\<^sub>C[g, f, g]) (\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g))"
proof (intro D.seqI)
show 1: "D.hseq (\<Phi> (g, f)) (F g)"
using antipar C.VV.arr_char D.hseqI' by simp
show "D.arr (\<Phi> (g \<star>\<^sub>C f, g))"
using antipar C.VV.arr_char by simp
show "D.dom (\<Phi> (g \<star>\<^sub>C f, g)) = D.cod (\<Phi> (g, f) \<star>\<^sub>D F g)"
proof -
have "D.iso (\<Phi> (g, f) \<star>\<^sub>D F g)"
using antipar by simp
moreover have "D.iso (\<Phi> (g \<star>\<^sub>C f, g))"
using antipar by simp
ultimately show ?thesis
using ide_left ide_right A.ide_right antipar D.iso_is_arr D.ide_char
C.ide_hcomp C.ideD(1) C.src_hcomp' D.hcomp_simps(4) \<Phi>_simps(4-5)
by metis
qed
show "D.arr (F \<a>\<^sub>C[g, f, g])"
using antipar by simp
show "D.dom (F \<a>\<^sub>C[g, f, g]) = D.cod (\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g))"
proof -
have "D.iso (\<Phi> (g, f) \<star>\<^sub>D F g)"
using antipar by simp
moreover have "D.seq (\<Phi> (g \<star>\<^sub>C f, g)) (\<Phi> (g, f) \<star>\<^sub>D F g)"
using antipar D.iso_is_arr by (intro D.seqI, auto)
ultimately show ?thesis
using antipar by simp
qed
qed
ultimately show ?thesis
using \<open>D.iso (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)))\<close> D.invert_side_of_triangle(1)
D.comp_assoc
by auto
qed
hence "(F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g) =
(F g \<star>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D
\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
using D.comp_assoc by simp
also have "... = ((F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D
(\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D ((D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D
(F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g))"
proof -
have "F g \<star>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D \<Phi> (f, g) =
(F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))"
proof -
have "D.seq (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) (\<Phi> (f, g))"
using antipar D.comp_assoc by simp
thus ?thesis
using antipar D.whisker_left by simp
qed
moreover have "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g =
(D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
using antipar D.whisker_right by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D
(((F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
D.inv (\<Phi> (g, f \<star>\<^sub>C g))) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D
((\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
(F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
proof -
have "D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) =
D.inv (F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (\<Phi> (g, f \<star>\<^sub>C g))"
proof -
have "D.iso (\<Phi> (g, f \<star>\<^sub>C g))"
using antipar by simp
moreover have "D.iso (F g \<star>\<^sub>D \<Phi> (f, g))"
using antipar by simp
moreover have "D.seq (\<Phi> (g, f \<star>\<^sub>C g)) (F g \<star>\<^sub>D \<Phi> (f, g))"
using antipar \<Phi>_in_hom A.ide_right D.iso_is_arr
apply (intro D.seqI D.hseqI) by auto
ultimately show ?thesis
using antipar D.inv_comp by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D
D.inv (\<Phi> (g, f \<star>\<^sub>C g)) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D
(F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
proof -
have "((\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
(F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g) =
(F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
proof -
have "(\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) = F (g \<star>\<^sub>C f) \<star>\<^sub>D F g"
using antipar D.comp_arr_inv'
D.whisker_right [of "F g" "\<Phi> (g, f)" "D.inv (\<Phi> (g, f))"]
by simp
thus ?thesis
using antipar D.comp_cod_arr D.whisker_right D.hseqI' by simp
qed
moreover have "((F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
D.inv (\<Phi> (g, f \<star>\<^sub>C g)) =
D.inv (\<Phi> (g, f \<star>\<^sub>C g))"
using antipar D.comp_arr_inv' D.comp_cod_arr
D.whisker_left [of "F g" "\<Phi> (f, g)" "D.inv (\<Phi> (f, g))"]
by simp
ultimately show ?thesis by simp
qed
also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D
((F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D D.inv (\<Phi> (g, f \<star>\<^sub>C g))) \<cdot>\<^sub>D
F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D
(\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g)) \<cdot>\<^sub>D
(\<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
using antipar D.whisker_left D.whisker_right \<Psi>_char(2) D.comp_assoc by simp
also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D
(F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g)) \<cdot>\<^sub>D
\<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
proof -
have "(F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D D.inv (\<Phi> (g, f \<star>\<^sub>C g)) = D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (g \<star>\<^sub>C \<epsilon>)"
using antipar C.VV.arr_char \<Phi>.naturality [of "(g, \<epsilon>)"] FF_def C.hseqI'
D.invert_opposite_sides_of_square
by simp
moreover have "\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g) = F (\<eta> \<star>\<^sub>C g) \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g)"
using antipar C.VV.arr_char \<Phi>.naturality [of "(\<eta>, g)"] FF_def by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = ((F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D
F (C.runit' g)) \<cdot>\<^sub>D (F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (src\<^sub>C f) \<star>\<^sub>D F g))"
proof -
have "F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g) = F (C.runit' g) \<cdot>\<^sub>D F \<l>\<^sub>C[g]"
using ide_left ide_right antipar triangle_right
by (metis C.comp_in_homE C.seqI' preserves_comp triangle_in_hom(2))
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = D.runit' (F g) \<cdot>\<^sub>D \<l>\<^sub>D[F g]"
proof -
have "D.inv \<r>\<^sub>D[F g] =
(F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (C.runit' g)"
proof -
have "D.runit' (F g) = D.inv (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)))"
using runit_coherence by simp
also have
"... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (C.runit' g)"
proof -
have "D.inv (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) =
D.inv (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (C.runit' g)"
proof -
have "D.iso (F \<r>\<^sub>C[g])"
using preserves_iso by simp
moreover have 1: "D.iso (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)))"
using preserves_iso \<Psi>_char(2) D.arrI D.seqE ide_right runit_coherence D.hseqI'
by (intro D.isos_compose D.seqI D.hseqI, auto)
moreover have "D.seq (F \<r>\<^sub>C[g]) (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)))"
using ide_right A.ide_right D.runit_simps(1) runit_coherence by metis
ultimately have "D.inv (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) =
D.inv (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D F (C.runit' g)"
using C.iso_runit preserves_inv D.inv_comp by simp
moreover have "D.inv (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) =
D.inv (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
proof -
have "D.seq (\<Phi> (g, src\<^sub>C g)) (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
using 1 antipar preserves_iso \<Psi>_char(2) by fast
(*
* TODO: The fact that auto cannot do this step is probably what is blocking
* the whole thing from being done by auto.
*)
thus ?thesis
using 1 antipar preserves_iso \<Psi>_char(2) D.inv_comp by auto
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
thus ?thesis
using antipar \<Psi>_char(2) preserves_iso by simp
qed
finally show ?thesis by simp
qed
thus ?thesis
using antipar lunit_coherence by simp
qed
finally show ?thesis by simp
qed
qed
qed
lemma preserves_adjoint_pair:
assumes "C.adjoint_pair f g"
shows "D.adjoint_pair (F f) (F g)"
using assms C.adjoint_pair_def D.adjoint_pair_def preserves_adjunction by blast
lemma preserves_left_adjoint:
assumes "C.is_left_adjoint f"
shows "D.is_left_adjoint (F f)"
using assms preserves_adjoint_pair by auto
lemma preserves_right_adjoint:
assumes "C.is_right_adjoint g"
shows "D.is_right_adjoint (F g)"
using assms preserves_adjoint_pair by auto
end
context equivalence_pseudofunctor
begin
lemma reflects_adjunction:
assumes "C.ide f" and "C.ide g"
and "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
and "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
shows "adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
proof -
let ?\<eta>' = "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)"
let ?\<epsilon>' = "D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)"
interpret A': adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close> ?\<eta>' ?\<epsilon>'
using assms(5) by auto
interpret A: adjunction_data_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
using assms(1-4) by (unfold_locales, auto)
show ?thesis
proof
show "(\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>) = \<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f]"
proof -
have 1: "C.par ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) (\<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f])"
using assms A.antipar C.hseqI' by simp
moreover have "F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) = F (\<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f])"
proof -
have "F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) =
F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>)"
using 1 by auto
also have "... =
(F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
(\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g \<star>\<^sub>C f)) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>))"
using assms A.antipar preserves_assoc(2) D.comp_assoc by auto
also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D ((F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
((F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta>)) \<cdot>\<^sub>D
D.inv (\<Phi> (f, src\<^sub>C f))"
proof -
have "F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (F \<epsilon> \<star>\<^sub>D F f)"
using assms \<Phi>.naturality [of "(\<epsilon>, f)"] FF_def C.VV.arr_char by simp
moreover have "D.inv (\<Phi> (f, g \<star>\<^sub>C f)) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>) =
(F f \<star>\<^sub>D F \<eta>) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
proof -
have "F (f \<star>\<^sub>C \<eta>) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) = \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta>)"
using assms \<Phi>.naturality [of "(f, \<eta>)"] FF_def C.VV.arr_char A.antipar
by simp
thus ?thesis
using assms A.antipar \<Phi>_components_are_iso C.VV.arr_char \<Phi>_in_hom
FF_def D.hseqI'
D.invert_opposite_sides_of_square
[of "\<Phi> (f, g \<star>\<^sub>C f)" "F f \<star>\<^sub>D F \<eta>" "F (f \<star>\<^sub>C \<eta>)" "\<Phi> (f, src\<^sub>C f)"]
by fastforce
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta>) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
using assms A.antipar \<Phi>_in_hom A.ide_left A.ide_right A'.ide_left A'.ide_right
D.whisker_left [of "F f" "D.inv (\<Phi> (g, f))" "F \<eta>"]
D.whisker_right [of "F f" "F \<epsilon>" "\<Phi> (f, g)"]
by (metis A'.counit_in_vhom A'.unit_simps(1)D.arrI D.comp_assoc
D.src.preserves_reflects_arr D.src_vcomp D.vseq_implies_hpar(1) \<Phi>_simps(2))
also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>' \<star>\<^sub>D F f) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
(F f \<star>\<^sub>D ?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
proof -
have "F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) = \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>'"
proof -
have "D.iso (\<Psi> (trg\<^sub>C f))"
using A.ide_left C.ideD(1) \<Psi>_char(2) by blast
thus ?thesis
by (metis A'.counit_simps(1) D.comp_assoc D.comp_cod_arr D.inv_is_inverse
D.seqE D.comp_arr_inv)
qed
moreover have "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> = ?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
using assms(2) \<Psi>_char D.comp_arr_inv D.inv_is_inverse D.comp_assoc D.comp_cod_arr
by (metis A'.unit_simps(1) A.antipar(1) C.ideD(1) C.obj_trg
D.invert_side_of_triangle(2))
ultimately show ?thesis by simp
qed
also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D ((\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D
(?\<epsilon>' \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D ((F f \<star>\<^sub>D ?\<eta>') \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
using assms A.antipar A'.antipar \<Psi>_char D.whisker_left D.whisker_right
by simp
also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D
((?\<epsilon>' \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<eta>')) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
using D.comp_assoc by simp
also have "... = (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]) \<cdot>\<^sub>D
\<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
using A'.triangle_left D.comp_assoc by simp
also have "... = F \<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>D F \<r>\<^sub>C[f]"
using assms A.antipar preserves_lunit(2) preserves_runit(1) by simp
also have "... = F (\<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f])"
using assms by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using is_faithful by blast
qed
show "(g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g) = \<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g]"
proof -
have 1: "C.par ((g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C g f g \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g)) (\<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g])"
using assms A.antipar C.hseqI' by auto
moreover have "F ((g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g)) = F (\<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g])"
proof -
have "F ((g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C g f g \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g)) =
F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g)"
using 1 by auto
also have "... = (F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D \<Phi> (g, f \<star>\<^sub>C g)) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
(D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g \<star>\<^sub>C f, g)) \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g))"
using assms A.antipar preserves_assoc(1) [of g f g] D.comp_assoc by auto
also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D ((F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
((D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g)) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
proof -
have "F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D \<Phi> (g, f \<star>\<^sub>C g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<epsilon>)"
using assms \<Phi>.naturality [of "(g, \<epsilon>)"] FF_def C.VV.arr_char by auto
moreover have "D.inv (\<Phi> (g \<star>\<^sub>C f, g)) \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g) =
(F \<eta> \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
proof -
have "F (\<eta> \<star>\<^sub>C g) \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) = \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g)"
using assms \<Phi>.naturality [of "(\<eta>, g)"] FF_def C.VV.arr_char A.antipar
by auto
thus ?thesis
using assms A.antipar \<Phi>_components_are_iso C.VV.arr_char FF_def D.hseqI'
D.invert_opposite_sides_of_square
[of "\<Phi> (g \<star>\<^sub>C f, g)" "F \<eta> \<star>\<^sub>D F g" "F (\<eta> \<star>\<^sub>C g)" "\<Phi> (trg\<^sub>C g, g)"]
by fastforce
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have " ... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
proof -
have "(F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)) = F g \<star>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)"
using assms A.antipar D.whisker_left
by (metis A'.counit_simps(1) A'.ide_right D.seqE)
moreover have "(D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g) =
D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<star>\<^sub>D F g"
using assms A.antipar D.whisker_right by simp
ultimately show ?thesis by simp
qed
also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
(?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
proof -
have "F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) = \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>'"
using \<Psi>_char D.comp_arr_inv D.inv_is_inverse D.comp_assoc D.comp_cod_arr
by (metis A'.counit_simps(1) C.ideD(1) C.obj_trg D.seqE assms(1))
moreover have "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> = ?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
using \<Psi>_char D.comp_arr_inv D.inv_is_inverse D.comp_assoc D.comp_cod_arr
by (metis A'.unit_simps(1) A.unit_simps(1) A.unit_simps(5)
C.obj_trg D.invert_side_of_triangle(2))
ultimately show ?thesis by simp
qed
also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D
((F g \<star>\<^sub>D ?\<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D (?\<eta>' \<star>\<^sub>D F g)) \<cdot>\<^sub>D
(D.inv (\<Psi> (src\<^sub>C f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
using assms A.antipar \<Psi>_char D.whisker_left D.whisker_right D.comp_assoc
by simp
also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g] \<cdot>\<^sub>D
\<l>\<^sub>D[F g] \<cdot>\<^sub>D (D.inv (\<Psi> (src\<^sub>C f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
using A'.triangle_right D.comp_assoc by simp
also have "... = F \<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>D F \<l>\<^sub>C[g]"
using assms A.antipar preserves_lunit(1) preserves_runit(2) D.comp_assoc
by simp
also have "... = F (\<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g])"
using assms by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using is_faithful by blast
qed
qed
qed
lemma reflects_adjoint_pair:
assumes "C.ide f" and "C.ide g"
and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C f"
and "D.adjoint_pair (F f) (F g)"
shows "C.adjoint_pair f g"
proof -
obtain \<eta>' \<epsilon>' where A': "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g) \<eta>' \<epsilon>'"
using assms D.adjoint_pair_def by auto
interpret A': adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close> \<eta>' \<epsilon>'
using A' by auto
have 1: "\<guillemotleft>\<Phi> (g, f) \<cdot>\<^sub>D \<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
using assms \<Psi>_char [of "src\<^sub>C f"] A'.unit_in_hom
by (intro D.comp_in_homI, auto)
have 2: "\<guillemotleft>\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D \<epsilon>' \<cdot>\<^sub>D D.inv (\<Phi> (f, g)): F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
using assms \<Phi>_in_hom [of f g] \<Psi>_char [of "trg\<^sub>C f"] A'.counit_in_hom
by (intro D.comp_in_homI, auto)
obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright> \<and>
F \<eta> = \<Phi> (g, f) \<cdot>\<^sub>D \<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
using assms 1 A'.unit_in_hom \<Phi>_in_hom locally_full by fastforce
have \<eta>': "\<eta>' = D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)"
using assms 1 \<eta> \<Phi>_in_hom \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char D.iso_inv_iso
\<Phi>_components_are_iso \<Psi>_char(2)
D.invert_side_of_triangle(1) [of "F \<eta>" "\<Phi> (g, f)" "\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"]
D.invert_side_of_triangle(2) [of "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta>" \<eta>' "D.inv (\<Psi> (src\<^sub>C f))"]
by (metis (no_types, lifting) C.ideD(1) C.obj_trg D.arrI D.comp_assoc D.inv_inv)
obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C trg\<^sub>C f\<guillemotright> \<and>
F \<epsilon> = \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D \<epsilon>' \<cdot>\<^sub>D D.inv (\<Phi> (f, g))"
using assms 2 A'.counit_in_hom \<Phi>_in_hom locally_full by fastforce
have \<epsilon>': "\<epsilon>' = D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)"
using assms 2 \<epsilon> \<Phi>_in_hom \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char D.iso_inv_iso
\<Psi>_char(2) D.comp_assoc
D.invert_side_of_triangle(1) [of "F \<epsilon>" "\<Psi> (trg\<^sub>C f)" "\<epsilon>' \<cdot>\<^sub>D D.inv (\<Phi> (f, g))"]
D.invert_side_of_triangle(2) [of "D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>" \<epsilon>' "D.inv (\<Phi> (f, g))"]
by (metis (no_types, lifting) C.arrI C.ideD(1) C.obj_trg D.inv_inv \<Phi>_components_are_iso
preserves_arr)
have "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
(D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
using A'.adjunction_in_bicategory_axioms \<eta>' \<epsilon>' by simp
hence "adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
using assms \<eta> \<epsilon> reflects_adjunction by simp
thus ?thesis
using C.adjoint_pair_def by auto
qed
lemma reflects_left_adjoint:
assumes "C.ide f" and "D.is_left_adjoint (F f)"
shows "C.is_left_adjoint f"
proof -
obtain g' where g': "D.adjoint_pair (F f) g'"
using assms D.adjoint_pair_def by auto
obtain g where g: "\<guillemotleft>g : trg\<^sub>C f \<rightarrow>\<^sub>C src\<^sub>C f\<guillemotright> \<and> C.ide g \<and> D.isomorphic (F g) g'"
using assms g' locally_essentially_surjective [of "trg\<^sub>C f" "src\<^sub>C f" g']
D.adjoint_pair_antipar [of "F f" g']
by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : g' \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<phi>"
using g D.isomorphic_def D.isomorphic_symmetric by metis
have "D.adjoint_pair (F f) (F g)"
using assms g g' \<phi> D.adjoint_pair_preserved_by_iso [of "F f" g' "F f" "F f" \<phi> "F g"]
by auto
thus ?thesis
using assms g reflects_adjoint_pair [of f g] D.adjoint_pair_antipar C.in_hhom_def
by auto
qed
lemma reflects_right_adjoint:
assumes "C.ide g" and "D.is_right_adjoint (F g)"
shows "C.is_right_adjoint g"
proof -
obtain f' where f': "D.adjoint_pair f' (F g)"
using assms D.adjoint_pair_def by auto
obtain f where f: "\<guillemotleft>f : trg\<^sub>C g \<rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) f'"
using assms f' locally_essentially_surjective [of "trg\<^sub>C g" "src\<^sub>C g" f']
D.adjoint_pair_antipar [of f' "F g"]
by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f' \<Rightarrow>\<^sub>D F f\<guillemotright> \<and> D.iso \<phi>"
using f D.isomorphic_def D.isomorphic_symmetric by metis
have "D.adjoint_pair (F f) (F g)"
using assms f f' \<phi> D.adjoint_pair_preserved_by_iso [of f' "F g" \<phi> "F f" "F g" "F g"]
by auto
thus ?thesis
using assms f reflects_adjoint_pair [of f g] D.adjoint_pair_antipar C.in_hhom_def
by auto
qed
end
subsection "Composition of Adjunctions"
text \<open>
We first consider the strict case, then extend to all bicategories using strictification.
\<close>
locale composite_adjunction_in_strict_bicategory =
strict_bicategory V H \<a> \<i> src trg +
fg: adjunction_in_strict_bicategory V H \<a> \<i> src trg f g \<zeta> \<xi> +
hk: adjunction_in_strict_bicategory V H \<a> \<i> src trg h k \<sigma> \<tau>
for V :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and f :: "'a"
and g :: "'a"
and \<zeta> :: "'a"
and \<xi> :: "'a"
and h :: "'a"
and k :: "'a"
and \<sigma> :: "'a"
and \<tau> :: "'a" +
assumes composable: "src h = trg f"
begin
abbreviation \<eta>
where "\<eta> \<equiv> (g \<star> \<sigma> \<star> f) \<cdot> \<zeta>"
abbreviation \<epsilon>
where "\<epsilon> \<equiv> \<tau> \<cdot> (h \<star> \<xi> \<star> k)"
interpretation adjunction_data_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
proof
show "ide (h \<star> f)"
using composable by simp
show "ide (g \<star> k)"
using fg.antipar hk.antipar composable by simp
show "\<guillemotleft>\<eta> : src (h \<star> f) \<Rightarrow> (g \<star> k) \<star> h \<star> f\<guillemotright>"
proof
show "\<guillemotleft>\<zeta> : src (h \<star> f) \<Rightarrow> g \<star> f\<guillemotright>"
using fg.antipar hk.antipar composable \<open>ide (h \<star> f)\<close> by auto
show "\<guillemotleft>g \<star> \<sigma> \<star> f : g \<star> f \<Rightarrow> (g \<star> k) \<star> h \<star> f\<guillemotright>"
proof -
have "\<guillemotleft>g \<star> \<sigma> \<star> f : g \<star> trg f \<star> f \<Rightarrow> g \<star> (k \<star> h) \<star> f\<guillemotright>"
using fg.antipar hk.antipar composable hk.unit_in_hom
by (simp add: ide_in_hom(2))
thus ?thesis
using hcomp_obj_arr hcomp_assoc by fastforce
qed
qed
show "\<guillemotleft>\<epsilon> : (h \<star> f) \<star> g \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
proof
show "\<guillemotleft>h \<star> \<xi> \<star> k : (h \<star> f) \<star> g \<star> k \<Rightarrow> h \<star> k\<guillemotright>"
proof -
have "\<guillemotleft>h \<star> \<xi> \<star> k : h \<star> (f \<star> g) \<star> k \<Rightarrow> h \<star> trg f \<star> k\<guillemotright>"
using composable fg.antipar(1-2) hk.antipar(1) by fastforce
thus ?thesis
using fg.antipar hk.antipar composable hk.unit_in_hom hcomp_obj_arr hcomp_assoc
by simp
qed
show "\<guillemotleft>\<tau> : h \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
using fg.antipar hk.antipar composable hk.unit_in_hom by auto
qed
qed
sublocale adjunction_in_strict_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
proof
show "(\<epsilon> \<star> h \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[h \<star> f, g \<star> k, h \<star> f] \<cdot> ((h \<star> f) \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[h \<star> f] \<cdot> \<r>[h \<star> f]"
proof -
have "(\<epsilon> \<star> h \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[h \<star> f, g \<star> k, h \<star> f] \<cdot> ((h \<star> f) \<star> \<eta>) =
(\<tau> \<cdot> (h \<star> \<xi> \<star> k) \<star> h \<star> f) \<cdot> ((h \<star> f) \<star> (g \<star> \<sigma> \<star> f) \<cdot> \<zeta>)"
using fg.antipar hk.antipar composable strict_assoc comp_ide_arr
ide_left ide_right antipar(1) antipar(2)
by (metis arrI seqE strict_assoc' triangle_in_hom(1))
also have "... = (\<tau> \<star> h \<star> f) \<cdot> ((h \<star> \<xi> \<star> (k \<star> h) \<star> f) \<cdot> (h \<star> (f \<star> g) \<star> \<sigma> \<star> f)) \<cdot> (h \<star> f \<star> \<zeta>)"
using fg.antipar hk.antipar composable whisker_left [of "h \<star> f"] whisker_right
comp_assoc hcomp_assoc
by simp
also have "... = (\<tau> \<star> h \<star> f) \<cdot> (h \<star> (\<xi> \<star> (k \<star> h)) \<cdot> ((f \<star> g) \<star> \<sigma>) \<star> f) \<cdot> (h \<star> f \<star> \<zeta>)"
using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
by (simp add: hseqI')
also have "... = (\<tau> \<star> h \<star> f) \<cdot> (h \<star> (trg f \<star> \<sigma>) \<cdot> (\<xi> \<star> trg f) \<star> f) \<cdot> (h \<star> f \<star> \<zeta>)"
using fg.antipar hk.antipar composable comp_arr_dom comp_cod_arr
interchange [of \<xi> "f \<star> g" "k \<star> h" \<sigma>] interchange [of "trg f" \<xi> \<sigma> "trg f"]
by auto
also have "... = (\<tau> \<star> h \<star> f) \<cdot> (h \<star> \<sigma> \<cdot> \<xi> \<star> f) \<cdot> (h \<star> f \<star> \<zeta>)"
using fg.antipar hk.antipar composable hcomp_obj_arr hcomp_arr_obj
by (metis fg.counit_simps(1) fg.counit_simps(4) hk.unit_simps(1) hk.unit_simps(5)
obj_src)
also have "... = ((\<tau> \<star> h \<star> f) \<cdot> (h \<star> \<sigma> \<star> f)) \<cdot> ((h \<star> \<xi> \<star> f) \<cdot> (h \<star> f \<star> \<zeta>))"
using fg.antipar hk.antipar composable whisker_left whisker_right comp_assoc
by (simp add: hseqI')
also have "... = ((\<tau> \<star> h) \<cdot> (h \<star> \<sigma>) \<star> f) \<cdot> (h \<star> (\<xi> \<star> f) \<cdot> (f \<star> \<zeta>))"
using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
by (simp add: hseqI')
also have "... = h \<star> f"
using fg.antipar hk.antipar composable fg.triangle_left hk.triangle_left
by simp
also have "... = \<l>\<^sup>-\<^sup>1[h \<star> f] \<cdot> \<r>[h \<star> f]"
using fg.antipar hk.antipar composable strict_lunit' strict_runit by simp
finally show ?thesis by simp
qed
show "((g \<star> k) \<star> \<epsilon>) \<cdot> \<a>[g \<star> k, h \<star> f, g \<star> k] \<cdot> (\<eta> \<star> g \<star> k) = \<r>\<^sup>-\<^sup>1[g \<star> k] \<cdot> \<l>[g \<star> k]"
proof -
have "((g \<star> k) \<star> \<epsilon>) \<cdot> \<a>[g \<star> k, h \<star> f, g \<star> k] \<cdot> (\<eta> \<star> g \<star> k) =
((g \<star> k) \<star> \<tau> \<cdot> (h \<star> \<xi> \<star> k)) \<cdot> ((g \<star> \<sigma> \<star> f) \<cdot> \<zeta> \<star> g \<star> k)"
using fg.antipar hk.antipar composable strict_assoc comp_ide_arr
ide_left ide_right
by (metis antipar(1) antipar(2) arrI seqE triangle_in_hom(2))
also have "... = (g \<star> k \<star> \<tau>) \<cdot> ((g \<star> (k \<star> h) \<star> \<xi> \<star> k) \<cdot> (g \<star> \<sigma> \<star> (f \<star> g) \<star> k)) \<cdot> (\<zeta> \<star> g \<star> k)"
using fg.antipar hk.antipar composable whisker_left [of "g \<star> k"] whisker_right
comp_assoc hcomp_assoc
by simp
also have "... = (g \<star> k \<star> \<tau>) \<cdot> (g \<star> ((k \<star> h) \<star> \<xi>) \<cdot> (\<sigma> \<star> f \<star> g) \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
by (simp add: hseqI')
also have "... = (g \<star> k \<star> \<tau>) \<cdot> (g \<star> (\<sigma> \<star> src g) \<cdot> (src g \<star> \<xi>) \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
using fg.antipar hk.antipar composable interchange [of "k \<star> h" \<sigma> \<xi> "f \<star> g"]
interchange [of \<sigma> "src g" "src g" \<xi>] comp_arr_dom comp_cod_arr
by simp
also have "... = (g \<star> k \<star> \<tau>) \<cdot> (g \<star> \<sigma> \<cdot> \<xi> \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
using fg.antipar hk.antipar composable hcomp_obj_arr [of "src g" \<xi>]
hcomp_arr_obj [of \<sigma> "src g"]
by simp
also have "... = ((g \<star> k \<star> \<tau>) \<cdot> (g \<star> \<sigma> \<star> k)) \<cdot> (g \<star> \<xi> \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
using fg.antipar hk.antipar composable whisker_left whisker_right comp_assoc
by (simp add: hseqI')
also have "... = (g \<star> (k \<star> \<tau>) \<cdot> (\<sigma> \<star> k)) \<cdot> ((g \<star> \<xi>) \<cdot> (\<zeta> \<star> g) \<star> k)"
using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
by (simp add: hseqI')
also have "... = g \<star> k"
using fg.antipar hk.antipar composable fg.triangle_right hk.triangle_right
by simp
also have "... = \<r>\<^sup>-\<^sup>1[g \<star> k] \<cdot> \<l>[g \<star> k]"
using fg.antipar hk.antipar composable strict_lunit strict_runit' by simp
finally show ?thesis by simp
qed
qed
lemma is_adjunction_in_strict_bicategory:
shows "adjunction_in_strict_bicategory V H \<a> \<i> src trg (h \<star> f) (g \<star> k) \<eta> \<epsilon>"
..
end
context strict_bicategory
begin
lemma left_adjoints_compose:
assumes "is_left_adjoint f" and "is_left_adjoint f'" and "src f' = trg f"
shows "is_left_adjoint (f' \<star> f)"
proof -
obtain g \<eta> \<epsilon> where fg: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret fg: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using fg by auto
obtain g' \<eta>' \<epsilon>' where f'g': "adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'"
using assms adjoint_pair_def by auto
interpret f'g': adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'
using f'g' by auto
interpret f'fgg': composite_adjunction_in_strict_bicategory V H \<a> \<i> src trg
f g \<eta> \<epsilon> f' g' \<eta>' \<epsilon>'
using assms apply unfold_locales by simp
have "adjoint_pair (f' \<star> f) (g \<star> g')"
using adjoint_pair_def f'fgg'.adjunction_in_bicategory_axioms by auto
thus ?thesis by auto
qed
lemma right_adjoints_compose:
assumes "is_right_adjoint g" and "is_right_adjoint g'" and "src g = trg g'"
shows "is_right_adjoint (g \<star> g')"
proof -
obtain f \<eta> \<epsilon> where fg: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret fg: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using fg by auto
obtain f' \<eta>' \<epsilon>' where f'g': "adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'"
using assms adjoint_pair_def by auto
interpret f'g': adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'
using f'g' by auto
interpret f'fgg': composite_adjunction_in_strict_bicategory V H \<a> \<i> src trg
f g \<eta> \<epsilon> f' g' \<eta>' \<epsilon>'
using assms fg.antipar f'g'.antipar apply unfold_locales by simp
have "adjoint_pair (f' \<star> f) (g \<star> g')"
using adjoint_pair_def f'fgg'.adjunction_in_bicategory_axioms by auto
thus ?thesis by auto
qed
end
text \<open>
We now use strictification to extend the preceding results to an arbitrary bicategory.
We only prove that ``left adjoints compose'' and ``right adjoints compose'';
I did not work out formulas for the unit and counit of the composite adjunction in the
non-strict case.
\<close>
context bicategory
begin
interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
notation S.hcomp (infixr "\<star>\<^sub>S" 53)
notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
interpretation UP: fully_faithful_functor V S.vcomp S.UP
using S.UP_is_fully_faithful_functor by auto
interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
using S.UP_is_equivalence_pseudofunctor by auto
lemma left_adjoints_compose:
assumes "is_left_adjoint f" and "is_left_adjoint f'" and "src f = trg f'"
shows "is_left_adjoint (f \<star> f')"
proof -
have "S.is_left_adjoint (S.UP f) \<and> S.is_left_adjoint (S.UP f')"
using assms UP.preserves_left_adjoint by simp
moreover have "S.src (S.UP f) = S.trg (S.UP f')"
using assms left_adjoint_is_ide by simp
ultimately have "S.is_left_adjoint (S.hcomp (S.UP f) (S.UP f'))"
using S.left_adjoints_compose by simp
moreover have "S.isomorphic (S.hcomp (S.UP f) (S.UP f')) (S.UP (f \<star> f'))"
proof -
have "\<guillemotleft>S.\<Phi> (f, f') : S.hcomp (S.UP f) (S.UP f') \<Rightarrow>\<^sub>S S.UP (f \<star> f')\<guillemotright>"
using assms left_adjoint_is_ide UP.\<Phi>_in_hom by simp
moreover have "S.iso (S.\<Phi> (f, f'))"
using assms left_adjoint_is_ide by simp
ultimately show ?thesis
using S.isomorphic_def by blast
qed
ultimately have "S.is_left_adjoint (S.UP (f \<star> f'))"
using S.left_adjoint_preserved_by_iso S.isomorphic_def by blast
thus "is_left_adjoint (f \<star> f')"
using assms left_adjoint_is_ide UP.reflects_left_adjoint by simp
qed
lemma right_adjoints_compose:
assumes "is_right_adjoint g" and "is_right_adjoint g'" and "src g' = trg g"
shows "is_right_adjoint (g' \<star> g)"
proof -
have "S.is_right_adjoint (S.UP g) \<and> S.is_right_adjoint (S.UP g')"
using assms UP.preserves_right_adjoint by simp
moreover have "S.src (S.UP g') = S.trg (S.UP g)"
using assms right_adjoint_is_ide by simp
ultimately have "S.is_right_adjoint (S.hcomp (S.UP g') (S.UP g))"
using S.right_adjoints_compose by simp
moreover have "S.isomorphic (S.hcomp (S.UP g') (S.UP g)) (S.UP (g' \<star> g))"
proof -
have "\<guillemotleft>S.\<Phi> (g', g) : S.hcomp (S.UP g') (S.UP g) \<Rightarrow>\<^sub>S S.UP (g' \<star> g)\<guillemotright>"
using assms right_adjoint_is_ide UP.\<Phi>_in_hom by simp
moreover have "S.iso (S.\<Phi> (g', g))"
using assms right_adjoint_is_ide by simp
ultimately show ?thesis
using S.isomorphic_def by blast
qed
ultimately have "S.is_right_adjoint (S.UP (g' \<star> g))"
using S.right_adjoint_preserved_by_iso S.isomorphic_def by blast
thus "is_right_adjoint (g' \<star> g)"
using assms right_adjoint_is_ide UP.reflects_right_adjoint by simp
qed
end
subsection "Choosing Right Adjoints"
text \<open>
It will be useful in various situations to suppose that we have made a choice of
right adjoint for each left adjoint ({\it i.e.} each ``map'') in a bicategory.
\<close>
locale chosen_right_adjoints =
bicategory
begin
(* Global notation is evil! *)
no_notation Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)
definition some_right_adjoint ("_\<^sup>*" [1000] 1000)
where "f\<^sup>* \<equiv> SOME g. adjoint_pair f g"
definition some_unit
where "some_unit f \<equiv> SOME \<eta>. \<exists>\<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* \<eta> \<epsilon>"
definition some_counit
where "some_counit f \<equiv>
SOME \<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* (some_unit f) \<epsilon>"
lemma left_adjoint_extends_to_adjunction:
assumes "is_left_adjoint f"
shows "adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* (some_unit f) (some_counit f)"
using assms some_right_adjoint_def adjoint_pair_def some_unit_def some_counit_def
someI_ex [of "\<lambda>g. adjoint_pair f g"]
someI_ex [of "\<lambda>\<eta>. \<exists>\<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* \<eta> \<epsilon>"]
someI_ex [of "\<lambda>\<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* (some_unit f) \<epsilon>"]
by auto
lemma left_adjoint_extends_to_adjoint_pair:
assumes "is_left_adjoint f"
shows "adjoint_pair f f\<^sup>*"
using assms adjoint_pair_def left_adjoint_extends_to_adjunction by blast
lemma right_adjoint_in_hom [intro]:
assumes "is_left_adjoint f"
shows "\<guillemotleft>f\<^sup>* : trg f \<rightarrow> src f\<guillemotright>"
and "\<guillemotleft>f\<^sup>* : f\<^sup>* \<Rightarrow> f\<^sup>*\<guillemotright>"
using assms left_adjoint_extends_to_adjoint_pair adjoint_pair_antipar [of f "f\<^sup>*"]
by auto
lemma right_adjoint_simps [simp]:
assumes "is_left_adjoint f"
shows "ide f\<^sup>*"
and "src f\<^sup>* = trg f" and "trg f\<^sup>* = src f"
and "dom f\<^sup>* = f\<^sup>*" and "cod f\<^sup>* = f\<^sup>*"
using assms right_adjoint_in_hom left_adjoint_extends_to_adjoint_pair apply auto
using assms right_adjoint_is_ide [of "f\<^sup>*"] by blast
end
locale map_in_bicategory =
bicategory + chosen_right_adjoints +
fixes f :: 'a
assumes is_map: "is_left_adjoint f"
begin
abbreviation \<eta>
where "\<eta> \<equiv> some_unit f"
abbreviation \<epsilon>
where "\<epsilon> \<equiv> some_counit f"
sublocale adjunction_in_bicategory V H \<a> \<i> src trg f \<open>f\<^sup>*\<close> \<eta> \<epsilon>
using is_map left_adjoint_extends_to_adjunction by simp
end
subsection "Equivalences Refine to Adjoint Equivalences"
text \<open>
In this section, we show that, just as an equivalence between categories can always
be refined to an adjoint equivalence, an internal equivalence in a bicategory can also
always be so refined.
The proof, which follows that of Theorem 3.3 from \cite{nlab-adjoint-equivalence},
makes use of the fact that if an internal equivalence satisfies one of the triangle
identities, then it also satisfies the other.
\<close>
locale adjoint_equivalence_in_bicategory =
equivalence_in_bicategory +
adjunction_in_bicategory
begin
lemma dual_adjoint_equivalence:
shows "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
proof -
interpret gf: equivalence_in_bicategory V H \<a> \<i> src trg g f \<open>inv \<epsilon>\<close> \<open>inv \<eta>\<close>
using dual_equivalence by simp
show ?thesis
proof
show "(inv \<eta> \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[g, f, g] \<cdot> (g \<star> inv \<epsilon>) = \<l>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]"
proof -
have "(inv \<eta> \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[g, f, g] \<cdot> (g \<star> inv \<epsilon>) =
inv ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g))"
using antipar inv_comp counit_is_iso iso_inv_iso isos_compose unit_is_iso
comp_assoc hseqI'
by simp
also have "... = inv (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g])"
using triangle_right by simp
also have "... = \<l>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]"
using iso_lunit iso_runit iso_inv_iso inv_comp by simp
finally show ?thesis
by blast
qed
show "(f \<star> inv \<eta>) \<cdot> \<a>[f, g, f] \<cdot> (inv \<epsilon> \<star> f) = \<r>\<^sup>-\<^sup>1[f] \<cdot> \<l>[f]"
proof -
have "(f \<star> inv \<eta>) \<cdot> \<a>[f, g, f] \<cdot> (inv \<epsilon> \<star> f) =
inv ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>))"
using antipar inv_comp counit_is_iso iso_inv_iso isos_compose unit_is_iso
comp_assoc hseqI'
by simp
also have "... = inv (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
using triangle_left by simp
also have "... = \<r>\<^sup>-\<^sup>1[f] \<cdot> \<l>[f]"
using iso_lunit iso_runit iso_inv_iso inv_comp by simp
finally show ?thesis by blast
qed
qed
qed
end
context strict_bicategory
begin
lemma equivalence_refines_to_adjoint_equivalence:
assumes "equivalence_map f" and "\<guillemotleft>g : trg f \<rightarrow> src f\<guillemotright>" and "ide g"
and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>" and "iso \<eta>"
shows "\<exists>!\<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
proof -
obtain g' \<eta>' \<epsilon>' where E': "equivalence_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'"
using assms equivalence_map_def by auto
interpret E': equivalence_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'
using E' by auto
let ?a = "src f" and ?b = "trg f"
(* TODO: in_homE cannot be applied automatically to a conjunction. Must break down! *)
have f_in_hhom: "\<guillemotleft>f : ?a \<rightarrow> ?b\<guillemotright>" and ide_f: "ide f"
using assms equivalence_map_def by auto
have g_in_hhom: "\<guillemotleft>g : ?b \<rightarrow> ?a\<guillemotright>" and ide_g: "ide g"
using assms by auto
have g'_in_hhom: "\<guillemotleft>g' : ?b \<rightarrow> ?a\<guillemotright>" and ide_g': "ide g'"
using assms f_in_hhom E'.antipar by auto
have \<eta>_in_hom: "\<guillemotleft>\<eta> : ?a \<Rightarrow> g \<star> f\<guillemotright>" and iso_\<eta>: "iso \<eta>"
using assms by auto
have a: "obj ?a" and b: "obj ?b"
using f_in_hhom by auto
have \<eta>_in_hhom: "\<guillemotleft>\<eta> : ?a \<rightarrow> ?a\<guillemotright>"
using a src_dom trg_dom \<eta>_in_hom by fastforce
text \<open>
The following is quoted from \cite{nlab-adjoint-equivalence}:
\begin{quotation}
``Since \<open>g \<cong> gfg' \<cong> g'\<close>, the isomorphism \<open>fg' \<cong> 1\<close> also induces an isomorphism \<open>fg \<cong> 1\<close>,
which we denote \<open>\<xi>\<close>. Now \<open>\<eta>\<close> and \<open>\<xi>\<close> may not satisfy the zigzag identities, but if we
define \<open>\<epsilon>\<close> by \<open>\<xi> \<cdot> (f \<star> \<eta>\<^sup>-\<^sup>1) \<cdot> (f \<star> g \<star> \<xi>\<^sup>-\<^sup>1) : f \<star> g \<Rightarrow> 1\<close>, then we can verify,
using string diagram notation as above,
that \<open>\<epsilon>\<close> satisfies one zigzag identity, and hence (by the previous lemma) also the other.
Finally, if \<open>\<epsilon>': fg \<Rightarrow> 1\<close> is any other isomorphism satisfying the zigzag identities
with \<open>\<eta>\<close>, then we have:
\[
\<open>\<epsilon>' = \<epsilon>' \<cdot> (\<epsilon> f g) \<cdot> (f \<eta> g) = \<epsilon> \<cdot> (f g \<epsilon>') \<cdot> (f \<eta> g) = \<epsilon>\<close>
\]
using the interchange law and two zigzag identities. This shows uniqueness.''
\end{quotation}
\<close>
have 1: "isomorphic g g'"
proof -
have "isomorphic g (g \<star> ?b)"
using assms hcomp_arr_obj isomorphic_reflexive by auto
also have "isomorphic ... (g \<star> f \<star> g')"
using assms f_in_hhom g_in_hhom g'_in_hhom E'.counit_in_vhom E'.counit_is_iso
isomorphic_def hcomp_ide_isomorphic isomorphic_symmetric
by (metis E'.counit_simps(5) in_hhomE trg_trg)
also have "isomorphic ... (?a \<star> g')"
using assms f_in_hhom g_in_hhom g'_in_hhom ide_g' E'.unit_in_vhom E'.unit_is_iso
isomorphic_def hcomp_isomorphic_ide isomorphic_symmetric
by (metis hcomp_assoc hcomp_isomorphic_ide in_hhomE src_src)
also have "isomorphic ... g'"
using assms
by (simp add: E'.antipar(1) hcomp_obj_arr isomorphic_reflexive)
finally show ?thesis by blast
qed
moreover have "isomorphic (f \<star> g') ?b"
using E'.counit_is_iso isomorphicI [of \<epsilon>'] by auto
hence 2: "isomorphic (f \<star> g) ?b"
using assms 1 ide_f hcomp_ide_isomorphic [of f g g'] isomorphic_transitive
isomorphic_symmetric
by (metis in_hhomE)
obtain \<xi> where \<xi>: "\<guillemotleft>\<xi> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> iso \<xi>"
using 2 by auto
have \<xi>_in_hom: "\<guillemotleft>\<xi> : f \<star> g \<Rightarrow> ?b\<guillemotright>" and iso_\<xi>: "iso \<xi>"
using \<xi> by auto
have \<xi>_in_hhom: "\<guillemotleft>\<xi> : ?b \<rightarrow> ?b\<guillemotright>"
using b src_cod trg_cod \<xi>_in_hom by fastforce
text \<open>
At the time of this writing, the definition of \<open>\<epsilon>\<close> given on nLab
\cite{nlab-adjoint-equivalence} had an apparent typo:
the expression \<open>f \<star> g \<star> \<xi>\<^sup>-\<^sup>1\<close> should read \<open>\<xi>\<^sup>-\<^sup>1 \<star> f \<star> g\<close>, as we have used here.
\<close>
let ?\<epsilon> = "\<xi> \<cdot> (f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g)"
have \<epsilon>_in_hom: "\<guillemotleft>?\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright>"
proof -
have "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> g \<star> f \<star> g \<Rightarrow> f \<star> g\<guillemotright>"
proof -
have "\<guillemotleft>inv \<eta> : g \<star> f \<Rightarrow> ?a\<guillemotright>"
using \<eta>_in_hom iso_\<eta> by auto
hence "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> (g \<star> f) \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
using assms by (intro hcomp_in_vhom, auto)
hence "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> (g \<star> f) \<star> g \<Rightarrow> f \<star> g\<guillemotright>"
using assms f_in_hhom hcomp_obj_arr by (metis in_hhomE)
moreover have "f \<star> (g \<star> f) \<star> g = f \<star> g \<star> f \<star> g"
using hcomp_assoc by simp
ultimately show ?thesis by simp
qed
moreover have "\<guillemotleft>inv \<xi> \<star> f \<star> g : f \<star> g \<Rightarrow> f \<star> g \<star> f \<star> g\<guillemotright>"
proof -
have "\<guillemotleft>inv \<xi> \<star> f \<star> g : ?b \<star> f \<star> g \<Rightarrow> (f \<star> g) \<star> f \<star> g\<guillemotright>"
using assms \<xi>_in_hom iso_\<xi> by (intro hcomp_in_vhom, auto)
moreover have "(f \<star> g) \<star> f \<star> g = f \<star> g \<star> f \<star> g"
using hcomp_assoc by simp
moreover have "?b \<star> f \<star> g = f \<star> g"
using f_in_hhom g_in_hhom b hcomp_obj_arr [of ?b "f \<star> g"] hseqI' by fastforce
ultimately show ?thesis by simp
qed
ultimately show "\<guillemotleft>?\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright>"
using \<xi>_in_hom by blast
qed
have "iso ?\<epsilon>"
using f_in_hhom g_in_hhom \<eta>_in_hhom ide_f ide_g \<eta>_in_hom iso_\<eta> \<xi>_in_hhom \<xi>_in_hom iso_\<xi>
iso_inv_iso hseqI'
apply (intro isos_compose)
apply auto
apply fastforce
apply fastforce
proof -
have 1: "\<guillemotleft>(f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g) : ?b \<star> f \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
proof
have "\<guillemotleft>inv \<xi> \<star> f \<star> g : ?b \<star> f \<star> g \<Rightarrow> (f \<star> g) \<star> f \<star> g\<guillemotright>"
using f_in_hhom g_in_hhom ide_f ide_g \<xi>_in_hhom \<xi>_in_hom iso_\<xi>
by (intro hcomp_in_vhom, auto)
thus "\<guillemotleft>inv \<xi> \<star> f \<star> g : ?b \<star> f \<star> g \<Rightarrow> f \<star> g \<star> f \<star> g\<guillemotright>"
using hcomp_assoc by simp
have "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> (g \<star> f) \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
using f_in_hhom g_in_hhom ide_f ide_g \<eta>_in_hhom \<eta>_in_hom iso_\<eta>
by (intro hcomp_in_vhom, auto)
thus "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> g \<star> f \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
using hcomp_assoc by simp
qed
show "seq (f \<star> inv \<eta> \<star> g) (inv \<xi> \<star> f \<star> g)"
using 1 by auto
show "seq \<xi> ((f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g))"
proof -
have "f \<star> ?a \<star> g = f \<star> g"
using a f_in_hhom g_in_hhom hcomp_obj_arr by fastforce
thus ?thesis
using 1 \<xi>_in_hom by auto
qed
qed
have 4: "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> f \<star> g \<star> f\<guillemotright>"
proof -
have "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> (f \<star> g) \<star> f\<guillemotright>"
using \<xi>_in_hom iso_\<xi> f_in_hhom
by (intro hcomp_in_vhom, auto)
thus ?thesis
using hcomp_assoc by simp
qed
text \<open>
First show \<open>?\<epsilon>\<close> and \<open>\<eta>\<close> satisfy the ``left'' triangle identity.
\<close>
have triangle_left: "(?\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
proof -
have "(?\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = (\<xi> \<star> f) \<cdot> (f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (inv \<xi> \<star> f \<star> g \<star> f) \<cdot> (?b \<star> f \<star> \<eta>)"
proof -
have "f \<star> \<eta> = ?b \<star> f \<star> \<eta>"
using b \<eta>_in_hhom hcomp_obj_arr [of ?b "f \<star> \<eta>"] hseqI' by fastforce
moreover have "\<xi> \<cdot> (f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g) \<star> f =
(\<xi> \<star> f) \<cdot> ((f \<star> inv \<eta> \<star> g) \<star> f) \<cdot> ((inv \<xi> \<star> f \<star> g) \<star> f)"
using ide_f ide_g \<xi>_in_hhom \<xi>_in_hom iso_\<xi> \<eta>_in_hhom \<eta>_in_hom iso_\<eta> whisker_right
by (metis \<epsilon>_in_hom arrI in_hhomE seqE)
moreover have "... = (\<xi> \<star> f) \<cdot> (f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (inv \<xi> \<star> f \<star> g \<star> f)"
using hcomp_assoc by simp
ultimately show ?thesis
using comp_assoc by simp
qed
also have "... = (\<xi> \<star> f) \<cdot> ((f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (f \<star> g \<star> f \<star> \<eta>)) \<cdot> (inv \<xi> \<star> f)"
proof -
have "((inv \<xi> \<star> f) \<star> (g \<star> f)) \<cdot> ((?b \<star> f) \<star> \<eta>) = (inv \<xi> \<star> f) \<cdot> (?b \<star> f) \<star> (g \<star> f) \<cdot> \<eta>"
proof -
have "seq (inv \<xi> \<star> f) (?b \<star> f)"
using a b 4 ide_f ide_g \<xi>_in_hhom \<xi>_in_hom iso_\<xi> \<eta>_in_hhom \<eta>_in_hom iso_\<eta>
by blast
moreover have "seq (g \<star> f) \<eta>"
using f_in_hhom g_in_hhom ide_g ide_f \<eta>_in_hom by fast
ultimately show ?thesis
using interchange [of "inv \<xi> \<star> f" "?b \<star> f" "g \<star> f" \<eta>] by simp
qed
also have "... = inv \<xi> \<star> f \<star> \<eta>"
proof -
have "(inv \<xi> \<star> f) \<cdot> (?b \<star> f) = inv \<xi> \<star> f"
using 4 comp_arr_dom by auto
moreover have "(g \<star> f) \<cdot> \<eta> = \<eta>"
using \<eta>_in_hom comp_cod_arr by auto
ultimately show ?thesis
using hcomp_assoc by simp
qed
also have "... = (f \<star> g) \<cdot> inv \<xi> \<star> (f \<star> \<eta>) \<cdot> (f \<star> ?a)"
proof -
have "(f \<star> g) \<cdot> inv \<xi> = inv \<xi>"
using \<xi>_in_hom iso_\<xi> comp_cod_arr by auto
moreover have "(f \<star> \<eta>) \<cdot> (f \<star> ?a) = f \<star> \<eta>"
proof -
have "\<guillemotleft>f \<star> \<eta> : f \<star> ?a \<Rightarrow> f \<star> g \<star> f\<guillemotright>"
using \<eta>_in_hom by fastforce
thus ?thesis
using comp_arr_dom by blast
qed
ultimately show ?thesis by argo
qed
also have "... = ((f \<star> g) \<star> (f \<star> \<eta>)) \<cdot> (inv \<xi> \<star> (f \<star> ?a))"
proof -
have "seq (f \<star> g) (inv \<xi>)"
using \<xi>_in_hom iso_\<xi> comp_cod_arr by auto
moreover have "seq (f \<star> \<eta>) (f \<star> ?a)"
using f_in_hhom \<eta>_in_hom by force
ultimately show ?thesis
using interchange by simp
qed
also have "... = (f \<star> g \<star> f \<star> \<eta>) \<cdot> (inv \<xi> \<star> f)"
using hcomp_arr_obj hcomp_assoc by auto
finally have "((inv \<xi> \<star> f) \<star> (g \<star> f)) \<cdot> ((?b \<star> f) \<star> \<eta>) = (f \<star> g \<star> f \<star> \<eta>) \<cdot> (inv \<xi> \<star> f)"
by simp
thus ?thesis
using comp_assoc hcomp_assoc by simp
qed
also have "... = (\<xi> \<star> f) \<cdot> ((f \<star> ?a \<star> \<eta>) \<cdot> (f \<star> inv \<eta> \<star> ?a)) \<cdot> (inv \<xi> \<star> f)"
proof -
have "(f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) = f \<star> (inv \<eta> \<star> g \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>)"
proof -
have "seq ((inv \<eta> \<star> g) \<star> f) ((g \<star> f) \<star> \<eta>)"
proof -
have "seq (inv \<eta> \<star> g \<star> f) ((g \<star> f) \<star> \<eta>)"
using f_in_hhom ide_f g_in_hhom ide_g \<eta>_in_hhom \<eta>_in_hom iso_\<eta> hseqI'
apply (intro seqI)
apply blast
apply blast
by fastforce
thus ?thesis
using hcomp_assoc by simp
qed
hence "(f \<star> (inv \<eta> \<star> g) \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) =
f \<star> ((inv \<eta> \<star> g) \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>)"
using whisker_left by simp
thus ?thesis
using hcomp_assoc by simp
qed
also have "... = f \<star> (?a \<star> \<eta>) \<cdot> (inv \<eta> \<star> ?a)"
proof -
have "(inv \<eta> \<star> g \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>) = (?a \<star> \<eta>) \<cdot> (inv \<eta> \<star> ?a)"
proof -
have "(inv \<eta> \<star> g \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>) = inv \<eta> \<cdot> (g \<star> f) \<star> (g \<star> f) \<cdot> \<eta>"
proof -
have "seq (inv \<eta>) (g \<star> f)"
using g_in_hhom ide_g \<eta>_in_hom iso_\<eta> by force
moreover have "seq (g \<star> f) \<eta>"
using g_in_hhom ide_g \<eta>_in_hom by fastforce
ultimately show ?thesis
using interchange by fastforce
qed
also have "... = inv \<eta> \<star> \<eta>"
using \<eta>_in_hom iso_\<eta> comp_arr_dom comp_cod_arr by auto
also have "... = ?a \<cdot> inv \<eta> \<star> \<eta> \<cdot> ?a"
using \<eta>_in_hom iso_\<eta> comp_arr_dom comp_cod_arr by auto
also have "... = (?a \<star> \<eta>) \<cdot> (inv \<eta> \<star> ?a)"
proof -
have "seq ?a (inv \<eta>)"
using a \<eta>_in_hom iso_\<eta> ideD [of ?a] by (elim objE, auto)
moreover have "seq \<eta> ?a"
using a \<eta>_in_hom by fastforce
ultimately show ?thesis
using interchange by blast
qed
finally show ?thesis by simp
qed
thus ?thesis by argo
qed
also have "... = (f \<star> ?a \<star> \<eta>) \<cdot> (f \<star> inv \<eta> \<star> ?a)"
proof -
have "seq (?a \<star> \<eta>) (inv \<eta> \<star> ?a)"
proof (intro seqI')
show "\<guillemotleft>inv \<eta> \<star> ?a : (g \<star> f) \<star> ?a \<Rightarrow> ?a \<star> ?a\<guillemotright>"
using a g_in_hhom \<eta>_in_hom iso_\<eta> hseqI ide_f ide_g
apply (elim in_homE in_hhomE, intro hcomp_in_vhom)
by auto
show "\<guillemotleft>?a \<star> \<eta> : ?a \<star> ?a \<Rightarrow> ?a \<star> g \<star> f\<guillemotright>"
using a \<eta>_in_hom hseqI by (intro hcomp_in_vhom, auto)
qed
thus ?thesis
using whisker_left by simp
qed
finally show ?thesis
using hcomp_assoc by simp
qed
also have "... = (\<xi> \<star> f) \<cdot> ((f \<star> \<eta>) \<cdot> (f \<star> inv \<eta>)) \<cdot> (inv \<xi> \<star> f)"
using a \<eta>_in_hhom iso_\<eta> hcomp_obj_arr [of ?a \<eta>] hcomp_arr_obj [of "inv \<eta>" ?a] by auto
also have "... = (\<xi> \<star> f) \<cdot> (inv \<xi> \<star> f)"
proof -
have "(f \<star> \<eta>) \<cdot> (f \<star> inv \<eta>) = f \<star> \<eta> \<cdot> inv \<eta>"
using \<eta>_in_hhom iso_\<eta> whisker_left inv_in_hom by auto
moreover have "f \<star> \<eta> \<cdot> inv \<eta> = f \<star> g \<star> f"
using \<eta>_in_hom iso_\<eta> comp_arr_inv inv_is_inverse by auto
moreover have "(f \<star> g \<star> f) \<cdot> (inv \<xi> \<star> f) = inv \<xi> \<star> f"
proof -
have "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> f \<star> g \<star> f\<guillemotright>"
proof -
have "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> (f \<star> g) \<star> f\<guillemotright>"
using \<xi>_in_hom iso_\<xi> by (intro hcomp_in_vhom, auto)
thus ?thesis
using hcomp_assoc by simp
qed
moreover have "f \<star> g \<star> f = cod (inv \<xi> \<star> f)"
using \<xi>_in_hhom iso_\<xi> hcomp_assoc hseqI' calculation by auto
ultimately show ?thesis
using comp_cod_arr by auto
qed
ultimately show ?thesis by simp
qed
also have "... = ?b \<star> f"
proof -
have "(\<xi> \<star> f) \<cdot> (inv \<xi> \<star> f) = \<xi> \<cdot> inv \<xi> \<star> f"
using \<xi>_in_hhom iso_\<xi> whisker_right by auto
moreover have "\<xi> \<cdot> inv \<xi> = ?b"
using \<xi>_in_hom iso_\<xi> comp_arr_inv inv_is_inverse by auto
ultimately show ?thesis by simp
qed
also have "... = f"
using hcomp_obj_arr by auto
finally show ?thesis by blast
qed
(* TODO: Putting this earlier breaks some steps in the proof. *)
interpret E: equivalence_in_strict_bicategory V H \<a> \<i> src trg f g \<eta> ?\<epsilon>
using ide_g \<eta>_in_hom \<epsilon>_in_hom g_in_hhom `iso \<eta>` `iso ?\<epsilon>`
by (unfold_locales, auto)
text \<open>
Apply ``triangle left if and only iff right'' to show the ``right'' triangle identity.
\<close>
have triangle_right: "((g \<star> \<xi> \<cdot> (f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g)) \<cdot> (\<eta> \<star> g) = g)"
using triangle_left E.triangle_left_iff_right by simp
text \<open>
Use the two triangle identities to establish an adjoint equivalence and show that
there is only one choice for the counit.
\<close>
show "\<exists>!\<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
proof -
have "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> ?\<epsilon>"
proof
show "(?\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
proof -
have "(?\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = (?\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)"
proof -
have "seq \<a>\<^sup>-\<^sup>1[f, g, f] (f \<star> \<eta>)"
using E.antipar hseqI'
by (intro seqI hseqI, auto)
hence "\<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = f \<star> \<eta>"
using ide_f ide_g E.antipar triangle_right strict_assoc' comp_ide_arr hseqI'
by presburger
thus ?thesis by simp
qed
also have "... = f"
using triangle_left by simp
also have "... = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
using strict_lunit strict_runit by simp
finally show ?thesis by simp
qed
show "(g \<star> ?\<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
proof -
have "(g \<star> ?\<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = (g \<star> ?\<epsilon>) \<cdot> (\<eta> \<star> g)"
proof -
have "seq \<a>[g, f, g] (\<eta> \<star> g)"
using E.antipar hseqI'
by (intro seqI hseqI, auto)
hence "\<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<eta> \<star> g"
using ide_f ide_g E.antipar triangle_right strict_assoc comp_ide_arr hseqI'
by presburger
thus ?thesis by simp
qed
also have "... = g"
using triangle_right by simp
also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
using strict_lunit strict_runit by simp
finally show ?thesis by blast
qed
qed
moreover have "\<And>\<epsilon> \<epsilon>'. \<lbrakk> adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>;
adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>' \<rbrakk>
\<Longrightarrow> \<epsilon> = \<epsilon>'"
using adjunction_unit_determines_counit
by (meson adjoint_equivalence_in_bicategory.axioms(2))
ultimately show ?thesis by auto
qed
qed
end
text \<open>
We now apply strictification to generalize the preceding result to an arbitrary bicategory.
\<close>
context bicategory
begin
interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
notation S.hcomp (infixr "\<star>\<^sub>S" 53)
notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
interpretation UP: fully_faithful_functor V S.vcomp S.UP
using S.UP_is_fully_faithful_functor by auto
interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
using S.UP_is_equivalence_pseudofunctor by auto
interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
..
lemma equivalence_refines_to_adjoint_equivalence:
assumes "equivalence_map f" and "\<guillemotleft>g : trg f \<rightarrow> src f\<guillemotright>" and "ide g"
and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>" and "iso \<eta>"
shows "\<exists>!\<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
proof -
text \<open>
To unpack the consequences of the assumptions, we need to obtain an
interpretation of @{locale equivalence_in_bicategory}, even though we don't
need the associated data other than \<open>f\<close>, \<open>a\<close>, and \<open>b\<close>.
\<close>
obtain g' \<phi> \<psi> where E: "equivalence_in_bicategory V H \<a> \<i> src trg f g' \<phi> \<psi>"
using assms equivalence_map_def by auto
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g' \<phi> \<psi>
using E by auto
let ?a = "src f" and ?b = "trg f"
have ide_f: "ide f" by simp
have f_in_hhom: "\<guillemotleft>f : ?a \<rightarrow> ?b\<guillemotright>" by simp
have a: "obj ?a" and b: "obj ?b" by auto
have 1: "S.equivalence_map (S.UP f)"
using assms UP.preserves_equivalence_maps by simp
let ?\<eta>' = "S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a"
have 2: "\<guillemotleft>S.UP \<eta> : S.UP ?a \<Rightarrow>\<^sub>S S.UP (g \<star> f)\<guillemotright>"
using assms UP.preserves_hom [of \<eta> "src f" "g \<star> f"] by auto
have 4: "\<guillemotleft>?\<eta>' : UP.map\<^sub>0 ?a \<Rightarrow>\<^sub>S S.UP g \<star>\<^sub>S S.UP f\<guillemotright> \<and> S.iso ?\<eta>'"
proof (intro S.comp_in_homI conjI)
have 3: "S.iso (S.\<Phi> (g, f))"
using assms UP.\<Phi>_components_are_iso by auto
show "\<guillemotleft>S.inv (S.\<Phi> (g, f)) : S.UP (g \<star> f) \<Rightarrow>\<^sub>S S.UP g \<star>\<^sub>S S.UP f\<guillemotright>"
using assms 3 UP.\<Phi>_in_hom(2) [of g f] UP.FF_def by auto
moreover show "\<guillemotleft>UP.\<Psi> ?a : UP.map\<^sub>0 ?a \<Rightarrow>\<^sub>S S.UP ?a\<guillemotright>" by auto
moreover show "\<guillemotleft>S.UP \<eta> : S.UP ?a \<Rightarrow>\<^sub>S S.UP (g \<star> f)\<guillemotright>"
using 2 by simp
ultimately show "S.iso (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a)"
using assms 3 a UP.\<Psi>_char(2) S.iso_inv_iso
apply (intro S.isos_compose) by auto
qed
have ex_un_\<xi>': "\<exists>!\<xi>'. adjoint_equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
(S.UP f) (S.UP g) ?\<eta>' \<xi>'"
proof -
have "\<guillemotleft>S.UP g : S.trg (S.UP f) \<rightarrow>\<^sub>S S.src (S.UP f)\<guillemotright>"
using assms(2) by auto
moreover have "S.ide (S.UP g)"
by (simp add: assms(3))
ultimately show ?thesis
using 1 4 S.equivalence_refines_to_adjoint_equivalence S.UP_map\<^sub>0_obj by simp
qed
obtain \<xi>' where \<xi>': "adjoint_equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
(S.UP f) (S.UP g) ?\<eta>' \<xi>'"
using ex_un_\<xi>' by auto
interpret E': adjoint_equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
\<open>S.UP f\<close> \<open>S.UP g\<close> ?\<eta>' \<xi>'
using \<xi>' by auto
let ?\<epsilon>' = "UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g))"
have \<epsilon>': "\<guillemotleft>?\<epsilon>' : S.UP (f \<star> g) \<Rightarrow>\<^sub>S S.UP ?b\<guillemotright>"
- using assms S.UP_map\<^sub>0_obj apply (intro S.in_homI) by auto
+ using assms(2-3) S.UP_map\<^sub>0_obj apply (intro S.in_homI) by auto
have ex_un_\<epsilon>: "\<exists>!\<epsilon>. \<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> S.UP \<epsilon> = ?\<epsilon>'"
proof -
have "\<exists>\<epsilon>. \<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> S.UP \<epsilon> = ?\<epsilon>'"
proof -
have "src (f \<star> g) = src ?b \<and> trg (f \<star> g) = trg ?b"
proof -
have "arr (f \<star> g)"
using assms(2) f_in_hhom by blast
thus ?thesis
using assms(2) f_in_hhom by (elim hseqE, auto)
qed
- thus ?thesis
- using assms(2-3) b \<epsilon>' UP.locally_full by auto
+ moreover have "ide (f \<star> g)"
+ using assms(2-3) by auto
+ ultimately show ?thesis
+ using \<epsilon>' UP.locally_full by auto
qed
moreover have
"\<And>\<mu> \<nu>. \<lbrakk> \<guillemotleft>\<mu> : f \<star> g \<Rightarrow> ?b\<guillemotright>; S.UP \<mu> = ?\<epsilon>'; \<guillemotleft>\<nu> : f \<star> g \<Rightarrow> ?b\<guillemotright>; S.UP \<nu> = ?\<epsilon>' \<rbrakk>
\<Longrightarrow> \<mu> = \<nu>"
proof -
fix \<mu> \<nu>
assume \<mu>: "\<guillemotleft>\<mu> : f \<star> g \<Rightarrow> ?b\<guillemotright>" and \<nu>: "\<guillemotleft>\<nu> : f \<star> g \<Rightarrow> ?b\<guillemotright>"
and 1: "S.UP \<mu> = ?\<epsilon>'" and 2: "S.UP \<nu> = ?\<epsilon>'"
have "par \<mu> \<nu>"
using \<mu> \<nu> by fastforce
thus "\<mu> = \<nu>"
using 1 2 UP.is_faithful [of \<mu> \<nu>] by simp
qed
ultimately show ?thesis by auto
qed
have iso_\<epsilon>': "S.iso ?\<epsilon>'"
proof (intro S.isos_compose)
show "S.iso (S.inv (S.\<Phi> (f, g)))"
using assms UP.\<Phi>_components_are_iso S.iso_inv_iso by auto
show "S.iso \<xi>'"
using E'.counit_is_iso by blast
show "S.iso (UP.\<Psi> ?b)"
using b UP.\<Psi>_char(2) by simp
show "S.seq (UP.\<Psi> ?b) (\<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)))"
proof (intro S.seqI')
show "\<guillemotleft>UP.\<Psi> ?b : UP.map\<^sub>0 ?b \<Rightarrow>\<^sub>S S.UP ?b\<guillemotright>"
using b UP.\<Psi>_char by simp
show "\<guillemotleft>\<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)) : S.UP (f \<star> g) \<Rightarrow>\<^sub>S UP.map\<^sub>0 ?b\<guillemotright>"
using assms UP.\<Phi>_components_are_iso VV.arr_char S.\<Phi>_in_hom [of "(f, g)"]
E'.counit_in_hom S.UP_map\<^sub>0_obj
apply (intro S.comp_in_homI) by auto
qed
thus "S.seq \<xi>' (S.inv (S.\<Phi> (f, g)))" by auto
qed
obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> S.UP \<epsilon> = ?\<epsilon>'"
using ex_un_\<epsilon> by auto
interpret E'': equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
- using assms \<epsilon> iso_\<epsilon>' UP.reflects_iso apply unfold_locales by auto
+ using assms(1,3-5)
+ apply unfold_locales
+ apply simp_all
+ using assms(2) \<epsilon>
+ apply auto[1]
+ using \<epsilon> iso_\<epsilon>' UP.reflects_iso [of \<epsilon>]
+ by auto
interpret E'': adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
proof
show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
proof -
have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
using E''.UP_triangle(3) by simp
also have
"... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)) \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
using \<epsilon> S.comp_assoc by simp
also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
have "\<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)) \<cdot>\<^sub>S S.\<Phi> (f, g) = \<xi>'"
proof -
have "S.iso (S.\<Phi> (f, g))"
using assms by auto
moreover have "S.dom (S.\<Phi> (f, g)) = S.UP f \<star>\<^sub>S S.UP g"
using assms by auto
ultimately have "S.inv (S.\<Phi> (f, g)) \<cdot>\<^sub>S S.\<Phi> (f, g) = S.UP f \<star>\<^sub>S S.UP g"
using S.comp_inv_arr' by simp
thus ?thesis
using S.comp_arr_dom E'.counit_in_hom(2) by simp
qed
thus ?thesis by argo
qed
also have
"... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
S.inv (S.\<Phi> (f, src f))"
proof -
have "UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<star>\<^sub>S S.UP f = (UP.\<Psi> ?b \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (\<xi>' \<star>\<^sub>S S.UP f)"
using assms b UP.\<Psi>_char S.whisker_right S.UP_map\<^sub>0_obj by auto
moreover have "S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> =
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)"
using assms S.whisker_left S.comp_assoc by auto
ultimately show ?thesis
using S.comp_assoc by simp
qed
also have "... = (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
proof -
have "(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>"
using assms S.whisker_left by auto
hence "((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) =
((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>))"
by simp
also have "... = ((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
proof -
have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) = \<xi>' \<star>\<^sub>S S.UP f"
proof -
have "\<guillemotleft>\<xi>' \<star>\<^sub>S S.UP f :
(S.UP f \<star>\<^sub>S S.UP g) \<star>\<^sub>S S.UP f \<Rightarrow>\<^sub>S S.trg (S.UP f) \<star>\<^sub>S S.UP f\<guillemotright>"
using assms by (intro S.hcomp_in_vhom, auto)
moreover have "\<guillemotleft>S.\<a>' (S.UP f) (S.UP g) (S.UP f) :
S.UP f \<star>\<^sub>S S.UP g \<star>\<^sub>S S.UP f \<Rightarrow>\<^sub>S (S.UP f \<star>\<^sub>S S.UP g) \<star>\<^sub>S S.UP f\<guillemotright>"
using assms S.assoc'_in_hom by auto
ultimately show ?thesis
using assms S.strict_assoc' S.iso_assoc S.hcomp_assoc E'.antipar
S.comp_arr_ide S.seqI'
- by simp
+ by (metis (no_types, lifting) E'.ide_left E'.ide_right)
qed
thus ?thesis
using S.comp_assoc by simp
qed
also have "... = ((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>))"
using S.comp_assoc by simp
also have "... = (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
proof -
have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
proof -
have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> ?a) =
S.lunit' (S.UP f) \<cdot>\<^sub>S S.runit (S.UP f)"
proof -
have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> ?a) =
(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a)"
proof -
have "S.seq (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) (UP.\<Psi> ?a)"
- using assms UP.\<Psi>_char UP.\<Phi>_components_are_iso by auto
+ using assms UP.\<Psi>_char UP.\<Phi>_components_are_iso
+ E'.unit_simps(1) S.comp_assoc
+ by presburger
hence "(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) =
S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a"
using assms UP.\<Psi>_char UP.\<Phi>_components_are_iso S.comp_assoc
S.whisker_left [of "S.UP f" "S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>" "UP.\<Psi> ?a"]
by simp
thus ?thesis by simp
qed
thus ?thesis
using assms E'.triangle_left UP.\<Phi>_components_are_iso UP.\<Psi>_char
- by simp
+ by argo
qed
also have "... = S.UP f"
using S.strict_lunit' S.strict_runit by simp
finally have 1: "((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> ?a) = S.UP f"
using S.comp_assoc by simp
have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
S.UP f \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a))"
proof -
- have "S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> ?a)"
+ have "S.arr (S.UP f)"
+ using assms by simp
+ moreover have "S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> ?a)"
using assms UP.\<Psi>_char S.UP_map\<^sub>0_obj by auto
moreover have "S.inv (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a)"
using assms a UP.\<Psi>_char S.UP_map\<^sub>0_obj by auto
ultimately show ?thesis
using assms 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso
S.invert_side_of_triangle(2)
[of "S.UP f" "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
"S.UP f \<star>\<^sub>S UP.\<Psi> ?a"]
- by simp (* 45 sec *)
+ by presburger
qed
also have "... = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a)"
proof -
have "\<guillemotleft>S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a) :
S.UP f \<star>\<^sub>S S.UP ?a \<Rightarrow>\<^sub>S S.UP f \<star>\<^sub>S UP.map\<^sub>0 ?a\<guillemotright>"
using assms ide_f f_in_hhom UP.\<Psi>_char [of ?a] S.inv_in_hom
apply (intro S.hcomp_in_vhom)
apply auto[1]
apply blast
by auto
moreover have "S.UP f \<star>\<^sub>S UP.map\<^sub>0 ?a = S.UP f"
using a S.hcomp_arr_obj S.UP_map\<^sub>0_obj by auto
finally show ?thesis
using S.comp_cod_arr by blast
qed
finally show ?thesis by auto
qed
thus ?thesis
using S.comp_assoc by simp
qed
finally show ?thesis by simp
qed
thus ?thesis
using S.comp_assoc by simp
qed
also have "... = S.UP \<l>\<^sup>-\<^sup>1[f] \<cdot>\<^sub>S S.UP \<r>[f]"
proof -
have "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<star>\<^sub>S S.UP f) = S.UP \<l>\<^sup>-\<^sup>1[f]"
proof -
have "S.UP f = S.UP \<l>[f] \<cdot>\<^sub>S S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)"
using UP.lunit_coherence iso_lunit S.strict_lunit by simp
thus ?thesis
- using UP.\<Psi>_char S.comp_arr_dom UP.preserves_iso UP.preserves_inv
- S.invert_side_of_triangle(1)
- [of "S.UP f" "S.UP \<l>[f]" "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)"]
- by auto
+ using UP.image_of_unitor(3) ide_f by presburger
qed
moreover have "(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
S.UP \<r>[f]"
proof -
have "S.UP \<r>[f] \<cdot>\<^sub>S S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) = S.UP f"
using UP.runit_coherence [of f] S.strict_runit by simp
- moreover have 1: "S.iso (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)))"
+ moreover have "S.iso (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)))"
using UP.\<Psi>_char UP.\<Phi>_components_are_iso VV.arr_char S.hseqI' S.UP_map\<^sub>0_obj
- by (intro S.isos_compose S.seqI, auto)
+ apply (intro S.isos_compose S.seqI)
+ by simp_all
ultimately have
"S.UP \<r>[f] = S.UP f \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)))"
using S.invert_side_of_triangle(2)
[of "S.UP f" "S.UP \<r>[f]" "S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"]
- by simp
- also have
- "... = (S.UP f \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
- proof -
- have "S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
- using 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso S.UP_map\<^sub>0_obj by simp
- moreover have
- "S.inv (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))"
- using 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso S.UP_map\<^sub>0_obj by simp
- moreover have "S.seq (S.\<Phi> (f, src f)) (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
- using 1 S.hseqI' S.UP_map\<^sub>0_obj
- by (intro S.seqI S.hseqI, auto)
- ultimately have "S.inv (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))) =
- (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
- using 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso S.inv_comp by auto
- thus ?thesis
- using S.comp_assoc by simp
- qed
- also have
- "... = (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
- using UP.\<Psi>_char S.comp_cod_arr S.hcomp_arr_obj S.hseqI' S.UP_map\<^sub>0_obj by simp
- finally show ?thesis by simp
+ ideD(1) ide_f by blast
+ thus ?thesis
+ using ide_f UP.image_of_unitor(2) [of f] by argo
qed
ultimately show ?thesis
using S.comp_assoc by simp
qed
also have "... = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
by simp
finally have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
by simp
moreover have "par ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
proof -
have "\<guillemotleft>(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) : f \<star> src f \<Rightarrow> trg f \<star> f\<guillemotright>"
using E''.triangle_in_hom(1) by simp
moreover have "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] : f \<star> src f \<Rightarrow> trg f \<star> f\<guillemotright>" by auto
ultimately show ?thesis
by (metis in_homE)
qed
ultimately show ?thesis
using UP.is_faithful by blast
qed
thus "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
using E''.triangle_left_implies_right by simp
qed
show ?thesis
using E''.adjoint_equivalence_in_bicategory_axioms E''.adjunction_in_bicategory_axioms
adjunction_unit_determines_counit adjoint_equivalence_in_bicategory_def
by metis
qed
lemma equivalence_map_extends_to_adjoint_equivalence:
assumes "equivalence_map f"
shows "\<exists>g \<eta> \<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
proof -
obtain g \<eta> \<epsilon>' where E: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
using assms equivalence_map_def by auto
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
using E by auto
obtain \<epsilon> where A: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
E.antipar E.unit_is_iso E.unit_in_hom by auto
show ?thesis
using E A by blast
qed
end
subsection "Uniqueness of Adjoints"
text \<open>
Left and right adjoints determine each other up to isomorphism.
\<close>
context strict_bicategory
begin
lemma left_adjoint_determines_right_up_to_iso:
assumes "adjoint_pair f g" and "adjoint_pair f g'"
shows "g \<cong> g'"
proof -
obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using A by auto
interpret A: adjunction_in_strict_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon> ..
obtain \<eta>' \<epsilon>' where A': "adjunction_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'"
using assms adjoint_pair_def by auto
interpret A': adjunction_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'
using A' by auto
interpret A': adjunction_in_strict_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>' ..
let ?\<phi> = "A'.trnl\<^sub>\<eta> g \<epsilon>"
have "\<guillemotleft>?\<phi>: g \<Rightarrow> g'\<guillemotright>"
using A'.trnl\<^sub>\<eta>_eq A'.adjoint_transpose_left(1) [of "trg f" g] A.antipar A'.antipar
hcomp_arr_obj hseqI'
by auto
moreover have "iso ?\<phi>"
proof (intro isoI)
let ?\<psi> = "A.trnl\<^sub>\<eta> g' \<epsilon>'"
show "inverse_arrows ?\<phi> ?\<psi>"
proof
show "ide (?\<phi> \<cdot> ?\<psi>)"
proof -
have 1: "ide (trg f) \<and> trg (trg f) = trg f"
by simp
have "?\<phi> \<cdot> ?\<psi> = (g' \<star> \<epsilon>) \<cdot> ((\<eta>' \<star> g) \<cdot> (g \<star> \<epsilon>')) \<cdot> (\<eta> \<star> g')"
using 1 A.antipar A'.antipar A.trnl\<^sub>\<eta>_eq [of "trg f" g' \<epsilon>']
A'.trnl\<^sub>\<eta>_eq [of "trg f" g \<epsilon>] comp_assoc A.counit_in_hom A'.counit_in_hom
by simp
also have "... = ((g' \<star> \<epsilon>) \<cdot> (g' \<star> f \<star> g \<star> \<epsilon>')) \<cdot> ((\<eta>' \<star> g \<star> f \<star> g') \<cdot> (\<eta> \<star> g'))"
proof -
have "(\<eta>' \<star> g) \<cdot> (g \<star> \<epsilon>') = (\<eta>' \<star> g \<star> trg f) \<cdot> (src f \<star> g \<star> \<epsilon>')"
using A.antipar A'.antipar hcomp_arr_obj hcomp_obj_arr [of "src f" "g \<star> \<epsilon>'"]
hseqI'
by (metis A'.counit_simps(1) A'.counit_simps(5) A.ide_right ideD(1)
obj_trg trg_hcomp')
also have "... = \<eta>' \<star> g \<star> \<epsilon>'"
using A.antipar A'.antipar interchange [of \<eta>' "src f" "g \<star> trg f" "g \<star> \<epsilon>'"]
whisker_left comp_arr_dom comp_cod_arr hseqI'
by simp
also have "... = ((g' \<star> f) \<star> g \<star> \<epsilon>') \<cdot> (\<eta>' \<star> g \<star> (f \<star> g'))"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
A'.unit_in_hom A'.counit_in_hom interchange whisker_left
comp_arr_dom comp_cod_arr
by (metis A'.counit_simps(1-2,5) A'.unit_simps(1,3) hseqI' ide_char)
also have "... = (g' \<star> f \<star> g \<star> \<epsilon>') \<cdot> (\<eta>' \<star> g \<star> f \<star> g')"
using hcomp_assoc by simp
finally show ?thesis
using comp_assoc by simp
qed
also have "... = (g' \<star> \<epsilon>') \<cdot> ((g' \<star> (\<epsilon> \<star> f) \<star> g') \<cdot> (g' \<star> (f \<star> \<eta>) \<star> g')) \<cdot> (\<eta>' \<star> g')"
proof -
have "(g' \<star> \<epsilon>) \<cdot> (g' \<star> f \<star> g \<star> \<epsilon>') = (g' \<star> \<epsilon>') \<cdot> (g' \<star> \<epsilon> \<star> f \<star> g')"
proof -
have "(g' \<star> \<epsilon>) \<cdot> (g' \<star> f \<star> g \<star> \<epsilon>') = g' \<star> \<epsilon> \<star> \<epsilon>'"
proof -
have "\<epsilon> \<cdot> (f \<star> g \<star> \<epsilon>') = \<epsilon> \<star> \<epsilon>'"
using A.ide_left A.ide_right A.antipar A'.antipar hcomp_arr_obj comp_arr_dom
comp_cod_arr interchange obj_src trg_src
by (metis A'.counit_simps(1,3) A.counit_simps(1-2,4) hcomp_assoc)
thus ?thesis
using A.antipar A'.antipar whisker_left [of g' \<epsilon> "f \<star> g \<star> \<epsilon>'"]
by (simp add: hcomp_assoc hseqI')
qed
also have "... = (g' \<star> \<epsilon>') \<cdot> (g' \<star> \<epsilon> \<star> f \<star> g')"
proof -
have "\<epsilon> \<star> \<epsilon>' = \<epsilon>' \<cdot> (\<epsilon> \<star> f \<star> g')"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
hcomp_obj_arr hcomp_arr_obj comp_arr_dom comp_cod_arr interchange
obj_src trg_src
by (metis A'.counit_simps(1-2,5) A.counit_simps(1,3-4) arr_cod
not_arr_null seq_if_composable)
thus ?thesis
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
whisker_left
by (metis A'.counit_simps(1,5) A.counit_simps(1,4) hseqI')
qed
finally show ?thesis by simp
qed
moreover have "(\<eta>' \<star> g \<star> f \<star> g') \<cdot> (\<eta> \<star> g') = (g' \<star> f \<star> \<eta> \<star> g') \<cdot> (\<eta>' \<star> g')"
proof -
have "(\<eta>' \<star> g \<star> f \<star> g') \<cdot> (\<eta> \<star> g') = \<eta>' \<star> \<eta> \<star> g'"
proof -
have "(\<eta>' \<star> g \<star> f) \<cdot> \<eta> = \<eta>' \<star> \<eta>"
using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom hcomp_arr_obj
interchange comp_arr_dom comp_cod_arr
by (metis A'.unit_simps(1-2,4) A.unit_simps(1,3,5) hcomp_obj_arr obj_trg)
thus ?thesis
using A.antipar A'.antipar whisker_right [of g' "\<eta>' \<star> g \<star> f" \<eta>]
by (simp add: hcomp_assoc hseqI')
qed
also have "... = (g' \<star> f \<star> \<eta> \<star> g') \<cdot> (\<eta>' \<star> g')"
proof -
have "\<eta>' \<star> \<eta> = (g' \<star> f \<star> \<eta>) \<cdot> \<eta>'"
using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom hcomp_arr_obj
comp_arr_dom comp_cod_arr hcomp_assoc interchange
by (metis A'.unit_simps(1,3-4) A.unit_simps(1-2) obj_src)
thus ?thesis
using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom hcomp_arr_obj
whisker_right [of g' "g' \<star> f \<star> \<eta>" \<eta>']
by (metis A'.ide_right A'.unit_simps(1,4) A.unit_simps(1,5)
hseqI' hcomp_assoc)
qed
finally show ?thesis by simp
qed
ultimately show ?thesis
using comp_assoc hcomp_assoc by simp
qed
also have "... = (g' \<star> \<epsilon>') \<cdot> ((g' \<star> f) \<star> g') \<cdot> (\<eta>' \<star> g')"
proof -
have "(g' \<star> (\<epsilon> \<star> f) \<star> g') \<cdot> (g' \<star> (f \<star> \<eta>) \<star> g') = g' \<star> f \<star> g'"
proof -
have "(g' \<star> (\<epsilon> \<star> f) \<star> g') \<cdot> (g' \<star> (f \<star> \<eta>) \<star> g') =
g' \<star> ((\<epsilon> \<star> f) \<star> g') \<cdot> ((f \<star> \<eta>) \<star> g')"
using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom
A'.counit_in_hom whisker_left [of g' "(\<epsilon> \<star> f) \<star> g'" "(f \<star> \<eta>) \<star> g'"]
by (metis A'.ide_right A.triangle_left hseqI' ideD(1) whisker_right)
also have "... = g' \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) \<star> g'"
using A.antipar A'.antipar whisker_right [of g' "\<epsilon> \<star> f" "f \<star> \<eta>"]
by (simp add: A.triangle_left hseqI')
also have "... = g' \<star> f \<star> g'"
using A.triangle_left by simp
finally show ?thesis by simp
qed
thus ?thesis
using hcomp_assoc by simp
qed
also have "... = (g' \<star> \<epsilon>') \<cdot> (\<eta>' \<star> g')"
using A.antipar A'.antipar A'.unit_in_hom A'.counit_in_hom comp_cod_arr
by (metis A'.triangle_in_hom(4) A'.triangle_right' hcomp_simps(4) comp_null(2)
hseq_char' in_homE)
also have "... = g'"
using A'.triangle_right by simp
finally have "?\<phi> \<cdot> ?\<psi> = g'" by simp
thus ?thesis by simp
qed
show "ide (?\<psi> \<cdot> ?\<phi>)"
proof -
have 1: "ide (trg f) \<and> trg (trg f) = trg f"
by simp
have "?\<psi> \<cdot> ?\<phi> = (g \<star> \<epsilon>') \<cdot> ((\<eta> \<star> g') \<cdot> (g' \<star> \<epsilon>)) \<cdot> (\<eta>' \<star> g)"
using A.antipar A'.antipar A'.trnl\<^sub>\<eta>_eq [of "trg f" g \<epsilon>]
A.trnl\<^sub>\<eta>_eq [of "trg f" g' \<epsilon>'] comp_assoc A.counit_in_hom A'.counit_in_hom
by simp
also have "... = ((g \<star> \<epsilon>') \<cdot> (g \<star> f \<star> g' \<star> \<epsilon>)) \<cdot> ((\<eta> \<star> g' \<star> f \<star> g) \<cdot> (\<eta>' \<star> g))"
proof -
have "(\<eta> \<star> g') \<cdot> (g' \<star> \<epsilon>) = (\<eta> \<star> g' \<star> trg f) \<cdot> (src f \<star> g' \<star> \<epsilon>)"
using A.antipar A'.antipar hcomp_arr_obj hcomp_obj_arr hseqI'
by (metis A'.ide_right A.unit_simps(1,4) hcomp_assoc hcomp_obj_arr
ideD(1) obj_src)
also have "... = \<eta> \<star> g' \<star> \<epsilon>"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar A.unit_in_hom
A.counit_in_hom interchange
by (metis "1" A.counit_simps(5) A.unit_simps(4) hseqI' ide_def ide_in_hom(2)
not_arr_null seqI' src.preserves_ide)
also have "... = ((g \<star> f) \<star> g' \<star> \<epsilon>) \<cdot> (\<eta> \<star> g' \<star> (f \<star> g))"
using A'.ide_right A'.antipar interchange ide_char comp_arr_dom comp_cod_arr hseqI'
by (metis A.counit_simps(1-2,5) A.unit_simps(1,3))
also have "... = (g \<star> f \<star> g' \<star> \<epsilon>) \<cdot> (\<eta> \<star> g' \<star> f \<star> g)"
using hcomp_assoc by simp
finally show ?thesis
using comp_assoc by simp
qed
also have "... = (g \<star> \<epsilon>) \<cdot> ((g \<star> (\<epsilon>' \<star> f) \<star> g) \<cdot> (g \<star> (f \<star> \<eta>') \<star> g)) \<cdot> (\<eta> \<star> g)"
proof -
have "(g \<star> \<epsilon>') \<cdot> (g \<star> f \<star> g' \<star> \<epsilon>) = (g \<star> \<epsilon>) \<cdot> (g \<star> \<epsilon>' \<star> f \<star> g)"
proof -
have "(g \<star> \<epsilon>') \<cdot> (g \<star> f \<star> g' \<star> \<epsilon>) = g \<star> \<epsilon>' \<star> \<epsilon>"
proof -
have "\<epsilon>' \<cdot> (f \<star> g' \<star> \<epsilon>) = \<epsilon>' \<star> \<epsilon>"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar hcomp_arr_obj
comp_arr_dom comp_cod_arr interchange obj_src trg_src hcomp_assoc
by (metis A.counit_simps(1,3) A'.counit_simps(1-2,4))
thus ?thesis
using A.antipar A'.antipar whisker_left [of g \<epsilon>' "f \<star> g' \<star> \<epsilon>"]
by (simp add: hcomp_assoc hseqI')
qed
also have "... = (g \<star> \<epsilon>) \<cdot> (g \<star> \<epsilon>' \<star> f \<star> g)"
proof -
have "\<epsilon>' \<star> \<epsilon> = \<epsilon> \<cdot> (\<epsilon>' \<star> f \<star> g)"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar hcomp_obj_arr
hcomp_arr_obj comp_arr_dom comp_cod_arr interchange obj_src trg_src
by (metis A.counit_simps(1-2,5) A'.counit_simps(1,3-4)
arr_cod not_arr_null seq_if_composable)
thus ?thesis
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
whisker_left
by (metis A.counit_simps(1,5) A'.counit_simps(1,4) hseqI')
qed
finally show ?thesis by simp
qed
moreover have "(\<eta> \<star> g' \<star> f \<star> g) \<cdot> (\<eta>' \<star> g) = (g \<star> f \<star> \<eta>' \<star> g) \<cdot> (\<eta> \<star> g)"
proof -
have "(\<eta> \<star> g' \<star> f \<star> g) \<cdot> (\<eta>' \<star> g) = \<eta> \<star> \<eta>' \<star> g"
proof -
have "(\<eta> \<star> g' \<star> f) \<cdot> \<eta>' = \<eta> \<star> \<eta>'"
using A.antipar A'.antipar A.unit_in_hom hcomp_arr_obj
comp_arr_dom comp_cod_arr hcomp_obj_arr interchange
by (metis A'.unit_simps(1,3,5) A.unit_simps(1-2,4) obj_trg)
thus ?thesis
using A.antipar A'.antipar whisker_right [of g "\<eta> \<star> g' \<star> f" \<eta>']
by (simp add: hcomp_assoc hseqI')
qed
also have "... = ((g \<star> f) \<star> \<eta>' \<star> g) \<cdot> (\<eta> \<star> src f \<star> g)"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar A.unit_in_hom
A'.unit_in_hom comp_arr_dom comp_cod_arr interchange
by (metis A'.unit_simps(1-2,4) A.unit_simps(1,3) hseqI' ide_char)
also have "... = (g \<star> f \<star> \<eta>' \<star> g) \<cdot> (\<eta> \<star> g)"
using A.antipar A'.antipar hcomp_assoc
by (simp add: hcomp_obj_arr)
finally show ?thesis by simp
qed
ultimately show ?thesis
using comp_assoc hcomp_assoc by simp
qed
also have "... = (g \<star> \<epsilon>) \<cdot> ((g \<star> f) \<star> g) \<cdot> (\<eta> \<star> g)"
proof -
have "(g \<star> (\<epsilon>' \<star> f) \<star> g) \<cdot> (g \<star> (f \<star> \<eta>') \<star> g) = g \<star> f \<star> g"
proof -
have "(g \<star> (\<epsilon>' \<star> f) \<star> g) \<cdot> (g \<star> (f \<star> \<eta>') \<star> g) =
g \<star> ((\<epsilon>' \<star> f) \<star> g) \<cdot> ((f \<star> \<eta>') \<star> g)"
using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar A.unit_in_hom
A.counit_in_hom whisker_left
by (metis A'.triangle_left hseqI' ideD(1) whisker_right)
also have "... = g \<star> (\<epsilon>' \<star> f) \<cdot> (f \<star> \<eta>') \<star> g"
using A.antipar A'.antipar whisker_right [of g "\<epsilon>' \<star> f" "f \<star> \<eta>'"]
by (simp add: A'.triangle_left hseqI')
also have "... = g \<star> f \<star> g"
using A'.triangle_left by simp
finally show ?thesis by simp
qed
thus ?thesis
using hcomp_assoc by simp
qed
also have "... = (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g)"
using A.antipar A'.antipar A.unit_in_hom A.counit_in_hom comp_cod_arr
by (metis A.triangle_in_hom(4) A.triangle_right' hcomp_simps(4) comp_null(2)
hseq_char' in_homE)
also have "... = g"
using A.triangle_right by simp
finally have "?\<psi> \<cdot> ?\<phi> = g" by simp
moreover have "ide g"
by simp
ultimately show ?thesis by simp
qed
qed
qed
ultimately show ?thesis
using isomorphic_def by auto
qed
end
text \<open>
We now use strictification to extend to arbitrary bicategories.
\<close>
context bicategory
begin
interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
notation S.hcomp (infixr "\<star>\<^sub>S" 53)
notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
using S.UP_is_equivalence_pseudofunctor by auto
interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
..
interpretation UP: fully_faithful_functor V S.vcomp S.UP
using S.UP_is_fully_faithful_functor by auto
lemma left_adjoint_determines_right_up_to_iso:
assumes "adjoint_pair f g" and "adjoint_pair f g'"
shows "g \<cong> g'"
proof -
have 0: "ide g \<and> ide g'"
using assms adjoint_pair_def adjunction_in_bicategory_def
adjunction_data_in_bicategory_def adjunction_data_in_bicategory_axioms_def
by metis
have 1: "S.adjoint_pair (S.UP f) (S.UP g) \<and> S.adjoint_pair (S.UP f) (S.UP g')"
using assms UP.preserves_adjoint_pair by simp
obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : S.UP g \<Rightarrow>\<^sub>S S.UP g'\<guillemotright> \<and> S.iso \<nu>"
using 1 S.left_adjoint_determines_right_up_to_iso S.isomorphic_def by blast
obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : g \<Rightarrow> g'\<guillemotright> \<and> S.UP \<mu> = \<nu>"
using 0 \<nu> UP.is_full [of g' g \<nu>] by auto
have "\<guillemotleft>\<mu> : g \<Rightarrow> g'\<guillemotright> \<and> iso \<mu>"
using \<mu> \<nu> UP.reflects_iso by auto
thus ?thesis
using isomorphic_def by auto
qed
lemma right_adjoint_determines_left_up_to_iso:
assumes "adjoint_pair f g" and "adjoint_pair f' g"
shows "f \<cong> f'"
proof -
obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using A by auto
obtain \<eta>' \<epsilon>' where A': "adjunction_in_bicategory V H \<a> \<i> src trg f' g \<eta>' \<epsilon>'"
using assms adjoint_pair_def by auto
interpret A': adjunction_in_bicategory V H \<a> \<i> src trg f' g \<eta>' \<epsilon>'
using A' by auto
interpret Cop: op_bicategory V H \<a> \<i> src trg ..
interpret Aop: adjunction_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f \<eta> \<epsilon>
using A.antipar A.triangle_left A.triangle_right Cop.assoc_ide_simp
Cop.lunit_ide_simp Cop.runit_ide_simp
by (unfold_locales, auto)
interpret Aop': adjunction_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f' \<eta>' \<epsilon>'
using A'.antipar A'.triangle_left A'.triangle_right Cop.assoc_ide_simp
Cop.lunit_ide_simp Cop.runit_ide_simp
by (unfold_locales, auto)
show ?thesis
using Aop.adjunction_in_bicategory_axioms Aop'.adjunction_in_bicategory_axioms
Cop.left_adjoint_determines_right_up_to_iso Cop.adjoint_pair_def
by blast
qed
end
context chosen_right_adjoints
begin
lemma isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint:
assumes "is_left_adjoint f" and "f \<cong> h"
shows "f\<^sup>* \<cong> h\<^sup>*"
proof -
have 1: "adjoint_pair f f\<^sup>*"
using assms left_adjoint_extends_to_adjoint_pair by blast
moreover have "adjoint_pair h f\<^sup>*"
using assms 1 adjoint_pair_preserved_by_iso isomorphic_symmetric isomorphic_reflexive
by (meson isomorphic_def right_adjoint_simps(1))
thus ?thesis
using left_adjoint_determines_right_up_to_iso left_adjoint_extends_to_adjoint_pair
by blast
qed
end
context bicategory
begin
lemma equivalence_is_adjoint:
assumes "equivalence_map f"
shows equivalence_is_left_adjoint: "is_left_adjoint f"
and equivalence_is_right_adjoint: "is_right_adjoint f"
proof -
obtain g \<eta> \<epsilon> where fg: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms equivalence_map_extends_to_adjoint_equivalence by blast
interpret fg: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using fg by simp
- interpret gf: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg g f "inv \<epsilon>" "inv \<eta>"
+ interpret gf: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg g f \<open>inv \<epsilon>\<close> \<open>inv \<eta>\<close>
using fg.dual_adjoint_equivalence by simp
show "is_left_adjoint f"
using fg.adjunction_in_bicategory_axioms adjoint_pair_def by auto
show "is_right_adjoint f"
using gf.adjunction_in_bicategory_axioms adjoint_pair_def by auto
qed
lemma right_adjoint_to_equivalence_is_equivalence:
assumes "equivalence_map f" and "adjoint_pair f g"
shows "equivalence_map g"
proof -
obtain \<eta> \<epsilon> where fg: "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret fg: adjunction_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg f g \<eta> \<epsilon>
using fg by simp
obtain g' \<phi> \<psi> where fg': "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g' \<phi> \<psi>"
using assms equivalence_map_def by auto
interpret fg': equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg f g' \<phi> \<psi>
using fg' by auto
obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g' \<phi> \<psi>'"
using assms equivalence_refines_to_adjoint_equivalence [of f g' \<phi>]
fg'.antipar fg'.unit_in_hom fg'.unit_is_iso
by auto
interpret \<psi>': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg f g' \<phi> \<psi>'
using \<psi>' by simp
have 1: "g \<cong> g'"
using fg.adjunction_in_bicategory_axioms \<psi>'.adjunction_in_bicategory_axioms
left_adjoint_determines_right_up_to_iso adjoint_pair_def
by blast
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : g' \<Rightarrow> g\<guillemotright> \<and> iso \<gamma>"
using 1 isomorphic_def isomorphic_symmetric by metis
have "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g ((\<gamma> \<star> f) \<cdot> \<phi>) (\<psi>' \<cdot> (f \<star> inv \<gamma>))"
using \<gamma> equivalence_preserved_by_iso_right \<psi>'.equivalence_in_bicategory_axioms by simp
hence "equivalence_pair f g"
using equivalence_pair_def by auto
thus ?thesis
using equivalence_pair_symmetric equivalence_pair_def equivalence_map_def by blast
qed
lemma left_adjoint_to_equivalence_is_equivalence:
assumes "equivalence_map f" and "adjoint_pair g f"
shows "equivalence_map g"
proof -
obtain \<eta> \<epsilon> where gf: "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g f \<eta> \<epsilon>"
using assms adjoint_pair_def by auto
interpret gf: adjunction_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg g f \<eta> \<epsilon>
using gf by simp
obtain g' where 1: "equivalence_pair g' f"
using assms equivalence_map_def equivalence_pair_def equivalence_pair_symmetric
by blast
obtain \<phi> \<psi> where g'f: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g' f \<phi> \<psi>"
using assms 1 equivalence_pair_def by auto
interpret g'f: equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg g' f \<phi> \<psi>
using g'f by auto
obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g' f \<phi> \<psi>'"
using assms 1 equivalence_refines_to_adjoint_equivalence [of g' f \<phi>]
g'f.antipar g'f.unit_in_hom g'f.unit_is_iso equivalence_pair_def
equivalence_map_def
by auto
interpret \<psi>': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg g' f \<phi> \<psi>'
using \<psi>' by simp
have 1: "g \<cong> g'"
using gf.adjunction_in_bicategory_axioms \<psi>'.adjunction_in_bicategory_axioms
right_adjoint_determines_left_up_to_iso adjoint_pair_def
by blast
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : g' \<Rightarrow> g\<guillemotright> \<and> iso \<gamma>"
using 1 isomorphic_def isomorphic_symmetric by metis
have "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g f ((f \<star> \<gamma>) \<cdot> \<phi>) (\<psi>' \<cdot> (inv \<gamma> \<star> f))"
using \<gamma> equivalence_preserved_by_iso_left \<psi>'.equivalence_in_bicategory_axioms by simp
hence "equivalence_pair g f"
using equivalence_pair_def by auto
thus ?thesis
using equivalence_pair_symmetric equivalence_pair_def equivalence_map_def by blast
qed
lemma equivalence_pair_is_adjoint_pair:
assumes "equivalence_pair f g"
shows "adjoint_pair f g"
proof -
obtain \<eta> \<epsilon> where \<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms equivalence_pair_def by auto
interpret \<eta>\<epsilon>: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using \<eta>\<epsilon> by auto
obtain \<epsilon>' where \<eta>\<epsilon>': "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
using \<eta>\<epsilon> equivalence_map_def \<eta>\<epsilon>.antipar \<eta>\<epsilon>.unit_in_hom \<eta>\<epsilon>.unit_is_iso
\<eta>\<epsilon>.ide_right equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
by force
interpret \<eta>\<epsilon>': adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
using \<eta>\<epsilon>' by auto
show ?thesis
using \<eta>\<epsilon>' adjoint_pair_def \<eta>\<epsilon>'.adjunction_in_bicategory_axioms by auto
qed
lemma equivalence_pair_isomorphic_right:
assumes "equivalence_pair f g"
shows "equivalence_pair f g' \<longleftrightarrow> g \<cong> g'"
proof
show "g \<cong> g' \<Longrightarrow> equivalence_pair f g'"
using assms equivalence_pair_def isomorphic_def equivalence_preserved_by_iso_right
by metis
assume g': "equivalence_pair f g'"
show "g \<cong> g'"
using assms g' equivalence_pair_is_adjoint_pair left_adjoint_determines_right_up_to_iso
by blast
qed
lemma equivalence_pair_isomorphic_left:
assumes "equivalence_pair f g"
shows "equivalence_pair f' g \<longleftrightarrow> f \<cong> f'"
proof
show "f \<cong> f' \<Longrightarrow> equivalence_pair f' g"
using assms equivalence_pair_def isomorphic_def equivalence_preserved_by_iso_left
by metis
assume f': "equivalence_pair f' g"
show "f \<cong> f'"
using assms f' equivalence_pair_is_adjoint_pair right_adjoint_determines_left_up_to_iso
by blast
qed
end
end
diff --git a/thys/Bicategory/Prebicategory.thy b/thys/Bicategory/Prebicategory.thy
--- a/thys/Bicategory/Prebicategory.thy
+++ b/thys/Bicategory/Prebicategory.thy
@@ -1,3328 +1,3328 @@
(* Title: PreBicategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
text \<open>
The objective of this section is to construct a formalization of bicategories that is
compatible with our previous formulation of categories \cite{Category3-AFP}
and that permits us to carry over unchanged as much of the work done on categories as possible.
For these reasons, we conceive of a bicategory in what might be regarded as a somewhat
unusual fashion. Rather than a traditional development, which would typically define
a bicategory to be essentially ``a `category' whose homs themselves have the structure
of categories,'' here we regard a bicategory as ``a (vertical) category that has been
equipped with a suitable (horizontal) weak composition.'' Stated another way, we think
of a bicategory as a generalization of a monoidal category in which the tensor product is
a partial operation, rather than a total one. Our definition of bicategory can thus
be summarized as follows: a bicategory is a (vertical) category that has been equipped
with idempotent endofunctors \<open>src\<close> and \<open>trg\<close> that assign to each arrow its ``source''
and ``target'' subject to certain commutativity constraints,
a partial binary operation \<open>\<star>\<close> of horizontal composition that is suitably functorial on
the ``hom-categories'' determined by the assignment of sources and targets,
``associativity'' isomorphisms \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> (g \<star> h)\<guillemotright>\<close> for each horizontally
composable triple of vertical identities \<open>f\<close>, \<open>g\<close>, \<open>h\<close>, subject to the usual naturality
and coherence conditions, and for each ``object'' \<open>a\<close> (defined to be an arrow that is
its own source and target) a ``unit isomorphism'' \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
As is the case for monoidal categories, the unit isomorphisms and associator isomorphisms
together enable a canonical definition of left and right ``unit'' isomorphisms
\<open>\<guillemotleft>\<l>[f] : a \<star> f \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close> when \<open>f\<close> is a vertical identity
horizontally composable on the left or right by \<open>a\<close>, and it can be shown that these are
the components of natural transformations.
The definition of bicategory just sketched shares with a more traditional version the
requirement that assignments of source and target are given as basic data, and these
assignments determine horizontal composability in the sense that arrows \<open>\<mu>\<close> and \<open>\<nu>\<close>
are composable if the chosen source of \<open>\<mu>\<close> coincides with the chosen target of \<open>\<nu>\<close>.
Thus it appears, at least on its face, that composability of arrows depends on an assignment
of sources and targets. We are interested in establishing whether this is essential or
whether bicategories can be formalized in a completely ``object-free'' fashion.
It turns out that we can obtain such an object-free formalization through a rather direct
generalization of the approach we used in the formalization of categories.
Specifically, we define a \emph{weak composition} to be a partial binary operation \<open>\<star>\<close>
on the arrow type of a ``vertical'' category \<open>V\<close>, such that the domain of definition of this
operation is itself a category (of ``horizontally composable pairs of arrows''),
the operation is functorial, and it is subject to certain matching conditions which include
those satisfied by a category.
From the axioms for a weak composition we can prove the existence of ``hom-categories'',
which are subcategories of \<open>V\<close> consisting of arrows horizontally composable on the
left or right by a specified vertical identity.
A \emph{weak unit} is defined to be a vertical identity \<open>a\<close> such that \<open>a \<star> a \<cong> a\<close>
and is such that the mappings \<open>a \<star> \<hyphen>\<close> and \<open>\<hyphen> \<star> a\<close> are fully faithful endofunctors
of the subcategories of \<open>V\<close> consisting of the arrows for which they are defined.
We define the \emph{sources} of an arrow \<open>\<mu>\<close> to be the weak units that are horizontally
composable with \<open>\<mu>\<close> on the right, and the \emph{targets} of \<open>\<mu>\<close> to be the weak units
that are horizontally composable with \<open>\<mu>\<close> on the left.
An \emph{associative weak composition} is defined to be a weak composition that is equipped
with ``associator'' isomorphisms \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> (g \<star> h)\<guillemotright>\<close> for horizontally
composable vertical identities \<open>f\<close>, \<open>g\<close>, \<open>h\<close>, subject to the usual naturality and coherence
conditions.
A \emph{prebicategory} is defined to be an associative weak composition for which every
arrow has a source and a target. We show that the sets of sources and targets of each
arrow in a prebicategory is an isomorphism class of weak units, and that horizontal
composability of arrows \<open>\<mu>\<close> and \<open>\<nu>\<close> is characterized by the set of sources of \<open>\<mu>\<close> being
equal to the set of targets of \<open>\<nu>\<close>.
We show that prebicategories are essentially ``bicategories without objects''.
Given a prebicategory, we may choose an arbitrary representative of each
isomorphism class of weak units and declare these to be ``objects''
(this is analogous to choosing a particular unit object in a monoidal category).
For each object we may choose a particular \emph{unit isomorphism} \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
This choice, together with the associator isomorphisms, enables a canonical definition
of left and right unit isomorphisms \<open>\<guillemotleft>\<l>[f] : a \<star> f \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close>
when \<open>f\<close> is a vertical identity horizontally composable on the left or right by \<open>a\<close>,
and it can be shown that these are the components of natural isomorphisms.
We may then define ``the source'' of an arrow to be the chosen representative of the
set of its sources and ``the target'' to be the chosen representative of the set of its
targets. We show that the resulting structure is a bicategory, in which horizontal
composability as given by the weak composition coincides with the ``syntactic'' version
determined by the chosen sources and targets.
Conversely, a bicategory determines a prebicategory, essentially by forgetting
the sources, targets and unit isomorphisms.
These results make it clear that the assignment of sources and targets to arrows in
a bicategory is basically a convenience and that horizontal composability of arrows
is not dependent on a particular choice.
\<close>
theory Prebicategory
imports Category3.EquivalenceOfCategories Category3.Subcategory IsomorphismClass
begin
section "Weak Composition"
text \<open>
In this section we define a locale \<open>weak_composition\<close>, which formalizes a functorial
operation of ``horizontal'' composition defined on an underlying ``vertical'' category.
The definition is expressed without the presumption of the existence of any sort
of ``objects'' that determine horizontal composability. Rather, just as we did
in showing that the @{locale partial_magma} locale supported the definition of ``identity
arrow'' as a kind of unit for vertical composition which ultimately served as a basis
for the definition of ``domain'' and ``codomain'' of an arrow, here we show that the
\<open>weak_composition\<close> locale supports a definition of \emph{weak unit} for horizontal
composition which can ultimately be used to define the \emph{sources} and \emph{targets}
of an arrow with respect to horizontal composition.
In particular, the definition of weak composition involves axioms that relate horizontal
and vertical composability. As a consequence of these axioms, for any fixed arrow \<open>\<mu>\<close>,
the sets of arrows horizontally composable on the left and on the right with \<open>\<mu>\<close>
form subcategories with respect to vertical composition. We define the
sources of \<open>\<mu>\<close> to be the weak units that are composable with \<open>\<mu>\<close> on the right,
and the targets of \<open>\<mu>\<close> to be the weak units that are composable with \<open>\<mu>\<close>
on the left. Weak units are then characterized as arrows that are members
of the set of their own sources (or, equivalently, of their own targets).
\<close>
subsection "Definition"
locale weak_composition =
category V +
VxV: product_category V V +
VoV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null\<close> +
"functor" VoV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a comp" (infixr "\<star>" 53) +
assumes left_connected: "seq \<nu> \<nu>' \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu>' \<star> \<mu> \<noteq> null"
and right_connected: "seq \<mu> \<mu>' \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> \<mu>' \<noteq> null"
and match_1: "\<lbrakk> \<nu> \<star> \<mu> \<noteq> null; (\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null \<rbrakk> \<Longrightarrow> \<mu> \<star> \<tau> \<noteq> null"
and match_2: "\<lbrakk> \<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null; \<mu> \<star> \<tau> \<noteq> null \<rbrakk> \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null"
and match_3: "\<lbrakk> \<mu> \<star> \<tau> \<noteq> null; \<nu> \<star> \<mu> \<noteq> null \<rbrakk> \<Longrightarrow> (\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
and match_4: "\<lbrakk> \<mu> \<star> \<tau> \<noteq> null; \<nu> \<star> \<mu> \<noteq> null \<rbrakk> \<Longrightarrow> \<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null"
begin
text \<open>
We think of the arrows of the vertical category as ``2-cells'' and the vertical identities
as ``1-cells''. In the formal development, the predicate @{term arr} (``arrow'')
will have its normal meaning with respect to the vertical composition, hence @{term "arr \<mu>"}
will mean, essentially, ``\<open>\<mu>\<close> is a 2-cell''. This is somewhat unfortunate, as it is
traditional when discussing bicategories to use the term ``arrow'' to refer to the 1-cells.
However, we are trying to carry over all the formalism that we have already developed for
categories and apply it to bicategories with as little change and redundancy as possible.
It becomes too confusing to try to repurpose the name @{term arr} to mean @{term ide} and
to introduce a replacement for the name @{term arr}, so we will simply tolerate the
situation. In informal text, we will prefer the terms ``2-cell'' and ``1-cell'' over
(vertical) ``arrow'' and ``identity'' when there is a chance for confusion.
We do, however, make the following adjustments in notation for @{term in_hom} so that
it is distinguished from the notion @{term in_hhom} (``in horizontal hom'') to be
introduced subsequently.
\<close>
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
lemma is_partial_magma:
shows "partial_magma H"
proof
show "\<exists>!n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"
proof
show 1: "\<forall>f. null \<star> f = null \<and> f \<star> null = null"
using is_extensional VoV.inclusion VoV.arr_char by force
show "\<And>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n \<Longrightarrow> n = null"
using 1 VoV.arr_char is_extensional not_arr_null by metis
qed
qed
interpretation H: partial_magma H
using is_partial_magma by auto
text \<open>
Either \<open>match_1\<close> or \<open>match_2\<close> seems essential for the next result, which states
that the nulls for the horizontal and vertical compositions coincide.
\<close>
lemma null_agreement [simp]:
shows "H.null = null"
by (metis VoV.inclusion VxV.not_arr_null match_1 H.comp_null(1))
lemma composable_implies_arr:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "arr \<mu>" and "arr \<nu>"
using assms is_extensional VoV.arr_char VoV.inclusion by auto
lemma hcomp_null [simp]:
shows "null \<star> \<mu> = null" and "\<mu> \<star> null = null"
using H.comp_null by auto
lemma hcomp_simps\<^sub>W\<^sub>C [simp]:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "arr (\<nu> \<star> \<mu>)" and "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>" and "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
using assms preserves_arr preserves_dom preserves_cod VoV.arr_char VoV.inclusion
by force+
lemma ide_hcomp\<^sub>W\<^sub>C [simp]:
assumes "ide f" and "ide g" and "g \<star> f \<noteq> null"
shows "ide (g \<star> f)"
using assms preserves_ide VoV.ide_char by force
lemma hcomp_in_hom\<^sub>W\<^sub>C [intro]:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
using assms by auto
text \<open>
Horizontal composability of arrows is determined by horizontal composability of
their domains and codomains (defined with respect to vertical composition).
\<close>
lemma hom_connected:
shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> dom \<nu> \<star> \<mu> \<noteq> null"
and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> dom \<mu> \<noteq> null"
and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> cod \<nu> \<star> \<mu> \<noteq> null"
and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> cod \<mu> \<noteq> null"
proof -
show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> dom \<nu> \<star> \<mu> \<noteq> null"
using left_connected [of \<nu> "dom \<nu>" \<mu>] composable_implies_arr arr_dom_iff_arr by force
show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> cod \<nu> \<star> \<mu> \<noteq> null"
using left_connected [of "cod \<nu>" \<nu> \<mu>] composable_implies_arr arr_cod_iff_arr by force
show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> dom \<mu> \<noteq> null"
using right_connected [of \<mu> "dom \<mu>" \<nu>] composable_implies_arr arr_dom_iff_arr by force
show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> cod \<mu> \<noteq> null"
using right_connected [of "cod \<mu>" \<mu> \<nu>] composable_implies_arr arr_cod_iff_arr by force
qed
lemma isomorphic_implies_equicomposable:
assumes "f \<cong> g"
shows "\<tau> \<star> f \<noteq> null \<longleftrightarrow> \<tau> \<star> g \<noteq> null"
and "f \<star> \<sigma> \<noteq> null \<longleftrightarrow> g \<star> \<sigma> \<noteq> null"
using assms isomorphic_def hom_connected by auto
lemma interchange:
assumes "seq \<nu> \<mu>" and "seq \<tau> \<sigma>"
shows "(\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
proof -
have "\<mu> \<star> \<sigma> = null \<Longrightarrow> ?thesis"
by (metis assms comp_null(2) dom_comp hom_connected(1-2))
moreover have "\<mu> \<star> \<sigma> \<noteq> null \<Longrightarrow> ?thesis"
proof -
assume \<mu>\<sigma>: "\<mu> \<star> \<sigma> \<noteq> null"
have 1: "VoV.arr (\<mu>, \<sigma>)"
using \<mu>\<sigma> VoV.arr_char by auto
have \<nu>\<tau>: "(\<nu>, \<tau>) \<in> VoV.hom (VoV.cod (\<mu>, \<sigma>)) (VoV.cod (\<nu>, \<tau>))"
proof -
have "VoV.arr (\<nu>, \<tau>)"
using assms 1 hom_connected VoV.arr_char
by (elim seqE, auto, metis)
thus ?thesis
using assms \<mu>\<sigma> VoV.dom_char VoV.cod_char by fastforce
qed
show ?thesis
proof -
have "VoV.seq (\<nu>, \<tau>) (\<mu>, \<sigma>)"
using assms 1 \<mu>\<sigma> \<nu>\<tau> VoV.seqI by blast
thus ?thesis
using assms 1 \<mu>\<sigma> \<nu>\<tau> VoV.comp_char preserves_comp [of "(\<nu>, \<tau>)" "(\<mu>, \<sigma>)"] VoV.seqI
by fastforce
qed
qed
ultimately show ?thesis by blast
qed
lemma paste_1:
shows "\<nu> \<star> \<mu> = (cod \<nu> \<star> \<mu>) \<cdot> (\<nu> \<star> dom \<mu>)"
using interchange composable_implies_arr comp_arr_dom comp_cod_arr
hom_connected(2-3)
by (metis comp_null(2))
lemma paste_2:
shows "\<nu> \<star> \<mu> = (\<nu> \<star> cod \<mu>) \<cdot> (dom \<nu> \<star> \<mu>)"
using interchange composable_implies_arr comp_arr_dom comp_cod_arr
hom_connected(1,4)
by (metis comp_null(2))
lemma whisker_left:
assumes "seq \<nu> \<mu>" and "ide f"
shows "f \<star> (\<nu> \<cdot> \<mu>) = (f \<star> \<nu>) \<cdot> (f \<star> \<mu>)"
using assms interchange [of f f \<nu> \<mu>] hom_connected by auto
lemma whisker_right:
assumes "seq \<nu> \<mu>" and "ide f"
shows "(\<nu> \<cdot> \<mu>) \<star> f = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
using assms interchange [of \<nu> \<mu> f f] hom_connected by auto
subsection "Hom-Subcategories"
definition left
where "left \<tau> \<equiv> \<lambda>\<mu>. \<tau> \<star> \<mu> \<noteq> null"
definition right
where "right \<sigma> \<equiv> \<lambda>\<mu>. \<mu> \<star> \<sigma> \<noteq> null"
lemma right_iff_left:
shows "right \<sigma> \<tau> \<longleftrightarrow> left \<tau> \<sigma>"
using right_def left_def by simp
lemma left_respects_isomorphic:
assumes "f \<cong> g"
shows "left f = left g"
using assms isomorphic_implies_equicomposable left_def by auto
lemma right_respects_isomorphic:
assumes "f \<cong> g"
shows "right f = right g"
using assms isomorphic_implies_equicomposable right_def by auto
lemma left_iff_left_inv:
assumes "iso \<mu>"
shows "left \<tau> \<mu> \<longleftrightarrow> left \<tau> (inv \<mu>)"
using assms left_def inv_in_hom hom_connected(2) hom_connected(4) [of \<tau> "inv \<mu>"]
by auto
lemma right_iff_right_inv:
assumes "iso \<mu>"
shows "right \<sigma> \<mu> \<longleftrightarrow> right \<sigma> (inv \<mu>)"
using assms right_def inv_in_hom hom_connected(1) hom_connected(3) [of "inv \<mu>" \<sigma>]
by auto
lemma left_hom_is_subcategory:
assumes "arr \<mu>"
shows "subcategory V (left \<mu>)"
proof (unfold left_def, unfold_locales)
show "\<And>f. \<mu> \<star> f \<noteq> null \<Longrightarrow> arr f" using composable_implies_arr by simp
show "\<And>f. \<mu> \<star> f \<noteq> null \<Longrightarrow> \<mu> \<star> dom f \<noteq> null" using hom_connected(2) by simp
show "\<And>f. \<mu> \<star> f \<noteq> null \<Longrightarrow> \<mu> \<star> cod f \<noteq> null" using hom_connected(4) by auto
show "\<And>f g. \<lbrakk> \<mu> \<star> f \<noteq> null; \<mu> \<star> g \<noteq> null; cod f = dom g \<rbrakk> \<Longrightarrow> \<mu> \<star> (g \<cdot> f) \<noteq> null"
proof -
fix f g
assume f: "\<mu> \<star> f \<noteq> null" and g: "\<mu> \<star> g \<noteq> null" and fg: "cod f = dom g"
show "\<mu> \<star> (g \<cdot> f) \<noteq> null"
using f g fg composable_implies_arr hom_connected(2) [of \<mu> "g \<cdot> f"] hom_connected(2)
by simp
qed
qed
lemma right_hom_is_subcategory:
assumes "arr \<mu>"
shows "subcategory V (right \<mu>)"
proof (unfold right_def, unfold_locales)
show "\<And>f. f \<star> \<mu> \<noteq> null \<Longrightarrow> arr f" using composable_implies_arr by simp
show "\<And>f. f \<star> \<mu> \<noteq> null \<Longrightarrow> dom f \<star> \<mu> \<noteq> null" using hom_connected(1) by auto
show "\<And>f. f \<star> \<mu> \<noteq> null \<Longrightarrow> cod f \<star> \<mu> \<noteq> null" using hom_connected(3) by auto
show "\<And>f g. \<lbrakk> f \<star> \<mu> \<noteq> null; g \<star> \<mu> \<noteq> null; cod f = dom g \<rbrakk> \<Longrightarrow> (g \<cdot> f) \<star> \<mu> \<noteq> null"
proof -
fix f g
assume f: "f \<star> \<mu> \<noteq> null" and g: "g \<star> \<mu> \<noteq> null" and fg: "cod f = dom g"
show "(g \<cdot> f) \<star> \<mu> \<noteq> null"
using f g fg composable_implies_arr hom_connected(1) [of "g \<cdot> f" \<mu>] hom_connected(1)
by simp
qed
qed
abbreviation Left
where "Left a \<equiv> subcategory.comp V (left a)"
abbreviation Right
where "Right a \<equiv> subcategory.comp V (right a)"
text \<open>
We define operations of composition on the left or right with a fixed 1-cell,
and show that such operations are functorial in case that 1-cell is
horizontally self-composable.
\<close>
definition H\<^sub>L
where "H\<^sub>L g \<equiv> \<lambda>\<mu>. g \<star> \<mu>"
definition H\<^sub>R
where "H\<^sub>R f \<equiv> \<lambda>\<mu>. \<mu> \<star> f"
(* TODO: Why do the following fail when I use @{thm ...} *)
text \<open>
Note that \<open>match_3\<close> and \<open>match_4\<close> are required for the next results.
\<close>
lemma endofunctor_H\<^sub>L:
assumes "ide g" and "g \<star> g \<noteq> null"
shows "endofunctor (Left g) (H\<^sub>L g)"
proof -
interpret L: subcategory V \<open>left g\<close> using assms left_hom_is_subcategory by simp
have *: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> H\<^sub>L g \<mu> = g \<star> \<mu>"
using assms H\<^sub>L_def by simp
have preserves_arr: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L g \<mu>)"
using assms * L.arr_char left_def match_4 by force
show "endofunctor L.comp (H\<^sub>L g)"
proof
show "\<And>\<mu>. \<not> L.arr \<mu> \<Longrightarrow> H\<^sub>L g \<mu> = L.null"
using assms L.arr_char L.null_char left_def H\<^sub>L_def by fastforce
show "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L g \<mu>)" by fact
fix \<mu>
assume "L.arr \<mu>"
hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> g \<star> \<mu> \<noteq> null"
using assms L.arr_char composable_implies_arr left_def by metis
show "L.dom (H\<^sub>L g \<mu>) = H\<^sub>L g (L.dom \<mu>)"
using assms \<mu> * L.arr_char L.dom_char preserves_arr hom_connected(2) left_def
by simp
show "L.cod (H\<^sub>L g \<mu>) = H\<^sub>L g (L.cod \<mu>)"
using assms \<mu> * L.arr_char L.cod_char preserves_arr hom_connected(4) left_def
by simp
next
fix \<mu> \<nu>
assume \<mu>\<nu>: "L.seq \<nu> \<mu>"
have \<mu>: "L.arr \<mu>"
using \<mu>\<nu> by (elim L.seqE, auto)
have \<nu>: "L.arr \<nu> \<and> arr \<nu> \<and> in_hom \<nu> (L.cod \<mu>) (L.cod \<nu>) \<and> left g \<nu> \<and> g \<star> \<nu> \<noteq> null"
proof -
have 1: "L.in_hom \<nu> (L.cod \<mu>) (L.cod \<nu>)"
using \<mu>\<nu> by (elim L.seqE, auto)
hence "arr \<nu> \<and> left g \<nu>"
using L.hom_char by blast
thus ?thesis
using assms 1 left_def by fastforce
qed
show "H\<^sub>L g (L.comp \<nu> \<mu>) = L.comp (H\<^sub>L g \<nu>) (H\<^sub>L g \<mu>)"
proof -
have "H\<^sub>L g (L.comp \<nu> \<mu>) = g \<star> (\<nu> \<cdot> \<mu>)"
using \<mu> \<nu> H\<^sub>L_def L.comp_def L.arr_char by fastforce
also have "... = (g \<star> \<nu>) \<cdot> (g \<star> \<mu>)"
using assms \<mu> \<nu> L.inclusion whisker_left L.arr_char by fastforce
also have "... = L.comp (H\<^sub>L g \<nu>) (H\<^sub>L g \<mu>)"
using assms \<mu>\<nu> \<mu> \<nu> * preserves_arr L.arr_char L.dom_char L.cod_char L.comp_char
L.inclusion H\<^sub>L_def left_def
by auto
finally show ?thesis by blast
qed
qed
qed
lemma endofunctor_H\<^sub>R:
assumes "ide f" and "f \<star> f \<noteq> null"
shows "endofunctor (Right f) (H\<^sub>R f)"
proof -
interpret R: subcategory V \<open>right f\<close> using assms right_hom_is_subcategory by simp
have *: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> H\<^sub>R f \<mu> = \<mu> \<star> f"
using assms H\<^sub>R_def by simp
have preserves_arr: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R f \<mu>)"
using assms * R.arr_char right_def match_3 by force
show "endofunctor R.comp (H\<^sub>R f)"
proof
show "\<And>\<mu>. \<not> R.arr \<mu> \<Longrightarrow> H\<^sub>R f \<mu> = R.null"
using assms R.arr_char R.null_char right_def H\<^sub>R_def by fastforce
show "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R f \<mu>)" by fact
fix \<mu>
assume "R.arr \<mu>"
hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> \<mu> \<star> f \<noteq> null"
using assms R.arr_char composable_implies_arr right_def by simp
show "R.dom (H\<^sub>R f \<mu>) = H\<^sub>R f (R.dom \<mu>)"
using assms \<mu> * R.arr_char R.dom_char preserves_arr hom_connected(1) right_def
by simp
show "R.cod (H\<^sub>R f \<mu>) = H\<^sub>R f (R.cod \<mu>)"
using assms \<mu> * R.arr_char R.cod_char preserves_arr hom_connected(3) right_def
by simp
next
fix \<mu> \<nu>
assume \<mu>\<nu>: "R.seq \<nu> \<mu>"
have \<mu>: "R.arr \<mu>"
using \<mu>\<nu> by (elim R.seqE, auto)
have \<nu>: "R.arr \<nu> \<and> arr \<nu> \<and> in_hom \<nu> (R.cod \<mu>) (R.cod \<nu>) \<and> right f \<nu> \<and> \<nu> \<star> f \<noteq> null"
proof -
have 1: "R.in_hom \<nu> (R.cod \<mu>) (R.cod \<nu>)"
using \<mu>\<nu> by (elim R.seqE, auto)
hence "arr \<nu> \<and> right f \<nu>"
using R.hom_char by blast
thus ?thesis
using assms 1 right_def by fastforce
qed
show "H\<^sub>R f (R.comp \<nu> \<mu>) = R.comp (H\<^sub>R f \<nu>) (H\<^sub>R f \<mu>)"
proof -
have "H\<^sub>R f (R.comp \<nu> \<mu>) = (\<nu> \<cdot> \<mu>) \<star> f"
using \<mu> \<nu> H\<^sub>R_def R.comp_def R.arr_char by fastforce
also have "... = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
using assms \<mu> \<nu> R.inclusion whisker_right R.arr_char by fastforce
also have "... = R.comp (H\<^sub>R f \<nu>) (H\<^sub>R f \<mu>)"
using assms \<mu>\<nu> \<mu> \<nu> * preserves_arr R.arr_char R.dom_char R.cod_char R.comp_char
R.inclusion H\<^sub>R_def right_def
by auto
finally show ?thesis by blast
qed
qed
qed
end
locale left_hom =
weak_composition V H +
S: subcategory V \<open>left \<omega>\<close>
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a comp" (infixr "\<star>" 53)
and \<omega> :: 'a +
assumes arr_\<omega>: "arr \<omega>"
begin
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
notation S.comp (infixr "\<cdot>\<^sub>S" 55)
notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
lemma right_hcomp_closed [simp]:
assumes "\<guillemotleft>\<mu> : x \<Rightarrow>\<^sub>S y\<guillemotright>" and "\<guillemotleft>\<nu> : c \<Rightarrow> d\<guillemotright>" and "\<mu> \<star> \<nu> \<noteq> null"
shows "\<guillemotleft>\<mu> \<star> \<nu> : x \<star> c \<Rightarrow>\<^sub>S y \<star> d\<guillemotright>"
proof
show 1: "S.arr (\<mu> \<star> \<nu>)"
using assms arr_\<omega> S.arr_char left_def match_4
by (elim S.in_homE, meson)
show "S.dom (\<mu> \<star> \<nu>) = x \<star> c"
using assms 1 by force
show "S.cod (\<mu> \<star> \<nu>) = y \<star> d"
using assms 1 by force
qed
lemma interchange:
assumes "S.seq \<nu> \<mu>" and "S.seq \<tau> \<sigma>" and "\<mu> \<star> \<sigma> \<noteq> null"
shows "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
proof -
have 1: "\<nu> \<star> \<tau> \<noteq> null"
using assms hom_connected(1) [of \<nu> \<sigma>] hom_connected(2) [of \<nu> \<tau>] hom_connected(3-4)
by force
have "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)"
using assms S.comp_char S.seq_char by metis
also have "... = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
using assms interchange S.seq_char S.arr_char by simp
also have "... = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
proof -
have "S.arr (\<nu> \<star> \<tau>)"
proof -
have "\<guillemotleft>\<tau> : dom \<tau> \<Rightarrow> cod \<tau>\<guillemotright>"
using assms S.in_hom_char by blast
thus ?thesis
using assms 1 right_hcomp_closed by blast
qed
moreover have "S.arr (\<mu> \<star> \<sigma>)"
proof -
have "\<guillemotleft>\<sigma> : dom \<sigma> \<Rightarrow> cod \<sigma>\<guillemotright>"
using assms S.in_hom_char by blast
thus ?thesis
using assms right_hcomp_closed [of \<mu> "dom \<mu>" "cod \<mu>" \<sigma> "dom \<sigma>" "cod \<sigma>"] by fastforce
qed
moreover have "seq (\<nu> \<star> \<tau>) (\<mu> \<star> \<sigma>)"
using assms 1 S.in_hom_char
by (metis (full_types) S.seq_char hcomp_simps\<^sub>W\<^sub>C(1-3) seqE seqI)
ultimately show ?thesis
using S.comp_char by auto
qed
finally show ?thesis by blast
qed
lemma inv_char:
assumes "S.arr \<phi>" and "iso \<phi>"
shows "S.inverse_arrows \<phi> (inv \<phi>)"
and "S.inv \<phi> = inv \<phi>"
proof -
have 1: "S.arr (inv \<phi>)"
proof -
have "S.arr \<phi>" using assms by auto
hence "\<omega> \<star> \<phi> \<noteq> null"
using S.arr_char left_def by simp
hence "\<omega> \<star> cod \<phi> \<noteq> null"
using hom_connected(4) by blast
hence "\<omega> \<star> dom (inv \<phi>) \<noteq> null"
using assms S.iso_char by simp
hence "\<omega> \<star> inv \<phi> \<noteq> null"
using hom_connected by blast
thus "S.arr (inv \<phi>)"
using S.arr_char left_def by force
qed
show "S.inv \<phi> = inv \<phi>"
using assms 1 S.inv_char S.iso_char by blast
thus "S.inverse_arrows \<phi> (inv \<phi>)"
using assms 1 S.iso_char S.inv_is_inverse by metis
qed
lemma iso_char:
assumes "S.arr \<phi>"
shows "S.iso \<phi> \<longleftrightarrow> iso \<phi>"
using assms S.iso_char inv_char by auto
end
locale right_hom =
weak_composition V H +
S: subcategory V \<open>right \<omega>\<close>
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a comp" (infixr "\<star>" 53)
and \<omega> :: 'a +
assumes arr_\<omega>: "arr \<omega>"
begin
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
notation S.comp (infixr "\<cdot>\<^sub>S" 55)
notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
lemma left_hcomp_closed [simp]:
assumes "\<guillemotleft>\<mu> : x \<Rightarrow>\<^sub>S y\<guillemotright>" and "\<guillemotleft>\<nu> : c \<Rightarrow> d\<guillemotright>" and "\<nu> \<star> \<mu> \<noteq> null"
shows "\<guillemotleft>\<nu> \<star> \<mu> : c \<star> x \<Rightarrow>\<^sub>S d \<star> y\<guillemotright>"
proof
show 1: "S.arr (\<nu> \<star> \<mu>)"
using assms arr_\<omega> S.arr_char right_def match_3
by (elim S.in_homE, meson)
show "S.dom (\<nu> \<star> \<mu>) = c \<star> x"
using assms 1 by force
show "S.cod (\<nu> \<star> \<mu>) = d \<star> y"
using assms 1 by force
qed
lemma interchange:
assumes "S.seq \<nu> \<mu>" and "S.seq \<tau> \<sigma>" and "\<mu> \<star> \<sigma> \<noteq> null"
shows "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
proof -
have 1: "\<nu> \<star> \<tau> \<noteq> null"
using assms hom_connected(1) [of \<nu> \<sigma>] hom_connected(2) [of \<nu> \<tau>] hom_connected(3-4)
by fastforce
have "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)"
using assms S.comp_char S.seq_char by metis
also have "... = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
using assms interchange S.seq_char S.arr_char by simp
also have "... = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
proof -
have "S.arr (\<nu> \<star> \<tau>)"
proof -
have "\<guillemotleft>\<nu> : dom \<nu> \<Rightarrow> cod \<nu>\<guillemotright>"
using assms S.in_hom_char by blast
thus ?thesis
using assms 1 left_hcomp_closed by blast
qed
moreover have "S.arr (\<mu> \<star> \<sigma>)"
proof -
have "\<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
using assms S.in_hom_char by blast
thus ?thesis
using assms left_hcomp_closed [of \<sigma> "dom \<sigma>" "cod \<sigma>" \<mu> "dom \<mu>" "cod \<mu>"]
by fastforce
qed
moreover have "seq (\<nu> \<star> \<tau>) (\<mu> \<star> \<sigma>)"
using assms 1 S.in_hom_char
by (metis (full_types) S.seq_char hcomp_simps\<^sub>W\<^sub>C(1-3) seqE seqI)
ultimately show ?thesis
using S.comp_char by auto
qed
finally show ?thesis by blast
qed
lemma inv_char:
assumes "S.arr \<phi>" and "iso \<phi>"
shows "S.inverse_arrows \<phi> (inv \<phi>)"
and "S.inv \<phi> = inv \<phi>"
proof -
have 1: "S.arr (inv \<phi>)"
proof -
have "S.arr \<phi>" using assms by auto
hence "\<phi> \<star> \<omega> \<noteq> null"
using S.arr_char right_def by simp
hence "cod \<phi> \<star> \<omega> \<noteq> null"
using hom_connected(3) by blast
hence "dom (inv \<phi>) \<star> \<omega> \<noteq> null"
using assms S.iso_char by simp
hence "inv \<phi> \<star> \<omega> \<noteq> null"
using hom_connected(1) by blast
thus ?thesis
using S.arr_char right_def by force
qed
show "S.inv \<phi> = inv \<phi>"
using assms 1 S.inv_char S.iso_char by blast
thus "S.inverse_arrows \<phi> (inv \<phi>)"
using assms 1 S.iso_char S.inv_is_inverse by metis
qed
lemma iso_char:
assumes "S.arr \<phi>"
shows "S.iso \<phi> \<longleftrightarrow> iso \<phi>"
using assms S.iso_char inv_char by auto
end
subsection "Weak Units"
text \<open>
We now define a \emph{weak unit} to be an arrow \<open>a\<close> such that:
\begin{enumerate}
\item \<open>a \<star> a\<close> is isomorphic to \<open>a\<close>
(and hence \<open>a\<close> is a horizontally self-composable 1-cell).
\item Horizontal composition on the left with \<open>a\<close> is a fully faithful endofunctor of the
subcategory of arrows that are composable on the left with \<open>a\<close>.
\item Horizontal composition on the right with \<open>a\<close> is fully faithful endofunctor of the
subcategory of arrows that are composable on the right with \<open>a\<close>.
\end{enumerate}
\<close>
context weak_composition
begin
definition weak_unit :: "'a \<Rightarrow> bool"
where "weak_unit a \<equiv> a \<star> a \<cong> a \<and>
fully_faithful_functor (Left a) (Left a) (H\<^sub>L a) \<and>
fully_faithful_functor (Right a) (Right a) (H\<^sub>R a)"
lemma weak_unit_self_composable [simp]:
assumes "weak_unit a"
shows "ide a" and "ide (a \<star> a)" and "a \<star> a \<noteq> null"
proof -
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
using assms weak_unit_def isomorphic_def by blast
have 1: "arr \<phi>" using \<phi> by blast
show "ide a" using \<phi> ide_cod by blast
thus "ide (a \<star> a)" using \<phi> ide_dom by force
thus "a \<star> a \<noteq> null" using not_arr_null ideD(1) by metis
qed
lemma weak_unit_self_right:
assumes "weak_unit a"
shows "right a a"
using assms weak_unit_self_composable right_def by simp
lemma weak_unit_self_left:
assumes "weak_unit a"
shows "left a a"
using assms weak_unit_self_composable left_def by simp
lemma weak_unit_in_vhom:
assumes "weak_unit a"
shows "\<guillemotleft>a : a \<Rightarrow> a\<guillemotright>"
using assms weak_unit_self_composable left_def by auto
text \<open>
If \<open>a\<close> is a weak unit, then there exists a ``unit isomorphism'' \<open>\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
It need not be unique, but we may choose one arbitrarily.
\<close>
definition some_unit
where "some_unit a \<equiv> SOME \<iota>. iso \<iota> \<and> \<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
lemma iso_some_unit:
assumes "weak_unit a"
shows "iso (some_unit a)"
and "\<guillemotleft>some_unit a : a \<star> a \<Rightarrow> a\<guillemotright>"
proof -
let ?P = "\<lambda>\<iota>. iso \<iota> \<and> \<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
have "\<exists>\<iota>. ?P \<iota>"
using assms weak_unit_def by auto
hence 1: "?P (some_unit a)"
using someI_ex [of ?P] some_unit_def by simp
show "iso (some_unit a)" using 1 by blast
show "\<guillemotleft>some_unit a : a \<star> a \<Rightarrow> a\<guillemotright>" using 1 by blast
qed
text \<open>
The \emph{sources} of an arbitrary arrow \<open>\<mu>\<close> are the weak units that are composable with \<open>\<mu>\<close>
on the right. Similarly, the \emph{targets} of \<open>\<mu>\<close> are the weak units that are composable
with \<open>\<mu>\<close> on the left.
\<close>
definition sources
where "sources \<mu> \<equiv> {a. weak_unit a \<and> \<mu> \<star> a \<noteq> null}"
lemma sourcesI [intro]:
assumes "weak_unit a" and "\<mu> \<star> a \<noteq> null"
shows "a \<in> sources \<mu>"
using assms sources_def by blast
lemma sourcesD [dest]:
assumes "a \<in> sources \<mu>"
shows "ide a" and "weak_unit a" and "\<mu> \<star> a \<noteq> null"
using assms sources_def by auto
definition targets
where "targets \<mu> \<equiv> {b. weak_unit b \<and> b \<star> \<mu> \<noteq> null}"
lemma targetsI [intro]:
assumes "weak_unit b" and "b \<star> \<mu> \<noteq> null"
shows "b \<in> targets \<mu>"
using assms targets_def by blast
lemma targetsD [dest]:
assumes "b \<in> targets \<mu>"
shows "ide b" and "weak_unit b" and "b \<star> \<mu> \<noteq> null"
using assms targets_def by auto
lemma sources_dom [simp]:
assumes "arr \<mu>"
shows "sources (dom \<mu>) = sources \<mu>"
using assms hom_connected(1) by blast
lemma sources_cod [simp]:
assumes "arr \<mu>"
shows "sources (cod \<mu>) = sources \<mu>"
using assms hom_connected(3) by blast
lemma targets_dom [simp]:
assumes "arr \<mu>"
shows "targets (dom \<mu>) = targets \<mu>"
using assms hom_connected(2) by blast
lemma targets_cod [simp]:
assumes "arr \<mu>"
shows "targets (cod \<mu>) = targets \<mu>"
using assms hom_connected(4) by blast
lemma weak_unit_iff_self_source:
shows "weak_unit a \<longleftrightarrow> a \<in> sources a"
using weak_unit_self_composable by auto
lemma weak_unit_iff_self_target:
shows "weak_unit b \<longleftrightarrow> b \<in> targets b"
using weak_unit_self_composable by auto
abbreviation (input) in_hhom\<^sub>W\<^sub>C ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>W\<^sub>C _\<guillemotright>")
where "in_hhom\<^sub>W\<^sub>C \<mu> f g \<equiv> arr \<mu> \<and> f \<in> sources \<mu> \<and> g \<in> targets \<mu>"
lemma sources_hcomp:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "sources (\<nu> \<star> \<mu>) = sources \<mu>"
using assms match_1 match_3 null_agreement by blast
lemma targets_hcomp:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "targets (\<nu> \<star> \<mu>) = targets \<nu>"
using assms match_2 match_4 null_agreement by blast
lemma H\<^sub>R_preserved_along_iso:
assumes "weak_unit a" and "a \<cong> a'"
shows "endofunctor (Right a) (H\<^sub>R a')"
proof -
have a: "ide a \<and> weak_unit a" using assms isomorphic_def by auto
have a': "ide a'" using assms isomorphic_def by auto
(* TODO: The following interpretation re-introduces unwanted notation for "in_hom" *)
interpret R: subcategory V \<open>right a\<close> using a right_hom_is_subcategory by simp
have *: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> H\<^sub>R a' \<mu> = \<mu> \<star> a'"
using assms H\<^sub>R_def by simp
have preserves_arr: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R a' \<mu>)"
using assms a' * R.arr_char right_def weak_unit_def weak_unit_self_composable
isomorphic_implies_equicomposable R.ide_char match_3 hcomp_simps\<^sub>W\<^sub>C(1)
null_agreement
by metis
show "endofunctor R.comp (H\<^sub>R a')"
proof
show "\<And>\<mu>. \<not> R.arr \<mu> \<Longrightarrow> H\<^sub>R a' \<mu> = R.null"
using assms R.arr_char R.null_char right_def H\<^sub>R_def null_agreement
right_respects_isomorphic
by metis
fix \<mu>
assume "R.arr \<mu>"
hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> right a \<mu> \<and> right a' \<mu> \<and> \<mu> \<star> a \<noteq> null \<and> \<mu> \<star> a' \<noteq> null"
using assms R.arr_char right_respects_isomorphic composable_implies_arr null_agreement
right_def
by metis
show "R.arr (H\<^sub>R a' \<mu>)" using \<mu> preserves_arr by blast
show "R.dom (H\<^sub>R a' \<mu>) = H\<^sub>R a' (R.dom \<mu>)"
using a' \<mu> * R.arr_char R.dom_char preserves_arr hom_connected(1) right_def
by simp
show "R.cod (H\<^sub>R a' \<mu>) = H\<^sub>R a' (R.cod \<mu>)"
using a' \<mu> * R.arr_char R.cod_char preserves_arr hom_connected(3) right_def
by simp
next
fix \<mu> \<nu>
assume \<mu>\<nu>: "R.seq \<nu> \<mu>"
have "R.arr \<mu>"
using \<mu>\<nu> by (elim R.seqE, auto)
hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> right a \<mu> \<and> right a' \<mu> \<and> \<mu> \<star> a \<noteq> null \<and> \<mu> \<star> a' \<noteq> null"
using assms R.arr_char right_respects_isomorphic composable_implies_arr null_agreement
right_def
by metis
have "\<nu> \<in> R.hom (R.cod \<mu>) (R.cod \<nu>)"
using \<mu>\<nu> by (elim R.seqE, auto)
hence "\<guillemotleft>\<nu> : R.cod \<mu> \<Rightarrow> R.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and> \<nu> \<in> Collect (right a)"
using R.hom_char by blast
hence \<nu>: "\<guillemotleft>\<nu> : R.cod \<mu> \<rightarrow> R.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and>
right a \<nu> \<and> H \<nu> a \<noteq> null \<and> right a' \<nu> \<and> H \<nu> a' \<noteq> null"
using assms right_def right_respects_isomorphic isomorphic_implies_equicomposable
by simp
show "H\<^sub>R a' (R.comp \<nu> \<mu>) = R.comp (H\<^sub>R a' \<nu>) (H\<^sub>R a' \<mu>)"
proof -
have 1: "R.arr (H\<^sub>R a' \<nu>)"
using \<nu> preserves_arr by blast
have 2: "seq (\<nu> \<star> a') (\<mu> \<star> a')"
using a' \<mu> \<nu> R.arr_char R.inclusion R.dom_char R.cod_char
isomorphic_implies_equicomposable
by auto
show ?thesis
proof -
have "H\<^sub>R a' (R.comp \<nu> \<mu>) = (\<nu> \<cdot> \<mu>) \<star> a'"
using \<mu> \<nu> H\<^sub>R_def R.comp_def by fastforce
also have "... = (\<nu> \<star> a') \<cdot> (\<mu> \<star> a')"
proof -
have "seq \<nu> \<mu>"
using \<mu> \<nu> \<mu>\<nu> by (elim R.seqE, auto)
thus ?thesis
using a' \<nu> whisker_right right_def by blast
qed
also have "... = R.comp (H\<^sub>R a' \<nu>) (H\<^sub>R a' \<mu>)"
using assms \<mu> 1 2 preserves_arr R.comp_char R.inclusion H\<^sub>R_def by auto
finally show ?thesis by blast
qed
qed
qed
qed
lemma H\<^sub>L_preserved_along_iso:
assumes "weak_unit a" and "a \<cong> a'"
shows "endofunctor (Left a) (H\<^sub>L a')"
proof -
have a: "ide a \<and> weak_unit a" using assms isomorphic_def by auto
have a': "ide a'" using assms isomorphic_def by auto
(* TODO: The following interpretation re-introduces unwanted notation for "in_hom" *)
interpret L: subcategory V \<open>left a\<close> using a left_hom_is_subcategory by simp
have *: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> H\<^sub>L a' \<mu> = a' \<star> \<mu>"
using assms H\<^sub>L_def by simp
have preserves_arr: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L a' \<mu>)"
using assms a' * L.arr_char left_def weak_unit_def weak_unit_self_composable
isomorphic_implies_equicomposable L.ide_char match_4 hcomp_simps\<^sub>W\<^sub>C(1)
null_agreement
by metis
show "endofunctor L.comp (H\<^sub>L a')"
proof
show "\<And>\<mu>. \<not> L.arr \<mu> \<Longrightarrow> H\<^sub>L a' \<mu> = L.null"
using assms L.arr_char L.null_char left_def H\<^sub>L_def null_agreement
left_respects_isomorphic
by metis
fix \<mu>
assume "L.arr \<mu>"
hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> left a \<mu> \<and> left a' \<mu> \<and> a \<star> \<mu> \<noteq> null \<and> a' \<star> \<mu> \<noteq> null"
using assms L.arr_char left_respects_isomorphic composable_implies_arr null_agreement
left_def
by metis
show "L.arr (H\<^sub>L a' \<mu>)" using \<mu> preserves_arr by blast
show "L.dom (H\<^sub>L a' \<mu>) = H\<^sub>L a' (L.dom \<mu>)"
using a' \<mu> * L.arr_char L.dom_char preserves_arr hom_connected(2) left_def
by simp
show "L.cod (H\<^sub>L a' \<mu>) = H\<^sub>L a' (L.cod \<mu>)"
using a' \<mu> * L.arr_char L.cod_char preserves_arr hom_connected(4) left_def
by simp
next
fix \<mu> \<nu>
assume \<mu>\<nu>: "L.seq \<nu> \<mu>"
have "L.arr \<mu>"
using \<mu>\<nu> by (elim L.seqE, auto)
hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> left a \<mu> \<and> left a' \<mu> \<and> a \<star> \<mu> \<noteq> null \<and> a' \<star> \<mu> \<noteq> null"
using assms L.arr_char left_respects_isomorphic composable_implies_arr null_agreement
left_def
by metis
have "L.in_hom \<nu> (L.cod \<mu>) (L.cod \<nu>)"
using \<mu>\<nu> by (elim L.seqE, auto)
hence "\<guillemotleft>\<nu> : L.cod \<mu> \<Rightarrow> L.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and> \<nu> \<in> Collect (left a)"
using L.hom_char by blast
hence \<nu>: "\<guillemotleft>\<nu> : L.cod \<mu> \<Rightarrow> L.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and>
left a \<nu> \<and> a \<star> \<nu> \<noteq> null \<and> left a' \<nu> \<and> a' \<star> \<nu> \<noteq> null"
using assms left_def left_respects_isomorphic isomorphic_implies_equicomposable
by simp
show "H\<^sub>L a' (L.comp \<nu> \<mu>) = L.comp (H\<^sub>L a' \<nu>) (H\<^sub>L a' \<mu>)"
proof -
have 1: "L.arr (H\<^sub>L a' \<nu>)"
using \<nu> preserves_arr by blast
have 2: "seq (a' \<star> \<nu>) (a' \<star> \<mu>)"
using a' \<mu> \<nu> L.arr_char L.inclusion L.dom_char L.cod_char
isomorphic_implies_equicomposable
by auto
- have "H\<^sub>L a' (L.comp \<nu> \<mu>) = a' \<star> (\<nu> \<cdot> \<mu>)"
- using \<mu> \<nu> H\<^sub>L_def L.comp_def by fastforce
- also have "... = (a' \<star> \<nu>) \<cdot> (a' \<star> \<mu>)"
- proof -
- have "seq \<nu> \<mu>"
- using \<mu> \<nu> \<mu>\<nu> by (elim L.seqE, auto)
- thus ?thesis
- using a' \<nu> whisker_left right_def by blast
- qed
- also have "... = L.comp (H\<^sub>L a' \<nu>) (H\<^sub>L a' \<mu>)"
- using assms \<mu> 1 2 preserves_arr L.comp_char L.inclusion H\<^sub>L_def by auto
- finally show ?thesis by blast
+ have "H\<^sub>L a' (L.comp \<nu> \<mu>) = a' \<star> (\<nu> \<cdot> \<mu>)"
+ using \<mu> \<nu> H\<^sub>L_def L.comp_def by fastforce
+ also have "... = (a' \<star> \<nu>) \<cdot> (a' \<star> \<mu>)"
+ proof -
+ have "seq \<nu> \<mu>"
+ using \<mu> \<nu> \<mu>\<nu> by (elim L.seqE, auto)
+ thus ?thesis
+ using a' \<nu> whisker_left right_def by blast
+ qed
+ also have "... = L.comp (H\<^sub>L a' \<nu>) (H\<^sub>L a' \<mu>)"
+ using assms \<mu> 1 2 preserves_arr L.comp_char L.inclusion H\<^sub>L_def by auto
+ finally show ?thesis by blast
qed
qed
qed
end
subsection "Regularity"
text \<open>
We call a weak composition \emph{regular} if \<open>f \<star> a \<cong> f\<close> whenever \<open>a\<close> is a source of
1-cell \<open>f\<close>, and \<open>b \<star> f \<cong> f\<close> whenever \<open>b\<close> is a target of \<open>f\<close>. A consequence of regularity
is that horizontal composability of 2-cells is fully determined by their sets of
sources and targets.
\<close>
locale regular_weak_composition =
weak_composition +
assumes comp_ide_source: "\<lbrakk> a \<in> sources f; ide f \<rbrakk> \<Longrightarrow> f \<star> a \<cong> f"
and comp_target_ide: "\<lbrakk> b \<in> targets f; ide f \<rbrakk> \<Longrightarrow> b \<star> f \<cong> f"
begin
lemma sources_determine_composability:
assumes "a \<in> sources \<tau>"
shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
proof -
have *: "\<And>\<tau>. ide \<tau> \<and> a \<in> sources \<tau> \<Longrightarrow> \<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
proof -
fix \<tau>
assume \<tau>: "ide \<tau> \<and> a \<in> sources \<tau>"
show "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
proof
assume \<mu>: "\<tau> \<star> \<mu> \<noteq> null"
show "a \<star> \<mu> \<noteq> null"
using assms \<mu> \<tau> comp_ide_source isomorphic_implies_equicomposable match_1
by blast
next
assume \<mu>: "a \<star> \<mu> \<noteq> null"
show "\<tau> \<star> \<mu> \<noteq> null"
using assms \<mu> \<tau> comp_ide_source isomorphic_implies_equicomposable match_3
by blast
qed
qed
show ?thesis
proof -
have "arr \<tau>" using assms composable_implies_arr by auto
thus ?thesis
using assms * [of "dom \<tau>"] hom_connected(1) by auto
qed
qed
lemma targets_determine_composability:
assumes "b \<in> targets \<mu>"
shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
proof -
have *: "\<And>\<mu>. ide \<mu> \<and> b \<in> targets \<mu> \<Longrightarrow> \<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
proof -
fix \<mu>
assume \<mu>: "ide \<mu> \<and> b \<in> targets \<mu>"
show "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
proof
assume \<tau>: "\<tau> \<star> \<mu> \<noteq> null"
show "\<tau> \<star> b \<noteq> null"
using assms \<mu> \<tau> comp_target_ide isomorphic_implies_equicomposable match_2
by blast
next
assume \<tau>: "\<tau> \<star> b \<noteq> null"
show "\<tau> \<star> \<mu> \<noteq> null"
using assms \<mu> \<tau> comp_target_ide isomorphic_implies_equicomposable match_4
by blast
qed
qed
show ?thesis
proof -
have "arr \<mu>" using assms composable_implies_arr by auto
thus ?thesis
using assms * [of "dom \<mu>"] hom_connected(2) by auto
qed
qed
lemma composable_if_connected:
assumes "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
shows "\<nu> \<star> \<mu> \<noteq> null"
using assms targets_determine_composability by blast
lemma connected_if_composable:
assumes "\<nu> \<star> \<mu> \<noteq> null"
shows "sources \<nu> = targets \<mu>"
using assms sources_determine_composability targets_determine_composability by blast
lemma iso_hcomp\<^sub>R\<^sub>W\<^sub>C:
assumes "iso \<mu>" and "iso \<nu>" and "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
shows "iso (\<nu> \<star> \<mu>)"
and "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
proof -
have \<mu>: "arr \<mu> \<and> \<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright> \<and>
iso \<mu> \<and> \<guillemotleft>inv \<mu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
using assms inv_in_hom arr_iff_in_hom iso_is_arr by auto
have \<nu>: "arr \<nu> \<and> \<guillemotleft>\<nu> : dom \<nu> \<Rightarrow> cod \<nu>\<guillemotright> \<and>
iso \<nu> \<and> \<guillemotleft>inv \<nu> : cod \<nu> \<Rightarrow> dom \<nu>\<guillemotright>"
using assms inv_in_hom by blast
have 1: "sources (inv \<nu>) \<inter> targets (inv \<mu>) \<noteq> {}"
proof -
have "sources (inv \<nu>) \<inter> targets (inv \<mu>) = sources \<nu> \<inter> targets \<mu>"
proof -
have "sources (inv \<nu>) \<inter> targets (inv \<mu>)
= sources (cod (inv \<nu>)) \<inter> targets (cod (inv \<mu>))"
using assms \<mu> \<nu> sources_cod targets_cod arr_inv by presburger
also have "... = sources (dom \<nu>) \<inter> targets (dom \<mu>)"
using \<mu> \<nu> by simp
also have "... = sources \<nu> \<inter> targets \<mu>"
using \<mu> \<nu> sources_dom targets_dom by simp
finally show ?thesis by blast
qed
thus ?thesis using assms by simp
qed
show "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
proof
have "(inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
using assms \<mu> \<nu> inv_in_hom inv_is_inverse comp_inv_arr
interchange [of "inv \<nu>" \<nu> "inv \<mu>" \<mu>] composable_if_connected
by simp
moreover have "ide (dom \<nu> \<star> dom \<mu>)"
using assms \<mu> \<nu> ide_hcomp\<^sub>W\<^sub>C composable_if_connected sources_dom targets_dom
by auto
ultimately show "ide ((inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>))"
by presburger
have "(\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>) = cod \<nu> \<star> cod \<mu>"
using assms 1 \<mu> \<nu> inv_in_hom inv_is_inverse comp_arr_inv
interchange [of \<nu> "inv \<nu>" \<mu> "inv \<mu>"] composable_if_connected
by simp
moreover have "ide (cod \<nu> \<star> cod \<mu>)"
using assms \<mu> \<nu> ide_hcomp\<^sub>W\<^sub>C composable_if_connected sources_cod targets_cod
by auto
ultimately show "ide ((\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>))"
by presburger
qed
thus "iso (\<nu> \<star> \<mu>)" by auto
qed
lemma inv_hcomp\<^sub>R\<^sub>W\<^sub>C:
assumes "iso \<mu>" and "iso \<nu>" and "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
shows "inv (\<nu> \<star> \<mu>) = inv \<nu> \<star> inv \<mu>"
using assms iso_hcomp\<^sub>R\<^sub>W\<^sub>C(2) [of \<mu> \<nu>] inverse_arrow_unique [of "H \<nu> \<mu>"] inv_is_inverse
by auto
end
subsection "Associativity"
text \<open>
An \emph{associative weak composition} consists of a weak composition that has been
equipped with an \emph{associator} isomorphism: \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>\<close>
for each composable triple \<open>(f, g, h)\<close> of 1-cells, subject to naturality and
coherence conditions.
\<close>
locale associative_weak_composition =
weak_composition +
fixes \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
assumes assoc_in_vhom\<^sub>A\<^sub>W\<^sub>C:
"\<lbrakk> ide f; ide g; ide h; f \<star> g \<noteq> null; g \<star> h \<noteq> null \<rbrakk> \<Longrightarrow>
\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
and assoc_naturality\<^sub>A\<^sub>W\<^sub>C:
"\<lbrakk> \<tau> \<star> \<mu> \<noteq> null; \<mu> \<star> \<nu> \<noteq> null \<rbrakk> \<Longrightarrow>
\<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
and iso_assoc\<^sub>A\<^sub>W\<^sub>C: "\<lbrakk> ide f; ide g; ide h; f \<star> g \<noteq> null; g \<star> h \<noteq> null \<rbrakk> \<Longrightarrow> iso \<a>[f, g, h]"
and pentagon\<^sub>A\<^sub>W\<^sub>C:
"\<lbrakk> ide f; ide g; ide h; ide k; sources f \<inter> targets g \<noteq> {};
sources g \<inter> targets h \<noteq> {}; sources h \<inter> targets k \<noteq> {} \<rbrakk> \<Longrightarrow>
(f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) = \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
begin
lemma assoc_in_hom\<^sub>A\<^sub>W\<^sub>C:
assumes "ide f" and "ide g" and "ide h"
and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
shows "sources \<a>[f, g, h] = sources h" and "targets \<a>[f, g, h] = targets f"
and "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
proof -
show 1: "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
using assms assoc_in_vhom\<^sub>A\<^sub>W\<^sub>C by simp
show "sources \<a>[f, g, h] = sources h"
using assms 1 sources_dom [of "\<a>[f, g, h]"] sources_hcomp match_3
by (elim in_homE, auto)
show "targets \<a>[f, g, h] = targets f"
using assms 1 targets_cod [of "\<a>[f, g, h]"] targets_hcomp match_4
by (elim in_homE, auto)
qed
lemma assoc_simps\<^sub>A\<^sub>W\<^sub>C [simp]:
assumes "ide f" and "ide g" and "ide h"
and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
shows "arr \<a>[f, g, h]"
and "dom \<a>[f, g, h] = (f \<star> g) \<star> h"
and "cod \<a>[f, g, h] = f \<star> g \<star> h"
proof -
have 1: "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
using assms assoc_in_hom\<^sub>A\<^sub>W\<^sub>C by auto
show "arr \<a>[f, g, h]" using 1 by auto
show "dom \<a>[f, g, h] = (f \<star> g) \<star> h" using 1 by auto
show "cod \<a>[f, g, h] = f \<star> g \<star> h" using 1 by auto
qed
lemma assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C:
assumes "ide f" and "ide g" and "ide h"
and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
shows "sources (inv \<a>[f, g, h]) = sources h" and "targets (inv \<a>[f, g, h]) = targets f"
and "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
proof -
show 1: "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
using assms assoc_in_hom\<^sub>A\<^sub>W\<^sub>C iso_assoc\<^sub>A\<^sub>W\<^sub>C inv_in_hom by auto
show "sources (inv \<a>[f, g, h]) = sources h"
using assms 1 sources_hcomp [of "f \<star> g" h] sources_cod match_3 null_agreement
by (elim in_homE, metis)
show "targets (inv \<a>[f, g, h]) = targets f"
using assms 1 targets_hcomp [of f "g \<star> h"] targets_dom match_4 null_agreement
by (elim in_homE, metis)
qed
lemma assoc'_simps\<^sub>A\<^sub>W\<^sub>C [simp]:
assumes "ide f" and "ide g" and "ide h"
and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
shows "arr (inv \<a>[f, g, h])"
and "dom (inv \<a>[f, g, h]) = f \<star> g \<star> h"
and "cod (inv \<a>[f, g, h]) = (f \<star> g) \<star> h"
proof -
have 1: "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
using assms assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C by auto
show "arr (inv \<a>[f, g, h])" using 1 by auto
show "dom (inv \<a>[f, g, h]) = f \<star> g \<star> h" using 1 by auto
show "cod (inv \<a>[f, g, h]) = (f \<star> g) \<star> h" using 1 by auto
qed
lemma assoc'_naturality\<^sub>A\<^sub>W\<^sub>C:
assumes "\<tau> \<star> \<mu> \<noteq> null" and "\<mu> \<star> \<nu> \<noteq> null"
shows "inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) = ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> inv \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
proof -
have \<tau>\<mu>\<nu>: "arr \<tau> \<and> arr \<mu> \<and> arr \<nu>"
using assms composable_implies_arr by simp
have 0: "dom \<tau> \<star> dom \<mu> \<noteq> null \<and> dom \<mu> \<star> dom \<nu> \<noteq> null \<and>
cod \<tau> \<star> cod \<mu> \<noteq> null \<and> cod \<mu> \<star> cod \<nu> \<noteq> null"
using assms \<tau>\<mu>\<nu> hom_connected by simp
have 1: "\<guillemotleft>\<tau> \<star> \<mu> \<star> \<nu> : dom \<tau> \<star> dom \<mu> \<star> dom \<nu> \<Rightarrow> cod \<tau> \<star> cod \<mu> \<star> cod \<nu>\<guillemotright>"
using assms match_4 by auto
have 2: "\<guillemotleft>(\<tau> \<star> \<mu>) \<star> \<nu> : (dom \<tau> \<star> dom \<mu>) \<star> dom \<nu> \<Rightarrow> (cod \<tau> \<star> cod \<mu>) \<star> cod \<nu>\<guillemotright>"
using assms match_3 by auto
have "(inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>)) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>] = (\<tau> \<star> \<mu>) \<star> \<nu>"
proof -
have "(\<tau> \<star> \<mu>) \<star> \<nu> = (inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>]) \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
using 0 2 \<tau>\<mu>\<nu> assoc_in_hom\<^sub>A\<^sub>W\<^sub>C iso_assoc\<^sub>A\<^sub>W\<^sub>C comp_inv_arr inv_is_inverse comp_cod_arr
by auto
also have "... = inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
using comp_assoc by auto
also have "... = inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
using assms \<tau>\<mu>\<nu> 0 2 assoc_naturality\<^sub>A\<^sub>W\<^sub>C by presburger
also have "... = (inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>)) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
using comp_assoc by auto
finally show ?thesis by argo
qed
thus ?thesis
using 0 1 2 \<tau>\<mu>\<nu> iso_assoc\<^sub>A\<^sub>W\<^sub>C assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C inv_in_hom invert_side_of_triangle(2)
by auto
qed
end
subsection "Unitors"
text \<open>
For an associative weak composition with a chosen unit isomorphism \<open>\<iota> : a \<star> a \<Rightarrow> a\<close>,
where \<open>a\<close> is a weak unit, horizontal composition on the right by \<open>a\<close> is a fully faithful
endofunctor \<open>R\<close> of the subcategory of arrows composable on the right with \<open>a\<close>, and is
consequently an endo-equivalence of that subcategory. This equivalence, together with the
associator isomorphisms and unit isomorphism \<open>\<iota>\<close>, canonically associate, with each
identity arrow \<open>f\<close> composable on the right with \<open>a\<close>, a \emph{right unit} isomorphism
\<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close>. These isomorphisms are the components of a natural isomorphism
from \<open>R\<close> to the identity functor.
\<close>
locale right_hom_with_unit =
associative_weak_composition V H \<a> +
right_hom V H a
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a comp" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<iota> :: 'a
and a :: 'a +
assumes weak_unit_a: "weak_unit a"
and \<iota>_in_hom: "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
and iso_\<iota>: "iso \<iota>"
begin
abbreviation R
where "R \<equiv> H\<^sub>R a"
interpretation R: endofunctor S.comp R
using weak_unit_a weak_unit_self_composable endofunctor_H\<^sub>R by simp
interpretation R: fully_faithful_functor S.comp S.comp R
using weak_unit_a weak_unit_def by simp
lemma fully_faithful_functor_R:
shows "fully_faithful_functor S.comp S.comp R"
..
definition runit ("\<r>[_]")
where "runit f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
lemma iso_unit:
shows "S.iso \<iota>" and "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow>\<^sub>S a\<guillemotright>"
proof -
show "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow>\<^sub>S a\<guillemotright>"
proof -
have a: "weak_unit a \<and> S.ide a"
using weak_unit_a S.ide_char S.arr_char right_def weak_unit_self_composable
by metis
moreover have "S.arr (a \<star> a)"
using a S.ideD(1) R.preserves_arr H\<^sub>R_def by auto
ultimately show ?thesis
using a S.in_hom_char S.arr_char right_def \<iota>_in_hom
by (metis S.ideD(1) hom_connected(3) in_homE)
qed
thus "S.iso \<iota>"
using iso_\<iota> iso_char by blast
qed
lemma characteristic_iso:
assumes "S.ide f"
shows "\<guillemotleft>\<a>[f, a, a] : (f \<star> a) \<star> a \<Rightarrow>\<^sub>S f \<star> a \<star> a\<guillemotright>"
and "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright>"
and "\<guillemotleft>(f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a] : R (R f) \<Rightarrow>\<^sub>S R f\<guillemotright>"
and "S.iso ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
proof -
have f: "S.ide f \<and> ide f"
using assms S.ide_char by simp
have a: "weak_unit a \<and> ide a \<and> S.ide a"
using weak_unit_a S.ide_char weak_unit_def S.arr_char right_def
weak_unit_self_composable
by metis
have fa: "f \<star> a \<noteq> null \<and> (f \<star> a) \<star> a \<noteq> null \<and> ((f \<star> a) \<star> a) \<star> a \<noteq> null"
proof -
have "S.arr (f \<star> a) \<and> S.arr ((f \<star> a) \<star> a) \<and> S.arr (((f \<star> a) \<star> a) \<star> a)"
using assms S.ideD(1) R.preserves_arr H\<^sub>R_def by auto
thus ?thesis
using S.not_arr_null by fastforce
qed
have aa: "a \<star> a \<noteq> null"
using a S.ideD(1) R.preserves_arr H\<^sub>R_def S.not_arr_null by auto
have ia_a: "\<iota> \<star> a \<noteq> null"
using weak_unit_a hom_connected(3) weak_unit_self_composable \<iota>_in_hom by blast
have f_ia: "f \<star> \<iota> \<noteq> null"
using assms S.ide_char right_def S.arr_char hom_connected(4) \<iota>_in_hom by auto
show assoc_in_hom: "\<guillemotleft>\<a>[f, a, a] : (f \<star> a) \<star> a \<Rightarrow>\<^sub>S f \<star> a \<star> a\<guillemotright>"
using a f fa hom_connected(1) [of "\<a>[f, a, a]" a] S.arr_char right_def
match_3 match_4 S.in_hom_char
by auto
show 1: "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright>"
using a f fa iso_unit
by (simp add: f_ia ide_in_hom)
moreover have "S.iso (f \<star> \<iota>)"
using a f fa f_ia 1 VoV.arr_char VxV.inv_simp
inv_in_hom hom_connected(2) [of f "inv \<iota>"] VoV.arr_char VoV.iso_char
preserves_iso iso_char iso_\<iota>
by auto
ultimately have unit_part: "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright> \<and> S.iso (f \<star> \<iota>)"
by blast
show "S.iso ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
using assms a f fa aa hom_connected(1) [of "\<a>[f, a, a]" a] right_def
iso_assoc\<^sub>A\<^sub>W\<^sub>C iso_char S.arr_char unit_part assoc_in_hom isos_compose
using S.isos_compose S.seqI' by auto
show "\<guillemotleft>(f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a] : R (R f) \<Rightarrow>\<^sub>S R f\<guillemotright>"
unfolding H\<^sub>R_def using unit_part assoc_in_hom by blast
qed
lemma runit_char:
assumes "S.ide f"
shows "\<guillemotleft>\<r>[f] : R f \<Rightarrow>\<^sub>S f\<guillemotright>" and "R \<r>[f] = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
proof -
let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
show "\<exists>!\<mu>. ?P \<mu>"
proof -
have "\<exists>\<mu>. ?P \<mu>"
proof -
have 1: "S.ide f"
using assms S.ide_char S.arr_char by simp
moreover have "S.ide (R f)"
using 1 R.preserves_ide by simp
ultimately show ?thesis
using assms characteristic_iso(3) R.is_full by blast
qed
moreover have "\<forall>\<mu> \<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
proof
fix \<mu>
show "\<forall>\<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
using R.is_faithful [of \<mu>] by fastforce
qed
ultimately show ?thesis by blast
qed
hence "?P (THE \<mu>. ?P \<mu>)"
using theI' [of ?P] by fastforce
hence 1: "?P \<r>[f]"
unfolding runit_def by blast
show "\<guillemotleft>\<r>[f] : R f \<Rightarrow>\<^sub>S f\<guillemotright>" using 1 by fast
show "R \<r>[f] = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]" using 1 by fast
qed
lemma iso_runit:
assumes "S.ide f"
shows "S.iso \<r>[f]"
using assms characteristic_iso(4) runit_char R.reflects_iso by metis
lemma runit_eqI:
assumes "\<guillemotleft>f : a \<Rightarrow>\<^sub>S b\<guillemotright>" and "\<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright>"
and "R \<mu> = ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
shows "\<mu> = \<r>[f]"
proof -
have "S.ide f" using assms(2) S.ide_cod by auto
thus ?thesis using assms runit_char [of f] by auto
qed
lemma runit_naturality:
assumes "S.arr \<mu>"
shows "\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu> = \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>]"
proof -
have 1: "\<guillemotleft>\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu> : R (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
using assms runit_char(1) S.ide_cod by blast
have 2: "S.par (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
proof -
have "\<guillemotleft>\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>] : R (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
using assms S.ide_dom runit_char(1) by blast
thus ?thesis using 1 by (elim S.in_homE, auto)
qed
moreover have "R (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) = R (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
proof -
have 3: "\<guillemotleft>\<mu> \<star> a \<star> a : S.dom \<mu> \<star> a \<star> a \<Rightarrow>\<^sub>S S.cod \<mu> \<star> a \<star> a\<guillemotright>"
using assms weak_unit_a R.preserves_hom H\<^sub>R_def S.arr_iff_in_hom S.arr_char
by (metis match_4 weak_unit_in_vhom weak_unit_self_right S.in_hom_char
left_hcomp_closed S.not_arr_null S.null_char)
have 4: "R (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) = R \<r>[S.cod \<mu>] \<cdot>\<^sub>S R (R \<mu>)"
using assms 1 R.preserves_comp_2 by blast
also have 5: "... = ((S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.cod \<mu>, a, a]) \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
using assms R.preserves_arr runit_char S.ide_cod H\<^sub>R_def by auto
also have 6: "... = (S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
using assms S.comp_assoc by simp
also have "... = (S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
proof -
have "(\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a] = \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
proof -
have "(\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a] = (\<mu> \<star> a \<star> a) \<cdot> \<a>[S.dom \<mu>, a, a]"
using assms 3 S.ide_dom characteristic_iso(1) S.in_hom_char
S.comp_char [of "\<mu> \<star> a \<star> a" "\<a>[S.dom \<mu>, a, a]"]
by fastforce
also have "... = \<a>[S.cod \<mu>, a, a] \<cdot> ((\<mu> \<star> a) \<star> a)"
proof -
have "\<mu> \<star> a \<noteq> null"
using assms S.arr_char right_def by simp
thus ?thesis
using assms weak_unit_a assoc_naturality\<^sub>A\<^sub>W\<^sub>C [of \<mu> a a] by fastforce
qed
also have "... = \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
using S.in_hom_char S.comp_char
by (metis 2 4 5 6 R.preserves_arr S.seq_char)
finally show ?thesis by blast
qed
thus ?thesis by argo
qed
also have "... = ((S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a)) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
using S.comp_assoc by auto
also have "... = ((\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>)) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
proof -
have "\<mu> \<star> a \<star> a \<noteq> null"
using 3 S.not_arr_null by (elim S.in_homE, auto)
moreover have "S.dom \<mu> \<star> \<iota> \<noteq> null"
using assms S.not_arr_null
by (metis S.dom_char \<iota>_in_hom calculation hom_connected(1-2) in_homE)
ultimately have "(S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a) = (\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>)"
using assms weak_unit_a iso_unit S.comp_arr_dom S.comp_cod_arr
interchange [of "S.cod \<mu>" \<mu> \<iota> "a \<star> a"] interchange [of \<mu> "S.dom \<mu>" a \<iota>]
by auto
thus ?thesis by argo
qed
also have "... = (\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
using S.comp_assoc by auto
also have "... = R \<mu> \<cdot>\<^sub>S R \<r>[S.dom \<mu>]"
using assms runit_char(2) S.ide_dom H\<^sub>R_def by auto
also have "... = R (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
using assms S.arr_iff_in_hom [of \<mu>] runit_char(1) S.ide_dom by fastforce
finally show ?thesis by blast
qed
ultimately show "\<r>[S.cod \<mu>] \<cdot>\<^sub>S (R \<mu>) = \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>]"
using R.is_faithful by blast
qed
abbreviation \<rr>
where "\<rr> \<mu> \<equiv> if S.arr \<mu> then \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>] else null"
interpretation \<rr>: natural_transformation S.comp S.comp R S.map \<rr>
proof -
interpret \<rr>: transformation_by_components S.comp S.comp R S.map runit
using runit_char(1) runit_naturality by (unfold_locales, simp_all)
have "\<rr>.map = \<rr>"
using \<rr>.is_extensional \<rr>.map_def \<rr>.naturality \<rr>.map_simp_ide S.ide_dom S.ide_cod
S.map_def
by auto
thus "natural_transformation S.comp S.comp R S.map \<rr>"
using \<rr>.natural_transformation_axioms by auto
qed
lemma natural_transformation_\<rr>:
shows "natural_transformation S.comp S.comp R S.map \<rr>" ..
interpretation \<rr>: natural_isomorphism S.comp S.comp R S.map \<rr>
using S.ide_is_iso iso_runit runit_char(1) S.isos_compose
by (unfold_locales, force)
lemma natural_isomorphism_\<rr>:
shows "natural_isomorphism S.comp S.comp R S.map \<rr>" ..
interpretation R: equivalence_functor S.comp S.comp R
using natural_isomorphism_\<rr> R.isomorphic_to_identity_is_equivalence by blast
lemma equivalence_functor_R:
shows "equivalence_functor S.comp S.comp R"
..
lemma runit_commutes_with_R:
assumes "S.ide f"
shows "\<r>[R f] = R \<r>[f]"
proof -
have "S.seq \<r>[f] (R \<r>[f])"
using assms runit_char(1) R.preserves_hom [of "\<r>[f]" "R f" f] by fastforce
moreover have "S.seq \<r>[f] \<r>[R f]"
using assms runit_char(1) [of f] runit_char(1) [of "R f"] by auto
ultimately show ?thesis
using assms runit_char(1) runit_naturality [of "\<r>[f]"] iso_runit S.iso_is_section
S.section_is_mono S.monoE [of "\<r>[f]" "R \<r>[f]" "\<r>[R f]"]
by force
qed
end
text \<open>
Symmetric results hold for the subcategory of all arrows composable on the left with
a specified weak unit \<open>b\<close>. This yields the \emph{left unitors}.
\<close>
locale left_hom_with_unit =
associative_weak_composition V H \<a> +
left_hom V H b
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a comp" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<iota> :: 'a
and b :: 'a +
assumes weak_unit_b: "weak_unit b"
and \<iota>_in_hom: "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow> b\<guillemotright>"
and iso_\<iota>: "iso \<iota>"
begin
abbreviation L
where "L \<equiv> H\<^sub>L b"
interpretation L: endofunctor S.comp L
using weak_unit_b weak_unit_self_composable endofunctor_H\<^sub>L by simp
interpretation L: fully_faithful_functor S.comp S.comp L
using weak_unit_b weak_unit_def by simp
lemma fully_faithful_functor_L:
shows "fully_faithful_functor S.comp S.comp L"
..
definition lunit ("\<l>[_]")
where "lunit f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S (inv \<a>[b, b, f])"
lemma iso_unit:
shows "S.iso \<iota>" and "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow>\<^sub>S b\<guillemotright>"
proof -
show "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow>\<^sub>S b\<guillemotright>"
proof -
have b: "weak_unit b \<and> S.ide b"
using weak_unit_b S.ide_char S.arr_char left_def weak_unit_self_composable
by metis
moreover have "S.arr (b \<star> b)"
using b S.ideD(1) L.preserves_arr H\<^sub>L_def by auto
ultimately show ?thesis
using b S.in_hom_char S.arr_char left_def \<iota>_in_hom
by (metis S.ideD(1) hom_connected(4) in_homE)
qed
thus "S.iso \<iota>"
using iso_\<iota> iso_char by blast
qed
lemma characteristic_iso:
assumes "S.ide f"
shows "\<guillemotleft>inv \<a>[b, b, f] : b \<star> b \<star> f \<Rightarrow>\<^sub>S (b \<star> b) \<star> f\<guillemotright>"
and "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright>"
and "\<guillemotleft>(\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f] : L (L f) \<Rightarrow>\<^sub>S L f\<guillemotright>"
and "S.iso ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
proof -
have f: "S.ide f \<and> ide f"
using assms S.ide_char by simp
have b: "weak_unit b \<and> ide b \<and> S.ide b"
using weak_unit_b S.ide_char weak_unit_def S.arr_char left_def
weak_unit_self_composable
by metis
have bf: "b \<star> f \<noteq> null \<and> b \<star> b \<star> b \<star> f \<noteq> null"
proof -
have "S.arr (b \<star> f) \<and> S.arr (b \<star> b \<star> f) \<and> S.arr (b \<star> b \<star> b \<star> f)"
using assms S.ideD(1) L.preserves_arr H\<^sub>L_def by auto
thus ?thesis
using S.not_arr_null by fastforce
qed
have bb: "b \<star> b \<noteq> null"
proof -
have "S.arr (b \<star> b)"
using b S.ideD(1) L.preserves_arr H\<^sub>L_def by auto
thus ?thesis
using S.not_arr_null by fastforce
qed
have b_ib: "b \<star> \<iota> \<noteq> null"
using weak_unit_b hom_connected(4) weak_unit_self_composable \<iota>_in_hom by blast
have ib_f: "\<iota> \<star> f \<noteq> null"
using assms S.ide_char left_def S.arr_char hom_connected(3) \<iota>_in_hom
by auto
show assoc_in_hom: "\<guillemotleft>inv \<a>[b, b, f] : b \<star> b \<star> f \<Rightarrow>\<^sub>S (b \<star> b) \<star> f\<guillemotright>"
using b f bf bb hom_connected(2) [of b "inv \<a>[b, b, f]"] left_def
by (metis S.arrI S.cod_closed S.in_hom_char assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C(3) assoc'_simps\<^sub>A\<^sub>W\<^sub>C(2-3))
show 1: "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright>"
using b f bf by (simp add: ib_f ide_in_hom iso_unit(2))
moreover have "S.iso (\<iota> \<star> f)"
using b f bf ib_f 1 VoV.arr_char VxV.inv_simp
inv_in_hom hom_connected(1) [of "inv \<iota>" f] VoV.arr_char VoV.iso_char
preserves_iso iso_char iso_\<iota>
by auto
ultimately have unit_part: "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright> \<and> S.iso (\<iota> \<star> f)"
by blast
show "S.iso ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
proof -
have "S.iso (inv \<a>[b, b, f])"
using assms b f bf bb hom_connected(2) [of b "inv \<a>[b, b, f]"] left_def
iso_assoc\<^sub>A\<^sub>W\<^sub>C iso_inv_iso iso_char S.arr_char left_def
by simp
thus ?thesis
using unit_part assoc_in_hom isos_compose by blast
qed
show "\<guillemotleft>(\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f] : L (L f) \<Rightarrow>\<^sub>S L f\<guillemotright>"
unfolding H\<^sub>L_def using unit_part assoc_in_hom by blast
qed
lemma lunit_char:
assumes "S.ide f"
shows "\<guillemotleft>\<l>[f] : L f \<Rightarrow>\<^sub>S f\<guillemotright>" and "L \<l>[f] = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
proof -
let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
show "\<exists>!\<mu>. ?P \<mu>"
proof -
have "\<exists>\<mu>. ?P \<mu>"
proof -
have 1: "S.ide f"
using assms S.ide_char S.arr_char by simp
moreover have "S.ide (L f)"
using 1 L.preserves_ide by simp
ultimately show ?thesis
using assms characteristic_iso(3) L.is_full by blast
qed
moreover have "\<forall>\<mu> \<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
proof
fix \<mu>
show "\<forall>\<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
using L.is_faithful [of \<mu>] by fastforce
qed
ultimately show ?thesis by blast
qed
hence "?P (THE \<mu>. ?P \<mu>)"
using theI' [of ?P] by fastforce
hence 1: "?P \<l>[f]"
unfolding lunit_def by blast
show "\<guillemotleft>\<l>[f] : L f \<Rightarrow>\<^sub>S f\<guillemotright>" using 1 by fast
show "L \<l>[f] = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]" using 1 by fast
qed
lemma iso_lunit:
assumes "S.ide f"
shows "S.iso \<l>[f]"
using assms characteristic_iso(4) lunit_char L.reflects_iso by metis
lemma lunit_eqI:
assumes "\<guillemotleft>f : a \<Rightarrow>\<^sub>S b\<guillemotright>" and "\<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright>"
and "L \<mu> = ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
shows "\<mu> = \<l>[f]"
proof -
have "S.ide f" using assms(2) S.ide_cod by auto
thus ?thesis using assms lunit_char [of f] by auto
qed
lemma lunit_naturality:
assumes "S.arr \<mu>"
shows "\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> = \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>]"
proof -
have 1: "\<guillemotleft>\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> : L (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
using assms lunit_char(1) [of "S.cod \<mu>"] S.ide_cod by blast
have "S.par (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
proof -
have "\<guillemotleft>\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>] : L (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
using assms S.ide_dom lunit_char(1) by blast
thus ?thesis using 1 by (elim S.in_homE, auto)
qed
moreover have "L (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) = L (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
proof -
have 2: "\<guillemotleft>b \<star> b \<star> \<mu> : b \<star> b \<star> S.dom \<mu> \<Rightarrow>\<^sub>S b \<star> b \<star> S.cod \<mu>\<guillemotright>"
using assms weak_unit_b L.preserves_hom H\<^sub>L_def S.arr_iff_in_hom [of \<mu>] S.arr_char
by simp
have 3: "\<guillemotleft>(b \<star> b) \<star> \<mu> : (b \<star> b) \<star> S.dom \<mu> \<Rightarrow>\<^sub>S (b \<star> b) \<star> S.cod \<mu>\<guillemotright>"
using assms weak_unit_b L.preserves_hom H\<^sub>L_def S.arr_iff_in_hom S.arr_char
by (metis match_3 weak_unit_in_vhom weak_unit_self_left S.in_hom_char
S.not_arr_null S.null_char right_hcomp_closed)
have "L (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) = L \<l>[S.cod \<mu>] \<cdot>\<^sub>S L (L \<mu>)"
using assms 1 L.preserves_comp_2 by blast
also have "... = ((\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.cod \<mu>]) \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
using assms L.preserves_arr lunit_char S.ide_cod H\<^sub>L_def by auto
also have "... = (\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
using S.comp_assoc by auto
also have "... = (\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
proof -
have "inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>) = ((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
proof -
have "((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>] = ((b \<star> b) \<star> \<mu>) \<cdot> inv \<a>[b, b, S.dom \<mu>]"
using assms 3 S.in_hom_char S.comp_char [of "(b \<star> b) \<star> \<mu>" "inv \<a>[b, b, S.dom \<mu>]"]
by (metis S.ide_dom characteristic_iso(1) ext)
also have "... = inv \<a>[b, b, S.cod \<mu>] \<cdot> (b \<star> b \<star> \<mu>)"
proof -
have "b \<star> \<mu> \<noteq> null"
using assms S.arr_char left_def by simp
thus ?thesis
using assms weak_unit_b assoc'_naturality\<^sub>A\<^sub>W\<^sub>C [of b b \<mu>] by fastforce
qed
also have "... = inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
using assms 2 S.in_hom_char S.comp_char
by (metis S.comp_simp S.ide_cod S.seqI' characteristic_iso(1))
finally show ?thesis by argo
qed
thus ?thesis by argo
qed
also have "... = ((\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>)) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
using S.comp_assoc by auto
also have "... = ((b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>)) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
proof -
have "(b \<star> b) \<star> \<mu> \<noteq> null"
using 3 S.not_arr_null by (elim S.in_homE, auto)
moreover have "\<iota> \<star> S.dom \<mu> \<noteq> null"
using assms S.not_arr_null
by (metis S.dom_char \<iota>_in_hom calculation hom_connected(1-2) in_homE)
ultimately have "(\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>) = (b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>)"
using assms weak_unit_b iso_unit S.comp_arr_dom S.comp_cod_arr
interchange [of \<iota> "b \<star> b" "S.cod \<mu>" \<mu> ] interchange [of b \<iota> \<mu> "S.dom \<mu>"]
by auto
thus ?thesis by argo
qed
also have "... = (b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
using S.comp_assoc by auto
also have "... = L \<mu> \<cdot>\<^sub>S L \<l>[S.dom \<mu>]"
using assms lunit_char(2) S.ide_dom H\<^sub>L_def by auto
also have "... = L (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
using assms S.arr_iff_in_hom [of \<mu>] lunit_char(1) S.ide_dom S.seqI
by fastforce
finally show ?thesis by blast
qed
ultimately show "\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> = \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>]"
using L.is_faithful by blast
qed
abbreviation \<ll>
where "\<ll> \<mu> \<equiv> if S.arr \<mu> then \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>] else null"
interpretation \<ll>: natural_transformation S.comp S.comp L S.map \<ll>
proof -
interpret \<ll>: transformation_by_components S.comp S.comp L S.map lunit
using lunit_char(1) lunit_naturality by (unfold_locales, simp_all)
have "\<ll>.map = \<ll>"
using \<ll>.is_extensional \<ll>.map_def \<ll>.naturality \<ll>.map_simp_ide S.ide_dom S.ide_cod
S.map_def
by auto
thus "natural_transformation S.comp S.comp L S.map \<ll>"
using \<ll>.natural_transformation_axioms by auto
qed
lemma natural_transformation_\<ll>:
shows "natural_transformation S.comp S.comp L S.map \<ll>" ..
interpretation \<ll>: natural_isomorphism S.comp S.comp L S.map \<ll>
using S.ide_is_iso iso_lunit lunit_char(1) S.isos_compose
by (unfold_locales, force)
lemma natural_isomorphism_\<ll>:
shows "natural_isomorphism S.comp S.comp L S.map \<ll>" ..
interpretation L: equivalence_functor S.comp S.comp L
using natural_isomorphism_\<ll> L.isomorphic_to_identity_is_equivalence by blast
lemma equivalence_functor_L:
shows "equivalence_functor S.comp S.comp L"
..
lemma lunit_commutes_with_L:
assumes "S.ide f"
shows "\<l>[L f] = L \<l>[f]"
proof -
have "S.seq \<l>[f] (L \<l>[f])"
using assms lunit_char(1) L.preserves_hom [of "\<l>[f]" "L f" f] by fastforce
moreover have "S.seq \<l>[f] \<l>[L f]"
using assms lunit_char(1) [of f] lunit_char(1) [of "L f"] by auto
ultimately show ?thesis
using assms lunit_char(1) lunit_naturality [of "\<l>[f]"] iso_lunit S.iso_is_section
S.section_is_mono S.monoE [of "\<l>[f]" "L \<l>[f]" "\<l>[L f]"]
by force
qed
end
subsection "Prebicategories"
text \<open>
A \emph{prebicategory} is an associative weak composition satisfying the additional assumption
that every arrow has a source and a target.
\<close>
locale prebicategory =
associative_weak_composition +
assumes arr_has_source: "arr \<mu> \<Longrightarrow> sources \<mu> \<noteq> {}"
and arr_has_target: "arr \<mu> \<Longrightarrow> targets \<mu> \<noteq> {}"
begin
lemma arr_iff_has_src:
shows "arr \<mu> \<longleftrightarrow> sources \<mu> \<noteq> {}"
using arr_has_source composable_implies_arr by auto
lemma arr_iff_has_trg:
shows "arr \<mu> \<longleftrightarrow> targets \<mu> \<noteq> {}"
using arr_has_target composable_implies_arr by auto
end
text \<open>
The horizontal composition of a prebicategory is regular.
\<close>
sublocale prebicategory \<subseteq> regular_weak_composition V H
proof
show "\<And>a f. a \<in> sources f \<Longrightarrow> ide f \<Longrightarrow> f \<star> a \<cong> f"
proof -
fix a f
assume a: "a \<in> sources f" and f: "ide f"
interpret Right_a: subcategory V \<open>right a\<close>
using a right_hom_is_subcategory weak_unit_self_composable by force
interpret Right_a: right_hom_with_unit V H \<a> \<open>some_unit a\<close> a
using a iso_some_unit by (unfold_locales, auto)
show "f \<star> a \<cong> f"
proof -
have "Right_a.ide f"
using a f Right_a.ide_char Right_a.arr_char right_def by auto
hence "Right_a.iso (Right_a.runit f) \<and> (Right_a.runit f) \<in> Right_a.hom (f \<star> a) f"
using Right_a.iso_runit Right_a.runit_char(1) H\<^sub>R_def by simp
hence "iso (Right_a.runit f) \<and> (Right_a.runit f) \<in> hom (f \<star> a) f"
using Right_a.iso_char Right_a.hom_char by auto
thus ?thesis using f isomorphic_def by auto
qed
qed
show "\<And>b f. b \<in> targets f \<Longrightarrow> ide f \<Longrightarrow> b \<star> f \<cong> f"
proof -
fix b f
assume b: "b \<in> targets f" and f: "ide f"
interpret Left_b: subcategory V \<open>left b\<close>
using b left_hom_is_subcategory weak_unit_self_composable by force
interpret Left_b: left_hom_with_unit V H \<a> \<open>some_unit b\<close> b
using b iso_some_unit by (unfold_locales, auto)
show "b \<star> f \<cong> f"
proof -
have "Left_b.ide f"
using b f Left_b.ide_char Left_b.arr_char left_def by auto
hence "Left_b.iso (Left_b.lunit f) \<and> (Left_b.lunit f) \<in> Left_b.hom (b \<star> f) f"
using b f Left_b.iso_lunit Left_b.lunit_char(1) H\<^sub>L_def by simp
hence "iso (Left_b.lunit f) \<and> (Left_b.lunit f) \<in> hom (b \<star> f) f"
using Left_b.iso_char Left_b.hom_char by auto
thus ?thesis using isomorphic_def by auto
qed
qed
qed
text \<open>
The regularity allows us to show that, in a prebicategory, all sources of
a given arrow are isomorphic, and similarly for targets.
\<close>
context prebicategory
begin
lemma sources_are_isomorphic:
assumes "a \<in> sources \<mu>" and "a' \<in> sources \<mu>"
shows "a \<cong> a'"
proof -
have \<mu>: "arr \<mu>" using assms composable_implies_arr by auto
have 0: "\<And>f. \<lbrakk> ide f; a \<in> sources f; a' \<in> sources f \<rbrakk> \<Longrightarrow> a \<cong> a'"
proof -
fix f
assume f: "ide f" and a: "a \<in> sources f" and a': "a' \<in> sources f"
have 1: "a \<star> a' \<noteq> null"
using a a' f \<mu> assms(1) sources_determine_composability sourcesD(2-3) by meson
have 2: "a \<in> targets a' \<and> a' \<in> sources a"
using assms 1 by blast
show "a \<cong> a'"
using a a' 1 2 comp_ide_source comp_target_ide [of a a']
weak_unit_self_composable(1) [of a] weak_unit_self_composable(1) [of a']
isomorphic_transitive isomorphic_symmetric
by blast
qed
have "ide (dom \<mu>) \<and> a \<in> sources (dom \<mu>) \<and> a' \<in> sources (dom \<mu>)"
using assms \<mu> sources_dom by auto
thus ?thesis using 0 by auto
qed
lemma targets_are_isomorphic:
assumes "b \<in> targets \<mu>" and "b' \<in> targets \<mu>"
shows "b \<cong> b'"
proof -
have \<mu>: "arr \<mu>" using assms composable_implies_arr by auto
have 0: "\<And>f. \<lbrakk> ide f; b \<in> targets f; b' \<in> targets f \<rbrakk> \<Longrightarrow> b \<cong> b'"
proof -
fix f
assume f: "ide f" and b: "b \<in> targets f" and b': "b' \<in> targets f"
have 1: "b \<star> b' \<noteq> null"
using b b' f \<mu> assms(1) targets_determine_composability targetsD(2-3) by meson
have 2: "b \<in> targets b' \<and> b' \<in> sources b"
using assms 1 by blast
show "b \<cong> b'"
using b b' 1 2 comp_ide_source comp_target_ide [of b b']
weak_unit_self_composable(1) [of b] weak_unit_self_composable(1) [of b']
isomorphic_transitive isomorphic_symmetric
by blast
qed
have "ide (dom \<mu>) \<and> b \<in> targets (dom \<mu>) \<and> b' \<in> targets (dom \<mu>)"
using assms \<mu> targets_dom [of \<mu>] by auto
thus ?thesis using 0 by auto
qed
text \<open>
In fact, we now show that the sets of sources and targets of a 2-cell are
isomorphism-closed, and hence are isomorphism classes.
We first show that the notion ``weak unit'' is preserved under isomorphism.
\<close>
interpretation H: partial_magma H
using is_partial_magma by auto
lemma isomorphism_respects_weak_units:
assumes "weak_unit a" and "a \<cong> a'"
shows "weak_unit a'"
proof -
obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<Rightarrow> a'\<guillemotright>"
using assms by auto
interpret Left_a: subcategory V \<open>left a\<close>
using assms left_hom_is_subcategory by fastforce
interpret Left_a: left_hom_with_unit V H \<a> \<open>some_unit a\<close> a
using assms iso_some_unit
apply unfold_locales by auto
interpret Right_a: subcategory V "right a"
using assms right_hom_is_subcategory by fastforce
interpret Right_a: right_hom_with_unit V H \<a> \<open>some_unit a\<close> a
using assms iso_some_unit
apply unfold_locales by auto
have a': "ide a' \<and> a \<star> a' \<noteq> null \<and> a' \<star> a \<noteq> null \<and> a' \<star> a' \<noteq> null \<and>
\<phi> \<star> a' \<noteq> null \<and> Left_a.ide a'"
using assms \<phi> weak_unit_self_composable hom_connected
Left_a.ide_char Left_a.arr_char left_def
apply auto
apply (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
apply (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
apply (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
apply (metis weak_unit_self_composable(3) in_homE)
by (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
have iso: "a' \<star> a' \<cong> a'"
proof -
have 1: "Right a' = Right a"
using assms right_respects_isomorphic by simp
interpret Right_a': subcategory V \<open>right a'\<close>
using assms right_hom_is_subcategory by fastforce
(* TODO: The previous interpretation brings in unwanted notation for in_hom. *)
interpret Ra': endofunctor \<open>Right a'\<close> \<open>H\<^sub>R a'\<close>
using assms a' endofunctor_H\<^sub>R by auto
let ?\<psi> = "Left_a.lunit a' \<cdot> inv (\<phi> \<star> a')"
have "iso ?\<psi> \<and> \<guillemotleft>?\<psi> : a' \<star> a' \<Rightarrow> a'\<guillemotright>"
proof -
have "iso (Left_a.lunit a') \<and> \<guillemotleft>Left_a.lunit a' : a \<star> a' \<Rightarrow> a'\<guillemotright>"
using a' Left_a.lunit_char(1) Left_a.iso_lunit Left_a.iso_char
Left_a.in_hom_char H\<^sub>L_def
by auto
moreover have "iso (\<phi> \<star> a') \<and> \<guillemotleft>\<phi> \<star> a' : a \<star> a' \<Rightarrow> a' \<star> a'\<guillemotright>"
proof -
have 1: "Right_a'.iso \<phi> \<and> \<phi> \<in> Right_a'.hom (Right_a'.dom \<phi>) (Right_a'.cod \<phi>)"
using a' \<phi> Right_a'.iso_char Right_a'.arr_char right_def right_iff_right_inv
Right_a'.arr_iff_in_hom [of \<phi>]
by simp
have "Right_a'.iso (H\<^sub>R a' \<phi>) \<and>
Right_a'.in_hom (H\<^sub>R a' \<phi>) (H\<^sub>R a' (Right_a'.dom \<phi>)) (H\<^sub>R a' (Right_a'.cod \<phi>))"
using \<phi> 1 Ra'.preserves_iso Ra'.preserves_hom Right_a'.iso_char
Ra'.preserves_dom Ra'.preserves_cod Right_a'.arr_iff_in_hom [of "H\<^sub>R a' \<phi>"]
by simp
thus ?thesis
using \<phi> 1 Right_a'.in_hom_char Right_a'.iso_char H\<^sub>R_def by auto
qed
ultimately show ?thesis
using isos_compose iso_inv_iso inv_in_hom by blast
qed
thus ?thesis using isomorphic_def by auto
qed
text \<open>
We show that horizontal composition on the left and right by @{term a'}
is naturally isomorphic to the identity functor. This follows from the fact
that if @{term a} is isomorphic to @{term a'}, then horizontal composition with @{term a}
is naturally isomorphic to horizontal composition with @{term a'}, hence the latter is
naturally isomorphic to the identity if the former is.
This is conceptually simple, but there are tedious composability details to handle.
\<close>
have 1: "Left a' = Left a \<and> Right a' = Right a"
using assms left_respects_isomorphic right_respects_isomorphic by simp
interpret L: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
using assms weak_unit_def by simp
interpret L': endofunctor \<open>Left a\<close> \<open>H\<^sub>L a'\<close>
using a' 1 endofunctor_H\<^sub>L [of a'] by auto
interpret \<Phi>: natural_isomorphism \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close> \<open>H\<^sub>L a'\<close> \<open>H\<^sub>L \<phi>\<close>
proof
fix \<mu>
show "\<not> Left_a.arr \<mu> \<Longrightarrow> H\<^sub>L \<phi> \<mu> = Left_a.null"
using left_def \<phi> H\<^sub>L_def hom_connected(1) Left_a.null_char null_agreement
Left_a.arr_char
by auto
assume "Left_a.arr \<mu>"
hence \<mu>: "Left_a.arr \<mu> \<and> arr \<mu> \<and> a \<star> \<mu> \<noteq> null"
using Left_a.arr_char left_def composable_implies_arr by simp
have 2: "\<phi> \<star> \<mu> \<noteq> null"
using assms \<phi> \<mu> Left_a.arr_char left_def hom_connected by auto
show "Left_a.dom (H\<^sub>L \<phi> \<mu>) = H\<^sub>L a (Left_a.dom \<mu>)"
using assms 2 \<phi> \<mu> Left_a.arr_char left_def hom_connected(2) [of a \<phi>]
weak_unit_self_composable match_4 Left_a.dom_char H\<^sub>L_def by auto
show "Left_a.cod (H\<^sub>L \<phi> \<mu>) = H\<^sub>L a' (Left_a.cod \<mu>)"
using assms 2 \<phi> \<mu> Left_a.arr_char left_def hom_connected(2) [of a \<phi>]
weak_unit_self_composable match_4 Left_a.cod_char H\<^sub>L_def
by auto
show "Left_a.comp (H\<^sub>L a' \<mu>) (H\<^sub>L \<phi> (Left_a.dom \<mu>)) = H\<^sub>L \<phi> \<mu>"
proof -
have "Left_a.comp (H\<^sub>L a' \<mu>) (H\<^sub>L \<phi> (Left_a.dom \<mu>)) =
Left_a.comp (a' \<star> \<mu>) (\<phi> \<star> dom \<mu>)"
using assms 1 2 \<phi> \<mu> Left_a.dom_char left_def H\<^sub>L_def by simp
also have "... = (a' \<star> \<mu>) \<cdot> (\<phi> \<star> dom \<mu>)"
proof -
have "Left_a.seq (a' \<star> \<mu>) (\<phi> \<star> dom \<mu>)"
proof (intro Left_a.seqI)
show 3: "Left_a.arr (\<phi> \<star> dom \<mu>)"
using assms 2 \<phi> \<mu> Left_a.arr_char left_def
by (metis H\<^sub>L_def L'.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1) in_homE right_connected
paste_1)
show 4: "Left_a.arr (a' \<star> \<mu>)"
using \<mu> H\<^sub>L_def L'.preserves_arr by auto
show "Left_a.dom (a' \<star> \<mu>) = Left_a.cod (\<phi> \<star> dom \<mu>)"
using a' \<phi> \<mu> 2 3 4 Left_a.dom_char Left_a.cod_char
by (metis Left_a.seqE Left_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_1)
qed
thus ?thesis using Left_a.comp_char Left_a.arr_char left_def by auto
qed
also have "... = a' \<cdot> \<phi> \<star> \<mu> \<cdot> dom \<mu>"
using a' \<phi> \<mu> interchange hom_connected by auto
also have "... = \<phi> \<star> \<mu>"
using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
finally show ?thesis using H\<^sub>L_def by simp
qed
show "Left_a.comp (H\<^sub>L \<phi> (Left_a.cod \<mu>)) (Left_a.L \<mu>) = H\<^sub>L \<phi> \<mu>"
proof -
have "Left_a.comp (H\<^sub>L \<phi> (Left_a.cod \<mu>)) (Left_a.L \<mu>) = Left_a.comp (\<phi> \<star> cod \<mu>) (a \<star> \<mu>)"
using assms 1 2 \<phi> \<mu> Left_a.cod_char left_def H\<^sub>L_def by simp
also have "... = (\<phi> \<star> cod \<mu>) \<cdot> (a \<star> \<mu>)"
proof -
have "Left_a.seq (\<phi> \<star> cod \<mu>) (a \<star> \<mu>)"
proof (intro Left_a.seqI)
show 3: "Left_a.arr (\<phi> \<star> cod \<mu>)"
using \<phi> \<mu> 2 Left_a.arr_char left_def
by (metis (no_types, lifting) H\<^sub>L_def L.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1)
in_homE right_connected paste_2)
show 4: "Left_a.arr (a \<star> \<mu>)"
using assms \<mu> Left_a.arr_char left_def
using H\<^sub>L_def L.preserves_arr by auto
show "Left_a.dom (\<phi> \<star> cod \<mu>) = Left_a.cod (a \<star> \<mu>)"
using assms \<phi> \<mu> 2 3 4 Left_a.dom_char Left_a.cod_char
by (metis Left_a.seqE Left_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_2)
qed
thus ?thesis using Left_a.comp_char Left_a.arr_char left_def by auto
qed
also have "... = \<phi> \<cdot> a \<star> cod \<mu> \<cdot> \<mu>"
using \<phi> \<mu> interchange hom_connected by auto
also have "... = \<phi> \<star> \<mu>"
using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
finally show ?thesis using H\<^sub>L_def by simp
qed
next
fix \<mu>
assume \<mu>: "Left_a.ide \<mu>"
have 1: "\<phi> \<star> \<mu> \<noteq> null"
using assms \<phi> \<mu> Left_a.ide_char Left_a.arr_char left_def hom_connected by auto
show "Left_a.iso (H\<^sub>L \<phi> \<mu>)"
proof -
have "iso (\<phi> \<star> \<mu>)"
proof -
have "a \<in> sources \<phi> \<inter> targets \<mu>"
using assms \<phi> \<mu> 1 hom_connected weak_unit_self_composable
Left_a.ide_char Left_a.arr_char left_def connected_if_composable
by auto
thus ?thesis
using \<phi> \<mu> Left_a.ide_char ide_is_iso iso_hcomp\<^sub>R\<^sub>W\<^sub>C(1) by blast
qed
moreover have "left a (\<phi> \<star> \<mu>)"
using assms 1 \<phi> weak_unit_self_composable hom_connected(2) [of a \<phi>]
left_def match_4 null_agreement
by auto
ultimately show ?thesis
using Left_a.iso_char Left_a.arr_char left_iff_left_inv Left_a.inv_char H\<^sub>L_def
by simp
qed
qed
interpret L': equivalence_functor \<open>Left a'\<close> \<open>Left a'\<close> \<open>H\<^sub>L a'\<close>
proof -
have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a) Left_a.map"
using assms Left_a.natural_isomorphism_\<ll> naturally_isomorphic_def by blast
moreover have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a) (H\<^sub>L a')"
using naturally_isomorphic_def \<Phi>.natural_isomorphism_axioms by blast
ultimately have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a')
(identity_functor.map (Left a))"
using naturally_isomorphic_symmetric naturally_isomorphic_transitive by fast
hence "naturally_isomorphic (Left a') (Left a') (H\<^sub>L a') (identity_functor.map (Left a'))"
using 1 by auto
thus "equivalence_functor (Left a') (Left a') (H\<^sub>L a')"
using 1 L'.isomorphic_to_identity_is_equivalence naturally_isomorphic_def by fastforce
qed
text \<open>
Now we do the same for \<open>R'\<close>.
\<close>
interpret R: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
using assms weak_unit_def by simp
interpret R': endofunctor \<open>Right a\<close> \<open>H\<^sub>R a'\<close>
using a' 1 endofunctor_H\<^sub>R [of a'] by auto
interpret \<Psi>: natural_isomorphism \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close> \<open>H\<^sub>R a'\<close> \<open>H\<^sub>R \<phi>\<close>
proof
fix \<mu>
show "\<not> Right_a.arr \<mu> \<Longrightarrow> H\<^sub>R \<phi> \<mu> = Right_a.null"
using right_def \<phi> H\<^sub>R_def hom_connected Right_a.null_char Right_a.arr_char
by auto
assume "Right_a.arr \<mu>"
hence \<mu>: "Right_a.arr \<mu> \<and> arr \<mu> \<and> \<mu> \<star> a \<noteq> null"
using Right_a.arr_char right_def composable_implies_arr by simp
have 2: "\<mu> \<star> \<phi> \<noteq> null"
using assms \<phi> \<mu> Right_a.arr_char right_def hom_connected by auto
show "Right_a.dom (H\<^sub>R \<phi> \<mu>) = H\<^sub>R a (Right_a.dom \<mu>)"
using assms 2 \<phi> \<mu> Right_a.arr_char right_def hom_connected(1) [of \<phi> a]
weak_unit_self_composable match_3 Right_a.dom_char H\<^sub>R_def
by auto
show "Right_a.cod (H\<^sub>R \<phi> \<mu>) = H\<^sub>R a' (Right_a.cod \<mu>)"
using assms 2 a' \<phi> \<mu> Right_a.arr_char right_def hom_connected(3) [of \<phi> a]
weak_unit_self_composable match_3 Right_a.cod_char H\<^sub>R_def
by auto
show "Right_a.comp (H\<^sub>R a' \<mu>) (H\<^sub>R \<phi> (Right_a.dom \<mu>)) = H\<^sub>R \<phi> \<mu>"
proof -
have "Right_a.comp (H\<^sub>R a' \<mu>) (H\<^sub>R \<phi> (Right_a.dom \<mu>)) =
Right_a.comp (\<mu> \<star> a') (dom \<mu> \<star> \<phi>)"
using assms 1 2 \<phi> \<mu> Right_a.dom_char right_def H\<^sub>R_def by simp
also have "... = (\<mu> \<star> a') \<cdot> (dom \<mu> \<star> \<phi>)"
proof -
have "Right_a.seq (\<mu> \<star> a') (dom \<mu> \<star> \<phi>)"
proof (intro Right_a.seqI)
show 3: "Right_a.arr (dom \<mu> \<star> \<phi>)"
using assms 2 \<phi> \<mu> Right_a.arr_char right_def
by (metis H\<^sub>R_def R'.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1) in_homE left_connected
paste_2)
show 4: "Right_a.arr (\<mu> \<star> a')"
using \<mu> H\<^sub>R_def R'.preserves_arr by auto
show "Right_a.dom (\<mu> \<star> a') = Right_a.cod (dom \<mu> \<star> \<phi>)"
using a' \<phi> \<mu> 2 3 4 Right_a.dom_char Right_a.cod_char
by (metis Right_a.seqE Right_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_2)
qed
thus ?thesis using Right_a.comp_char Right_a.arr_char right_def by auto
qed
also have "... = \<mu> \<cdot> dom \<mu> \<star> a' \<cdot> \<phi>"
using a' \<phi> \<mu> interchange hom_connected by auto
also have "... = \<mu> \<star> \<phi>"
using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
finally show ?thesis using H\<^sub>R_def by simp
qed
show "Right_a.comp (H\<^sub>R \<phi> (Right_a.cod \<mu>)) (Right_a.R \<mu>) = H\<^sub>R \<phi> \<mu>"
proof -
have "Right_a.comp (H\<^sub>R \<phi> (Right_a.cod \<mu>)) (Right_a.R \<mu>)
= Right_a.comp (cod \<mu> \<star> \<phi>) (\<mu> \<star> a)"
using assms 1 2 \<phi> \<mu> Right_a.cod_char right_def H\<^sub>R_def by simp
also have "... = (cod \<mu> \<star> \<phi>) \<cdot> (\<mu> \<star> a)"
proof -
have "Right_a.seq (cod \<mu> \<star> \<phi>) (\<mu> \<star> a)"
proof (intro Right_a.seqI)
show 3: "Right_a.arr (cod \<mu> \<star> \<phi>)"
using \<phi> \<mu> 2 Right_a.arr_char right_def
by (metis (no_types, lifting) H\<^sub>R_def R.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1)
in_homE left_connected paste_1)
show 4: "Right_a.arr (\<mu> \<star> a)"
using assms \<mu> Right_a.arr_char right_def
using H\<^sub>R_def R.preserves_arr by auto
show "Right_a.dom (cod \<mu> \<star> \<phi>) = Right_a.cod (\<mu> \<star> a)"
using assms \<phi> \<mu> 2 3 4 Right_a.dom_char Right_a.cod_char
by (metis Right_a.seqE Right_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_1)
qed
thus ?thesis using Right_a.comp_char Right_a.arr_char right_def by auto
qed
also have "... = cod \<mu> \<cdot> \<mu> \<star> \<phi> \<cdot> a"
using \<phi> \<mu> interchange hom_connected by auto
also have "... = \<mu> \<star> \<phi>"
using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
finally show ?thesis using H\<^sub>R_def by simp
qed
next
fix \<mu>
assume \<mu>: "Right_a.ide \<mu>"
have 1: "\<mu> \<star> \<phi> \<noteq> null"
using assms \<phi> \<mu> Right_a.ide_char Right_a.arr_char right_def hom_connected by auto
show "Right_a.iso (H\<^sub>R \<phi> \<mu>)"
proof -
have "iso (\<mu> \<star> \<phi>)"
proof -
have "a \<in> targets \<phi> \<inter> sources \<mu>"
using assms \<phi> \<mu> 1 hom_connected weak_unit_self_composable
Right_a.ide_char Right_a.arr_char right_def connected_if_composable
by (metis (full_types) IntI targetsI)
thus ?thesis
using \<phi> \<mu> Right_a.ide_char ide_is_iso iso_hcomp\<^sub>R\<^sub>W\<^sub>C(1) by blast
qed
moreover have "right a (\<mu> \<star> \<phi>)"
using assms 1 \<phi> weak_unit_self_composable hom_connected(1) [of \<phi> a]
right_def match_3 null_agreement
by auto
ultimately show ?thesis
using Right_a.iso_char Right_a.arr_char right_iff_right_inv
Right_a.inv_char H\<^sub>R_def
by simp
qed
qed
interpret R': equivalence_functor \<open>Right a'\<close> \<open>Right a'\<close> \<open>H\<^sub>R a'\<close>
proof -
have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a) Right_a.map"
using assms Right_a.natural_isomorphism_\<rr> naturally_isomorphic_def by blast
moreover have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a) (H\<^sub>R a')"
using naturally_isomorphic_def \<Psi>.natural_isomorphism_axioms by blast
ultimately have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a') Right_a.map"
using naturally_isomorphic_symmetric naturally_isomorphic_transitive by fast
hence "naturally_isomorphic (Right a') (Right a') (H\<^sub>R a')
(identity_functor.map (Right a'))"
using 1 by auto
thus "equivalence_functor (Right a') (Right a') (H\<^sub>R a')"
using 1 R'.isomorphic_to_identity_is_equivalence naturally_isomorphic_def
by fastforce
qed
show "weak_unit a'"
using weak_unit_def iso L'.fully_faithful_functor_axioms R'.fully_faithful_functor_axioms
by blast
qed
lemma sources_iso_closed:
assumes "a \<in> sources \<mu>" and "a \<cong> a'"
shows "a' \<in> sources \<mu>"
using assms isomorphism_respects_weak_units isomorphic_implies_equicomposable
by blast
lemma targets_iso_closed:
assumes "a \<in> targets \<mu>" and "a \<cong> a'"
shows "a' \<in> targets \<mu>"
using assms isomorphism_respects_weak_units isomorphic_implies_equicomposable
by blast
lemma sources_eqI:
assumes "sources \<mu> \<inter> sources \<nu> \<noteq> {}"
shows "sources \<mu> = sources \<nu>"
using assms sources_iso_closed sources_are_isomorphic by blast
lemma targets_eqI:
assumes "targets \<mu> \<inter> targets \<nu> \<noteq> {}"
shows "targets \<mu> = targets \<nu>"
using assms targets_iso_closed targets_are_isomorphic by blast
text \<open>
The sets of sources and targets of a weak unit are isomorphism classes.
\<close>
lemma sources_char:
assumes "weak_unit a"
shows "sources a = {x. x \<cong> a}"
using assms sources_iso_closed weak_unit_iff_self_source sources_are_isomorphic
isomorphic_symmetric
by blast
lemma targets_char:
assumes "weak_unit a"
shows "targets a = {x. x \<cong> a}"
using assms targets_iso_closed weak_unit_iff_self_target targets_are_isomorphic
isomorphic_symmetric
by blast
end
section "Horizontal Homs"
text \<open>
Here we define a locale that axiomatizes a (vertical) category \<open>V\<close> that has been
punctuated into ``horizontal homs'' by the choice of idempotent endofunctors \<open>src\<close> and \<open>trg\<close>
that assign a specific ``source'' and ``target'' 1-cell to each of its arrows.
The functors \<open>src\<close> and \<open>trg\<close> are also subject to further conditions that constrain how
they commute with each other.
\<close>
locale horizontal_homs =
category V +
src: endofunctor V src +
trg: endofunctor V trg
for V :: "'a comp" (infixr "\<cdot>" 55)
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a" +
assumes ide_src [simp]: "arr \<mu> \<Longrightarrow> ide (src \<mu>)"
and ide_trg [simp]: "arr \<mu> \<Longrightarrow> ide (trg \<mu>)"
and src_src [simp]: "arr \<mu> \<Longrightarrow> src (src \<mu>) = src \<mu>"
and trg_trg [simp]: "arr \<mu> \<Longrightarrow> trg (trg \<mu>) = trg \<mu>"
and trg_src [simp]: "arr \<mu> \<Longrightarrow> trg (src \<mu>) = src \<mu>"
and src_trg [simp]: "arr \<mu> \<Longrightarrow> src (trg \<mu>) = trg \<mu>"
begin
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
text \<open>
We define an \emph{object} to be an arrow that is its own source
(or equivalently, its own target).
\<close>
definition obj
where "obj a \<equiv> arr a \<and> src a = a"
lemma obj_def':
shows "obj a \<longleftrightarrow> arr a \<and> trg a = a"
using trg_src src_trg obj_def by metis
lemma objE [elim]:
assumes "obj a" and "\<lbrakk> ide a; src a = a; trg a = a \<rbrakk> \<Longrightarrow> T"
shows T
proof -
have "ide a" using assms obj_def ide_src by metis
moreover have "src a = a" using assms obj_def by simp
moreover have "trg a = a" using assms obj_def' by simp
ultimately show ?thesis using assms by simp
qed
(* TODO: Can't add "arr a" or "ide a" due to looping. *)
lemma obj_simps [simp]:
assumes "obj a"
shows "src a = a" and "trg a = a"
using assms by auto
lemma obj_src [intro, simp]:
assumes "arr \<mu>"
shows "obj (src \<mu>)"
using assms obj_def by auto
lemma obj_trg [intro, simp]:
assumes "arr \<mu>"
shows "obj (trg \<mu>)"
using assms obj_def by auto
definition in_hhom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
where "in_hhom \<mu> a b \<equiv> arr \<mu> \<and> src \<mu> = a \<and> trg \<mu> = b"
abbreviation hhom
where "hhom a b \<equiv> {\<mu>. \<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>}"
abbreviation (input) hseq\<^sub>H\<^sub>H
where "hseq\<^sub>H\<^sub>H \<equiv> \<lambda>\<mu> \<nu>. arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
lemma in_hhomI [intro, simp]:
assumes "arr \<mu>" and "src \<mu> = a" and "trg \<mu> = b"
shows "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>"
using assms in_hhom_def by auto
lemma in_hhomE [elim]:
assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>"
and "\<lbrakk> arr \<mu>; obj a; obj b; src \<mu> = a; trg \<mu> = b \<rbrakk> \<Longrightarrow> T"
shows "T"
using assms in_hhom_def by auto
(*
* TODO: I tried removing the second assertion here, thinking that it should already
* be covered by the category locale, but in fact it breaks some proofs in
* SpanBicategory that ought to be trivial. So it seems that the presence of
* this introduction rule adds something, and I should consider whether this rule
* should be added to the category locale.
*)
lemma ide_in_hom [intro]:
assumes "ide f"
shows "\<guillemotleft>f : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>f : f \<Rightarrow> f\<guillemotright>"
using assms by auto
lemma src_dom [simp]:
assumes "arr \<mu>"
shows "src (dom \<mu>) = src \<mu>"
using assms src.preserves_dom [of \<mu>] by simp
lemma src_cod [simp]:
assumes "arr \<mu>"
shows "src (cod \<mu>) = src \<mu>"
using assms src.preserves_cod [of \<mu>] by simp
lemma trg_dom [simp]:
assumes "arr \<mu>"
shows "trg (dom \<mu>) = trg \<mu>"
using assms trg.preserves_dom [of \<mu>] by simp
lemma trg_cod [simp]:
assumes "arr \<mu>"
shows "trg (cod \<mu>) = trg \<mu>"
using assms trg.preserves_cod [of \<mu>] by simp
(*
* TODO: In theory, the following simps should already be available from the fact
* that src and trg are endofunctors. But they seem not to get used.
*)
lemma dom_src [simp]:
assumes "arr \<mu>"
shows "dom (src \<mu>) = src \<mu>"
using assms by simp
lemma cod_src [simp]:
assumes "arr \<mu>"
shows "cod (src \<mu>) = src \<mu>"
using assms by simp
lemma dom_trg [simp]:
assumes "arr \<mu>"
shows "dom (trg \<mu>) = trg \<mu>"
using assms by simp
lemma cod_trg [simp]:
assumes "arr \<mu>"
shows "cod (trg \<mu>) = trg \<mu>"
using assms by simp
lemma vcomp_in_hhom [intro, simp]:
assumes "seq \<nu> \<mu>" and "src \<nu> = a" and "trg \<nu> = b"
shows "\<guillemotleft>\<nu> \<cdot> \<mu> : a \<rightarrow> b\<guillemotright>"
using assms src_cod [of "\<nu> \<cdot> \<mu>"] trg_cod [of "\<nu> \<cdot> \<mu>"] by auto
lemma src_vcomp [simp]:
assumes "seq \<nu> \<mu>"
shows "src (\<nu> \<cdot> \<mu>) = src \<nu>"
using assms src_cod [of "\<nu> \<cdot> \<mu>"] by auto
lemma trg_vcomp [simp]:
assumes "seq \<nu> \<mu>"
shows "trg (\<nu> \<cdot> \<mu>) = trg \<nu>"
using assms trg_cod [of "\<nu> \<cdot> \<mu>"] by auto
lemma vseq_implies_hpar:
assumes "seq \<nu> \<mu>"
shows "src \<nu> = src \<mu>" and "trg \<nu> = trg \<mu>"
using assms src_dom [of "\<nu> \<cdot> \<mu>"] trg_dom [of "\<nu> \<cdot> \<mu>"] src_cod [of "\<nu> \<cdot> \<mu>"]
trg_cod [of "\<nu> \<cdot> \<mu>"]
by auto
lemma vconn_implies_hpar:
assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>"
shows "src \<mu> = src f" and "trg \<mu> = trg f" and "src g = src f" and "trg g = trg f"
using assms by auto
lemma src_inv [simp]:
assumes "iso \<mu>"
shows "src (inv \<mu>) = src \<mu>"
using assms inv_in_hom iso_is_arr src_dom src_cod iso_inv_iso dom_inv by metis
lemma trg_inv [simp]:
assumes "iso \<mu>"
shows "trg (inv \<mu>) = trg \<mu>"
using assms inv_in_hom iso_is_arr trg_dom trg_cod iso_inv_iso cod_inv by metis
lemma inv_in_hhom [intro, simp]:
assumes "iso \<mu>" and "src \<mu> = a" and "trg \<mu> = b"
shows "\<guillemotleft>inv \<mu> : a \<rightarrow> b\<guillemotright>"
using assms iso_is_arr by simp
lemma hhom_is_subcategory:
shows "subcategory V (\<lambda>\<mu>. \<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>)"
using src_dom trg_dom src_cod trg_cod by (unfold_locales, auto)
lemma isomorphic_objects_are_equal:
assumes "obj a" and "obj b" and "a \<cong> b"
shows "a = b"
using assms isomorphic_def
by (metis arr_inv dom_inv in_homE objE src_dom src_inv)
text \<open>
Having the functors \<open>src\<close> and \<open>trg\<close> allows us to form categories VV and VVV
of formally horizontally composable pairs and triples of arrows.
\<close>
interpretation VxV: product_category V V ..
interpretation VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
by (unfold_locales, auto)
lemma subcategory_VV:
shows "subcategory VxV.comp (\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>))"
..
interpretation VxVxV: product_category V VxV.comp ..
interpretation VVV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using VV.arr_char
by (unfold_locales, auto)
lemma subcategory_VVV:
shows "subcategory VxVxV.comp
(\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>)))"
..
end
subsection "Prebicategories with Homs"
text \<open>
A \emph{weak composition with homs} consists of a weak composition that is
equipped with horizontal homs in such a way that the chosen source and
target of each 2-cell \<open>\<mu>\<close> in fact lie in the set of sources and targets,
respectively, of \<open>\<mu>\<close>, such that horizontal composition respects the
chosen sources and targets, and such that if 2-cells \<open>\<mu>\<close> and \<open>\<nu>\<close> are
horizontally composable, then the chosen target of \<open>\<mu>\<close> coincides with
the chosen source of \<open>\<nu>\<close>.
\<close>
locale weak_composition_with_homs =
weak_composition +
horizontal_homs +
assumes src_in_sources: "arr \<mu> \<Longrightarrow> src \<mu> \<in> sources \<mu>"
and trg_in_targets: "arr \<mu> \<Longrightarrow> trg \<mu> \<in> targets \<mu>"
and src_hcomp: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src (\<nu> \<star> \<mu>) = src \<mu>"
and trg_hcomp: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> trg (\<nu> \<star> \<mu>) = trg \<nu>"
and seq_if_composable: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
locale prebicategory_with_homs =
prebicategory +
weak_composition_with_homs
begin
lemma composable_char\<^sub>P\<^sub>B\<^sub>H:
shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
proof
show "arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu> \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null"
using trg_in_targets src_in_sources composable_if_connected
by (metis sourcesD(3) targets_determine_composability)
show "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
using seq_if_composable composable_implies_arr by auto
qed
lemma hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H:
assumes "\<guillemotleft>\<mu> : a \<rightarrow>\<^sub>W\<^sub>C b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
and "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
proof -
show "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
using assms sources_determine_composability sources_hcomp targets_hcomp by auto
thus "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
using assms by auto
qed
text \<open>
In a prebicategory with homs, if \<open>a\<close> is an object (i.e. \<open>src a = a\<close> and \<open>trg a = a\<close>),
then \<open>a\<close> is a weak unit. The converse need not hold: there can be weak units that the
\<open>src\<close> and \<open>trg\<close> mappings send to other 1-cells in the same isomorphism class.
\<close>
lemma obj_is_weak_unit:
assumes "obj a"
shows "weak_unit a"
proof -
have "a \<in> sources a"
using assms objE src_in_sources ideD(1) by metis
thus ?thesis by auto
qed
end
subsection "Choosing Homs"
text \<open>
Every prebicategory extends to a prebicategory with homs, by choosing an arbitrary
representative of each isomorphism class of weak units to serve as an object.
``The source'' of a 2-cell is defined to be the chosen representative of the set of
all its sources (which is an isomorphism class), and similarly for ``the target''.
\<close>
context prebicategory
begin
definition rep
where "rep f \<equiv> SOME f'. f' \<in> { f'. f \<cong> f' }"
definition some_src
where "some_src \<mu> \<equiv> if arr \<mu> then rep (SOME a. a \<in> sources \<mu>) else null"
definition some_trg
where "some_trg \<mu> \<equiv> if arr \<mu> then rep (SOME b. b \<in> targets \<mu>) else null"
lemma isomorphic_ide_rep:
assumes "ide f"
shows "f \<cong> rep f"
proof -
have "\<exists>f'. f' \<in> { f'. f \<cong> f' }"
using assms isomorphic_reflexive by blast
thus ?thesis using rep_def someI_ex by simp
qed
lemma rep_rep:
assumes "ide f"
shows "rep (rep f) = rep f"
proof -
have "rep f \<in> { f'. f \<cong> f' }"
using assms isomorphic_ide_rep by simp
have "{ f'. f \<cong> f' } = { f'. rep f \<cong> f' }"
proof -
have "\<And>f'. f \<cong> f' \<longleftrightarrow> rep f \<cong> f'"
proof
fix f'
assume f': "f \<cong> f'"
show "rep f \<cong> f'"
proof -
obtain \<phi> where \<phi>: "\<phi> \<in> hom f f' \<and> iso \<phi>"
using f' by auto
obtain \<psi> where \<psi>: "\<psi> \<in> hom f (rep f) \<and> iso \<psi>"
using assms isomorphic_ide_rep by blast
have "inv \<psi> \<in> hom (rep f) f \<and> iso (inv \<psi>)"
using \<psi> iso_inv_iso inv_in_hom by simp
hence "iso (V \<phi> (inv \<psi>)) \<and> V \<phi> (inv \<psi>) \<in> hom (rep f) f'"
using \<phi> isos_compose by auto
thus ?thesis using isomorphic_def by auto
qed
next
fix f'
assume f': "rep f \<cong> f'"
show "f \<cong> f'"
using assms f' isomorphic_ide_rep isos_compose isomorphic_def by blast
qed
thus ?thesis by auto
qed
hence "rep (rep f) = (SOME f'. f' \<in> { f'. f \<cong> f' })"
using assms rep_def by fastforce
also have "... = rep f"
using assms rep_def by simp
finally show ?thesis by simp
qed
lemma some_src_in_sources:
assumes "arr \<mu>"
shows "some_src \<mu> \<in> sources \<mu>"
proof -
have 1: "(SOME a. a \<in> sources \<mu>) \<in> sources \<mu>"
using assms arr_iff_has_src someI_ex [of "\<lambda>a. a \<in> sources \<mu>"] by blast
moreover have "ide (SOME a. a \<in> sources \<mu>)"
using 1 weak_unit_self_composable by auto
ultimately show ?thesis
using assms 1 some_src_def
sources_iso_closed [of "SOME a. a \<in> sources \<mu>" \<mu>]
isomorphic_ide_rep [of "SOME a. a \<in> sources \<mu>"]
by metis
qed
lemma some_trg_in_targets:
assumes "arr \<mu>"
shows "some_trg \<mu> \<in> targets \<mu>"
proof -
have 1: "(SOME a. a \<in> targets \<mu>) \<in> targets \<mu>"
using assms arr_iff_has_trg someI_ex [of "\<lambda>a. a \<in> targets \<mu>"] by blast
moreover have "ide (SOME a. a \<in> targets \<mu>)"
using 1 weak_unit_self_composable by auto
ultimately show ?thesis
using assms 1 some_trg_def
targets_iso_closed [of "SOME a. a \<in> targets \<mu>" \<mu>]
isomorphic_ide_rep [of "SOME a. a \<in> targets \<mu>"]
by presburger
qed
lemma some_src_dom:
assumes "arr \<mu>"
shows "some_src (dom \<mu>) = some_src \<mu>"
using assms some_src_def sources_dom by simp
lemma some_src_cod:
assumes "arr \<mu>"
shows "some_src (cod \<mu>) = some_src \<mu>"
using assms some_src_def sources_cod by simp
lemma some_trg_dom:
assumes "arr \<mu>"
shows "some_trg (dom \<mu>) = some_trg \<mu>"
using assms some_trg_def targets_dom by simp
lemma some_trg_cod:
assumes "arr \<mu>"
shows "some_trg (cod \<mu>) = some_trg \<mu>"
using assms some_trg_def targets_cod by simp
lemma ide_some_src:
assumes "arr \<mu>"
shows "ide (some_src \<mu>)"
using assms some_src_in_sources weak_unit_self_composable by blast
lemma ide_some_trg:
assumes "arr \<mu>"
shows "ide (some_trg \<mu>)"
using assms some_trg_in_targets weak_unit_self_composable by blast
lemma some_src_composable:
assumes "arr \<tau>"
shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> some_src \<tau> \<star> \<mu> \<noteq> null"
using assms some_src_in_sources sources_determine_composability by blast
lemma some_trg_composable:
assumes "arr \<sigma>"
shows "\<mu> \<star> \<sigma> \<noteq> null \<longleftrightarrow> \<mu> \<star> some_trg \<sigma> \<noteq> null"
using assms some_trg_in_targets targets_determine_composability by blast
lemma sources_some_src:
assumes "arr \<mu>"
shows "sources (some_src \<mu>) = sources \<mu>"
using assms sources_determine_composability some_src_in_sources by blast
lemma targets_some_trg:
assumes "arr \<mu>"
shows "targets (some_trg \<mu>) = targets \<mu>"
using assms targets_determine_composability some_trg_in_targets by blast
lemma src_some_src:
assumes "arr \<mu>"
shows "some_src (some_src \<mu>) = some_src \<mu>"
using assms some_src_def ide_some_src sources_some_src by force
lemma trg_some_trg:
assumes "arr \<mu>"
shows "some_trg (some_trg \<mu>) = some_trg \<mu>"
using assms some_trg_def ide_some_trg targets_some_trg by force
lemma sources_char':
assumes "arr \<mu>"
shows "a \<in> sources \<mu> \<longleftrightarrow> some_src \<mu> \<cong> a"
using assms some_src_in_sources sources_iso_closed sources_are_isomorphic by meson
lemma targets_char':
assumes "arr \<mu>"
shows "a \<in> targets \<mu> \<longleftrightarrow> some_trg \<mu> \<cong> a"
using assms some_trg_in_targets targets_iso_closed targets_are_isomorphic by blast
text \<open>
An arbitrary choice of sources and targets in a prebicategory results in a notion of
formal composability that coincides with the actual horizontal composability
of the prebicategory.
\<close>
lemma composable_char\<^sub>P\<^sub>B:
shows "\<tau> \<star> \<sigma> \<noteq> null \<longleftrightarrow> arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
proof
assume \<sigma>\<tau>: "\<tau> \<star> \<sigma> \<noteq> null"
show "arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
using \<sigma>\<tau> composable_implies_arr connected_if_composable some_src_def some_trg_def
by force
next
assume \<sigma>\<tau>: "arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
show "\<tau> \<star> \<sigma> \<noteq> null"
using \<sigma>\<tau> some_src_in_sources some_trg_composable by force
qed
text \<open>
A 1-cell is its own source if and only if it is its own target.
\<close>
lemma self_src_iff_self_trg:
assumes "ide a"
shows "a = some_src a \<longleftrightarrow> a = some_trg a"
proof
assume a: "a = some_src a"
have "weak_unit a \<and> a \<star> a \<noteq> null"
using assms a some_src_in_sources [of a] by force
thus "a = some_trg a" using a composable_char\<^sub>P\<^sub>B by simp
next
assume a: "a = some_trg a"
have "weak_unit a \<and> a \<star> a \<noteq> null"
using assms a some_trg_in_targets [of a] by force
thus "a = some_src a" using a composable_char\<^sub>P\<^sub>B by simp
qed
lemma some_trg_some_src:
assumes "arr \<mu>"
shows "some_trg (some_src \<mu>) = some_src \<mu>"
using assms ide_some_src some_src_def some_trg_def some_src_in_sources sources_char
targets_char sources_some_src
by force
lemma src_some_trg:
assumes "arr \<mu>"
shows "some_src (some_trg \<mu>) = some_trg \<mu>"
using assms ide_some_trg some_src_def some_trg_def some_trg_in_targets sources_char
targets_char targets_some_trg
by force
lemma some_src_eqI:
assumes "a \<in> sources \<mu>" and "some_src a = a"
shows "some_src \<mu> = a"
proof -
have 1: "arr \<mu> \<and> arr a" using assms composable_implies_arr by auto
have "some_src \<mu> = rep (SOME x. x \<in> sources \<mu>)"
using assms 1 some_src_def by simp
also have "... = rep (SOME x. some_src \<mu> \<cong> x)"
using assms 1 sources_char' by simp
also have "... = rep (SOME x. some_src a \<cong> x)"
using assms 1 some_src_in_sources sources_are_isomorphic
isomorphic_symmetric isomorphic_transitive
by metis
also have "... = rep (SOME x. x \<in> sources a)"
using assms 1 sources_char' by auto
also have "... = some_src a"
using assms 1 some_src_def by simp
also have "... = a"
using assms by auto
finally show ?thesis by simp
qed
lemma some_trg_eqI:
assumes "b \<in> targets \<mu>" and "some_trg b = b"
shows "some_trg \<mu> = b"
proof -
have 1: "arr \<mu> \<and> arr b" using assms composable_implies_arr by auto
have "some_trg \<mu> = rep (SOME x. x \<in> targets \<mu>)"
using assms 1 some_trg_def by simp
also have "... = rep (SOME x. some_trg \<mu> \<cong> x)"
using assms 1 targets_char' by simp
also have "... = rep (SOME x. some_trg b \<cong> x)"
using assms 1 some_trg_in_targets targets_are_isomorphic
isomorphic_symmetric isomorphic_transitive
by metis
also have "... = rep (SOME x. x \<in> targets b)"
using assms 1 targets_char' by auto
also have "... = some_trg b"
using assms 1 some_trg_def by simp
also have "... = b"
using assms by auto
finally show ?thesis by simp
qed
lemma some_src_comp:
assumes "\<tau> \<star> \<sigma> \<noteq> null"
shows "some_src (\<tau> \<star> \<sigma>) = some_src \<sigma>"
proof (intro some_src_eqI [of "some_src \<sigma>" "\<tau> \<star> \<sigma>"])
show "some_src (some_src \<sigma>) = some_src \<sigma>"
using assms src_some_src composable_implies_arr by simp
show "some_src \<sigma> \<in> sources (H \<tau> \<sigma>)"
using assms some_src_in_sources composable_char\<^sub>P\<^sub>B match_3 [of \<sigma> "some_src \<sigma>"]
by (simp add: sources_hcomp)
qed
lemma some_trg_comp:
assumes "\<tau> \<star> \<sigma> \<noteq> null"
shows "some_trg (\<tau> \<star> \<sigma>) = some_trg \<tau>"
proof (intro some_trg_eqI [of "some_trg \<tau>" "\<tau> \<star> \<sigma>"])
show "some_trg (some_trg \<tau>) = some_trg \<tau>"
using assms trg_some_trg composable_implies_arr by simp
show "some_trg \<tau> \<in> targets (H \<tau> \<sigma>)"
using assms some_trg_in_targets composable_char\<^sub>P\<^sub>B match_4 [of \<tau> \<sigma> "some_trg \<tau>"]
by (simp add: targets_hcomp)
qed
text \<open>
The mappings that take an arrow to its chosen source or target are endofunctors
of the vertical category, which commute with each other in the manner required
for horizontal homs.
\<close>
interpretation S: endofunctor V some_src
apply unfold_locales
using some_src_def apply simp
using ide_some_src apply simp
using some_src_dom ide_some_src apply simp
using some_src_cod ide_some_src apply simp
proof -
fix \<nu> \<mu>
assume \<mu>\<nu>: "seq \<nu> \<mu>"
show "some_src (\<nu> \<cdot> \<mu>) = some_src \<nu> \<cdot> some_src \<mu>"
using \<mu>\<nu> some_src_dom [of "\<nu> \<cdot> \<mu>"] some_src_dom some_src_cod [of "\<nu> \<cdot> \<mu>"]
some_src_cod ide_some_src
by auto
qed
interpretation T: endofunctor V some_trg
apply unfold_locales
using some_trg_def apply simp
using ide_some_trg apply simp
using some_trg_dom ide_some_trg apply simp
using some_trg_cod ide_some_trg apply simp
proof -
fix \<nu> \<mu>
assume \<mu>\<nu>: "seq \<nu> \<mu>"
show "some_trg (\<nu> \<cdot> \<mu>) = some_trg \<nu> \<cdot> some_trg \<mu>"
using \<mu>\<nu> some_trg_dom [of "\<nu> \<cdot> \<mu>"] some_trg_dom some_trg_cod [of "\<nu> \<cdot> \<mu>"]
some_trg_cod ide_some_trg
by auto
qed
interpretation weak_composition_with_homs V H some_src some_trg
apply unfold_locales
using some_src_in_sources some_trg_in_targets
src_some_src trg_some_trg src_some_trg some_trg_some_src
some_src_comp some_trg_comp composable_char\<^sub>P\<^sub>B ide_some_src ide_some_trg
by simp_all
proposition extends_to_weak_composition_with_homs:
shows "weak_composition_with_homs V H some_src some_trg"
..
proposition extends_to_prebicategory_with_homs:
shows "prebicategory_with_homs V H \<a> some_src some_trg"
..
end
subsection "Choosing Units"
text \<open>
A \emph{prebicategory with units} is a prebicategory equipped with a choice,
for each weak unit \<open>a\<close>, of a ``unit isomorphism'' \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
\<close>
locale prebicategory_with_units =
prebicategory V H \<a> +
weak_composition V H
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a comp" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]") +
assumes unit_in_vhom\<^sub>P\<^sub>B\<^sub>U: "weak_unit a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
and iso_unit\<^sub>P\<^sub>B\<^sub>U: "weak_unit a \<Longrightarrow> iso \<i>[a]"
begin
lemma unit_in_hom\<^sub>P\<^sub>B\<^sub>U:
assumes "weak_unit a"
shows "\<guillemotleft>\<i>[a] : a \<rightarrow>\<^sub>W\<^sub>C a\<guillemotright>" and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
proof -
show 1: "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
using assms unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by auto
show "\<guillemotleft>\<i>[a] : a \<rightarrow>\<^sub>W\<^sub>C a\<guillemotright>"
using assms 1 weak_unit_iff_self_source weak_unit_iff_self_target
sources_cod [of "\<i>[a]"] targets_cod [of "\<i>[a]"]
by (elim in_homE, auto)
qed
lemma unit_simps [simp]:
assumes "weak_unit a"
shows "arr \<i>[a]" and "dom \<i>[a] = a \<star> a" and "cod \<i>[a] = a"
using assms unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by auto
end
text \<open>
Every prebicategory extends to a prebicategory with units, simply by choosing the
unit isomorphisms arbitrarily.
\<close>
context prebicategory
begin
proposition extends_to_prebicategory_with_units:
shows "prebicategory_with_units V H \<a> some_unit"
using iso_some_unit by (unfold_locales, auto)
end
subsection "Horizontal Composition"
text \<open>
The following locale axiomatizes a (vertical) category \<open>V\<close> with horizontal homs,
which in addition has been equipped with a functorial operation \<open>H\<close> of
horizontal composition from \<open>VV\<close> to \<open>V\<close>, assumed to preserve source and target.
\<close>
locale horizontal_composition =
horizontal_homs V src trg +
VxV: product_category V V +
VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> +
H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a" +
assumes src_hcomp': "arr (\<mu> \<star> \<nu>) \<Longrightarrow> src (\<mu> \<star> \<nu>) = src \<nu>"
and trg_hcomp': "arr (\<mu> \<star> \<nu>) \<Longrightarrow> trg (\<mu> \<star> \<nu>) = trg \<mu>"
begin
(* TODO: Why does this get re-introduced? *)
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
text \<open>
\<open>H\<close> is a partial magma, which shares its null with \<open>V\<close>.
\<close>
lemma is_partial_magma:
shows "partial_magma H" and "partial_magma.null H = null"
proof -
have 1: "\<forall>f. null \<star> f = null \<and> f \<star> null = null"
using H.is_extensional VV.arr_char not_arr_null by auto
interpret H: partial_magma H
proof
show "\<exists>!n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"
proof
show "\<forall>f. null \<star> f = null \<and> f \<star> null = null" by fact
show "\<And>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n \<Longrightarrow> n = null"
using 1 VV.arr_char H.is_extensional not_arr_null by metis
qed
qed
show "partial_magma H" ..
show "H.null = null"
using 1 H.null_def the1_equality [of "\<lambda>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"]
by metis
qed
text \<open>
\textbf{Note:} The following is ``almost'' \<open>H.seq\<close>, but for that we would need
\<open>H.arr = V.arr\<close>.
This would be unreasonable to expect, in general, as the definition of \<open>H.arr\<close> is based
on ``strict'' units rather than weak units.
Later we will show that we do have \<open>H.arr = V.arr\<close> if the vertical category is discrete.
\<close>
abbreviation hseq
where "hseq \<nu> \<mu> \<equiv> arr (\<nu> \<star> \<mu>)"
lemma hseq_char:
shows "hseq \<nu> \<mu> \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
proof -
have "hseq \<nu> \<mu> \<longleftrightarrow> VV.arr (\<nu>, \<mu>)"
using H.is_extensional H.preserves_arr by force
also have "... \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
using VV.arr_char by force
finally show ?thesis by blast
qed
lemma hseq_char':
shows "hseq \<nu> \<mu> \<longleftrightarrow> \<nu> \<star> \<mu> \<noteq> null"
using VV.arr_char H.preserves_arr H.is_extensional hseq_char [of \<nu> \<mu>] by auto
(*
* The following is pretty useful as a simp, but it really slows things down,
* so it is not one by default.
*)
lemma hseqI' (* [simp] *):
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "hseq \<nu> \<mu>"
using assms hseq_char by simp
lemma hseqI [intro]:
assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow> c\<guillemotright>"
shows "hseq \<nu> \<mu>"
using assms hseq_char by auto
lemma hseqE [elim]:
assumes "hseq \<nu> \<mu>"
and "arr \<mu> \<Longrightarrow> arr \<nu> \<Longrightarrow> src \<nu> = trg \<mu> \<Longrightarrow> T"
shows "T"
using assms hseq_char by simp
lemma hcomp_simps [simp]:
assumes "hseq \<nu> \<mu>"
shows "src (\<nu> \<star> \<mu>) = src \<mu>" and "trg (\<nu> \<star> \<mu>) = trg \<nu>"
and "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>" and "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
using assms VV.arr_char src_hcomp' apply force
using assms VV.arr_char trg_hcomp' apply force
using assms VV.arr_char H.preserves_dom apply force
using assms VV.arr_char H.preserves_cod by force
lemma ide_hcomp [intro, simp]:
assumes "ide \<nu>" and "ide \<mu>" and "src \<nu> = trg \<mu>"
shows "ide (\<nu> \<star> \<mu>)"
using assms VV.ide_char VV.arr_char H.preserves_ide [of "(\<nu>, \<mu>)"] by auto
lemma hcomp_in_hhom [intro, simp]:
assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow> c\<guillemotright>"
shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
using assms hseq_char by fastforce
lemma hcomp_in_hhomE [elim]:
assumes "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
and "\<lbrakk> arr \<mu>; arr \<nu>; src \<nu> = trg \<mu>; src \<mu> = a; trg \<nu> = c \<rbrakk> \<Longrightarrow> T"
shows T
using assms in_hhom_def by fastforce
lemma hcomp_in_vhom [intro, simp]:
assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>" and "\<guillemotleft>\<nu> : h \<Rightarrow> k\<guillemotright>" and "src h = trg f"
shows "\<guillemotleft>\<nu> \<star> \<mu> : h \<star> f \<Rightarrow> k \<star> g\<guillemotright>"
using assms hseqI' by fastforce
lemma hcomp_in_vhomE [elim]:
assumes "\<guillemotleft>\<nu> \<star> \<mu> : f \<Rightarrow> g\<guillemotright>"
and "\<lbrakk> arr \<mu>; arr \<nu>; src \<nu> = trg \<mu>; src \<mu> = src f; src \<mu> = src g;
trg \<nu> = trg f; trg \<nu> = trg g \<rbrakk> \<Longrightarrow> T"
shows T
using assms in_hom_def
by (metis in_homE hseqE src_cod src_dom src_hcomp' trg_cod trg_dom trg_hcomp')
text \<open>
A horizontal composition yields a weak composition by simply forgetting
the \<open>src\<close> and \<open>trg\<close> functors.
\<close>
lemma match_1:
assumes "\<nu> \<star> \<mu> \<noteq> null" and "(\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
shows "\<mu> \<star> \<tau> \<noteq> null"
using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
lemma match_2:
assumes "\<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null" and "\<mu> \<star> \<tau> \<noteq> null"
shows "\<nu> \<star> \<mu> \<noteq> null"
using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
lemma match_3:
assumes "\<mu> \<star> \<tau> \<noteq> null" and "\<nu> \<star> \<mu> \<noteq> null"
shows "(\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
lemma match_4:
assumes "\<mu> \<star> \<tau> \<noteq> null" and "\<nu> \<star> \<mu> \<noteq> null"
shows "\<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null"
using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
lemma left_connected:
assumes "seq \<nu> \<nu>'"
shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu>' \<star> \<mu> \<noteq> null"
using assms H.is_extensional not_arr_null VV.arr_char hseq_char'
by (metis hseq_char seqE vseq_implies_hpar(1))
lemma right_connected:
assumes "seq \<mu> \<mu>'"
shows "H \<nu> \<mu> \<noteq> null \<longleftrightarrow> H \<nu> \<mu>' \<noteq> null"
using assms H.is_extensional not_arr_null VV.arr_char hseq_char'
by (metis hseq_char seqE vseq_implies_hpar(2))
proposition is_weak_composition:
shows "weak_composition V H"
proof -
have 1: "(\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null)
= (\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>))"
using hseq_char' by auto
interpret VoV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null\<close>
using 1 VV.subcategory_axioms by simp
interpret H: "functor" VoV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
using H.functor_axioms 1 by simp
show ?thesis
using match_1 match_2 match_3 match_4 left_connected right_connected
by (unfold_locales, metis)
qed
interpretation weak_composition V H
using is_weak_composition by auto
text \<open>
It can be shown that \<open>arr ((\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)) \<Longrightarrow> (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)\<close>.
However, we do not have \<open>arr ((\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)) \<Longrightarrow> (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)\<close>,
because it does not follow from \<open>arr ((\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>))\<close> that \<open>dom \<nu> = cod \<mu>\<close>
and \<open>dom \<tau> = cod \<sigma>\<close>, only that \<open>dom \<nu> \<star> dom \<tau> = cod \<mu> \<star> cod \<sigma>\<close>.
So we don't get interchange unconditionally.
\<close>
lemma interchange:
assumes "seq \<nu> \<mu>" and "seq \<tau> \<sigma>"
shows "(\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
using assms interchange by simp
lemma whisker_right:
assumes "ide f" and "seq \<nu> \<mu>"
shows "(\<nu> \<cdot> \<mu>) \<star> f = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
using assms whisker_right by simp
lemma whisker_left:
assumes "ide f" and "seq \<nu> \<mu>"
shows "f \<star> (\<nu> \<cdot> \<mu>) = (f \<star> \<nu>) \<cdot> (f \<star> \<mu>)"
using assms whisker_left by simp
lemma inverse_arrows_hcomp:
assumes "iso \<mu>" and "iso \<nu>" and "src \<nu> = trg \<mu>"
shows "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
proof -
show "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
proof
show "ide ((inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>))"
proof -
have "(inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
using assms interchange iso_is_arr comp_inv_arr'
by (metis arr_dom)
thus ?thesis
using assms iso_is_arr by simp
qed
show "ide ((\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>))"
proof -
have "(\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>) = cod \<nu> \<star> cod \<mu>"
using assms interchange iso_is_arr comp_arr_inv'
by (metis arr_cod)
thus ?thesis
using assms iso_is_arr by simp
qed
qed
qed
lemma iso_hcomp [intro, simp]:
assumes "iso \<mu>" and "iso \<nu>" and "src \<nu> = trg \<mu>"
shows "iso (\<nu> \<star> \<mu>)"
using assms inverse_arrows_hcomp by auto
lemma isomorphic_implies_ide:
assumes "f \<cong> g"
shows "ide f" and "ide g"
using assms isomorphic_def by auto
lemma hcomp_ide_isomorphic:
assumes "ide f" and "g \<cong> h" and "src f = trg g"
shows "f \<star> g \<cong> f \<star> h"
proof -
obtain \<mu> where \<mu>: "iso \<mu> \<and> \<guillemotleft>\<mu> : g \<Rightarrow> h\<guillemotright>"
using assms isomorphic_def by auto
have "iso (f \<star> \<mu>) \<and> \<guillemotleft>f \<star> \<mu> : f \<star> g \<Rightarrow> f \<star> h\<guillemotright>"
using assms \<mu> iso_hcomp by auto
thus ?thesis
using isomorphic_def by auto
qed
lemma hcomp_isomorphic_ide:
assumes "f \<cong> g" and "ide h" and "src f = trg h"
shows "f \<star> h \<cong> g \<star> h"
proof -
obtain \<mu> where \<mu>: "iso \<mu> \<and> \<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>"
using assms isomorphic_def by auto
have "iso (\<mu> \<star> h) \<and> \<guillemotleft>\<mu> \<star> h : f \<star> h \<Rightarrow> g \<star> h\<guillemotright>"
using assms \<mu> iso_hcomp by auto
thus ?thesis
using isomorphic_def by auto
qed
lemma isomorphic_implies_hpar:
assumes "f \<cong> f'"
shows "ide f" and "ide f'" and "src f = src f'" and "trg f = trg f'"
using assms isomorphic_def by auto
lemma inv_hcomp [simp]:
assumes "iso \<nu>" and "iso \<mu>" and "src \<nu> = trg \<mu>"
shows "inv (\<nu> \<star> \<mu>) = inv \<nu> \<star> inv \<mu>"
using assms inverse_arrow_unique [of "\<nu> \<star> \<mu>"] inv_is_inverse inverse_arrows_hcomp
by auto
interpretation VxVxV: product_category V VxV.comp ..
interpretation VVV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using subcategory_VVV by auto
text \<open>
The following define the two ways of using horizontal composition to compose three arrows.
\<close>
definition HoHV
where "HoHV \<mu> \<equiv> if VVV.arr \<mu> then (fst \<mu> \<star> fst (snd \<mu>)) \<star> snd (snd \<mu>) else null"
definition HoVH
where "HoVH \<mu> \<equiv> if VVV.arr \<mu> then fst \<mu> \<star> fst (snd \<mu>) \<star> snd (snd \<mu>) else null"
lemma functor_HoHV:
shows "functor VVV.comp V HoHV"
apply unfold_locales
using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char
HoHV_def hseqI'
apply auto[4]
proof -
fix f g
assume fg: "VVV.seq g f"
show "HoHV (VVV.comp g f) = HoHV g \<cdot> HoHV f"
proof -
have "VxVxV.comp g f =
(fst g \<cdot> fst f, fst (snd g) \<cdot> fst (snd f), snd (snd g) \<cdot> snd (snd f))"
using fg VVV.seq_char VVV.arr_char VV.arr_char VxVxV.comp_char VxV.comp_char
by (metis (no_types, lifting) VxV.seqE VxVxV.seqE)
hence "HoHV (VVV.comp g f) =
(fst g \<cdot> fst f \<star> fst (snd g) \<cdot> fst (snd f)) \<star> snd (snd g) \<cdot> snd (snd f)"
using HoHV_def VVV.comp_simp fg by auto
also have "... = ((fst g \<star> fst (snd g)) \<star> snd (snd g)) \<cdot>
((fst f \<star> fst (snd f)) \<star> snd (snd f))"
using fg VVV.seq_char VVV.arr_char VV.arr_char interchange
by (metis (no_types, lifting) VxV.seqE VxVxV.seqE hseqI' src_vcomp trg_vcomp)
also have "... = HoHV g \<cdot> HoHV f"
using HoHV_def fg by auto
finally show ?thesis by simp
qed
qed
lemma functor_HoVH:
shows "functor VVV.comp V HoVH"
apply unfold_locales
using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char
HoHV_def HoVH_def hseqI'
apply auto[4]
proof -
fix f g
assume fg: "VVV.seq g f"
show "HoVH (VVV.comp g f) = HoVH g \<cdot> HoVH f"
proof -
have "VxVxV.comp g f =
(fst g \<cdot> fst f, fst (snd g) \<cdot> fst (snd f), snd (snd g) \<cdot> snd (snd f))"
using fg VVV.seq_char VVV.arr_char VV.arr_char VxVxV.comp_char VxV.comp_char
by (metis (no_types, lifting) VxV.seqE VxVxV.seqE)
hence "HoVH (VVV.comp g f) =
fst g \<cdot> fst f \<star> fst (snd g) \<cdot> fst (snd f) \<star> snd (snd g) \<cdot> snd (snd f)"
using HoVH_def VVV.comp_simp fg by auto
also have "... = (fst g \<star> fst (snd g) \<star> snd (snd g)) \<cdot>
(fst f \<star> fst (snd f) \<star> snd (snd f))"
using fg VVV.seq_char VVV.arr_char VV.arr_char interchange
by (metis (no_types, lifting) VxV.seqE VxVxV.seqE hseqI' src_vcomp trg_vcomp)
also have "... = HoVH g \<cdot> HoVH f"
using fg VVV.seq_char VVV.arr_char HoVH_def VVV.comp_char VV.arr_char
by (metis (no_types, lifting))
finally show ?thesis by simp
qed
qed
text \<open>
The following define horizontal composition of an arrow on the left by its target
and on the right by its source.
\<close>
abbreviation L
where "L \<equiv> \<lambda>\<mu>. if arr \<mu> then trg \<mu> \<star> \<mu> else null"
abbreviation R
where "R \<equiv> \<lambda>\<mu>. if arr \<mu> then \<mu> \<star> src \<mu> else null"
lemma endofunctor_L:
shows "endofunctor V L"
using hseqI' vseq_implies_hpar(2) whisker_left
by (unfold_locales, auto)
lemma endofunctor_R:
shows "endofunctor V R"
using hseqI' vseq_implies_hpar(1) whisker_right
by (unfold_locales, auto)
end
end
diff --git a/thys/Bicategory/Strictness.thy b/thys/Bicategory/Strictness.thy
--- a/thys/Bicategory/Strictness.thy
+++ b/thys/Bicategory/Strictness.thy
@@ -1,4492 +1,4501 @@
(* Title: Strictness
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Strictness"
theory Strictness
-imports ConcreteCategory Pseudofunctor CanonicalIsos
+imports Category3.ConcreteCategory Pseudofunctor CanonicalIsos
begin
text \<open>
In this section we consider bicategories in which some or all of the canonical isomorphisms
are assumed to be identities. A \emph{normal} bicategory is one in which the unit
isomorphisms are identities, so that unit laws for horizontal composition are satisfied
``on the nose''.
A \emph{strict} bicategory (also known as a \emph{2-category}) is a bicategory in which both
the unit and associativity isomoprhisms are identities, so that horizontal composition is
strictly associative as well as strictly unital.
From any given bicategory \<open>B\<close> we may construct a related strict bicategory \<open>S\<close>,
its \emph{strictification}, together with a pseudofunctor that embeds \<open>B\<close> in \<open>S\<close>.
The Strictness Theorem states that this pseudofunctor is an equivalence pseudofunctor,
so that bicategory \<open>B\<close> is biequivalent to its strictification.
The Strictness Theorem is often used informally to justify suppressing canonical
isomorphisms; which amounts to proving a theorem about 2-categories and asserting that
it holds for all bicategories. Here we are working formally, so we can't just wave
our hands and mutter something about the Strictness Theorem when we want to avoid
dealing with units and associativities. However, in cases where we can establish that the
property we would like to prove is reflected by the embedding of a bicategory in its
strictification, then we can formally apply the Strictness Theorem to generalize to all
bicategories a result proved for 2-categories. We will apply this approach here to
simplify the proof of some facts about internal equivalences in a bicategory.
\<close>
subsection "Normal and Strict Bicategories"
text \<open>
A \emph{normal} bicategory is one in which the unit isomorphisms are identities,
so that unit laws for horizontal composition are satisfied ``on the nose''.
\<close>
locale normal_bicategory =
bicategory +
assumes strict_lunit: "\<And>f. ide f \<Longrightarrow> \<l>[f] = f"
and strict_runit: "\<And>f. ide f \<Longrightarrow> \<r>[f] = f"
begin
lemma strict_unit:
assumes "obj a"
shows "ide \<i>[a]"
using assms strict_runit unitor_coincidence(2) [of a] by auto
lemma strict_lunit':
assumes "ide f"
shows "\<l>\<^sup>-\<^sup>1[f] = f"
using assms strict_lunit by simp
lemma strict_runit':
assumes "ide f"
shows "\<r>\<^sup>-\<^sup>1[f] = f"
using assms strict_runit by simp
lemma hcomp_obj_arr:
assumes "obj b" and "arr f" and "b = trg f"
shows "b \<star> f = f"
using assms strict_lunit
by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom lunit_naturality)
lemma hcomp_arr_obj:
assumes "arr f" and "obj a" and "src f = a"
shows "f \<star> a = f"
using assms strict_runit
by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom runit_naturality)
end
text \<open>
A \emph{strict} bicategory is a normal bicategory in which the associativities are also
identities, so that associativity of horizontal composition holds ``on the nose''.
\<close>
locale strict_bicategory =
normal_bicategory +
assumes strict_assoc: "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow>
ide \<a>[f, g, h]"
begin
lemma strict_assoc':
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "ide \<a>\<^sup>-\<^sup>1[f, g, h]"
using assms strict_assoc by simp
lemma hcomp_assoc:
shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
proof (cases "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>")
show "\<not> (hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>) \<Longrightarrow> ?thesis"
by (metis hseqE hseq_char' match_1 match_2)
show "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau> \<Longrightarrow> ?thesis"
proof -
assume 1: "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>"
have 2: "arr \<mu> \<and> arr \<nu> \<and> arr \<tau> \<and> src \<mu> = trg \<nu> \<and> src \<nu> = trg \<tau>"
using 1 by blast
have "(\<mu> \<star> \<nu>) \<star> \<tau> = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
using 1 assoc_in_hom strict_assoc comp_cod_arr assoc_simps(4) hseq_char
by simp
also have "... = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
using 1 assoc_naturality by auto
also have "... = \<mu> \<star> \<nu> \<star> \<tau>"
using 2 assoc_in_hom [of "dom \<mu>" "dom \<nu>" "dom \<tau>"] strict_assoc comp_arr_dom hseqI'
by auto
finally show ?thesis by simp
qed
qed
text \<open>
In a strict bicategory, every canonical isomorphism is an identity.
\<close>
interpretation bicategorical_language ..
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
lemma ide_eval_Can:
assumes "Can t"
shows "ide \<lbrace>t\<rbrace>"
proof -
have 1: "\<And>u1 u2. \<lbrakk> ide \<lbrace>u1\<rbrace>; ide \<lbrace>u2\<rbrace>; Arr u1; Arr u2; Dom u1 = Cod u2 \<rbrakk>
\<Longrightarrow> ide (\<lbrace>u1\<rbrace> \<cdot> \<lbrace>u2\<rbrace>)"
by (metis (no_types, lifting) E.eval_simps'(4-5) comp_ide_self ide_char)
have "\<And>u. Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
proof -
fix u
show "Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
(* TODO: Rename \<ll>_ide_simp \<rr>_ide_simp to \<ll>_ide_eq \<rr>_ide_eq *)
using 1 \<alpha>_def \<a>'_def strict_lunit strict_runit strict_assoc strict_assoc'
\<ll>_ide_simp \<rr>_ide_simp Can_implies_Arr comp_ide_arr E.eval_simps'(2-3)
apply (induct u) by auto
qed
thus ?thesis
using assms by simp
qed
lemma ide_can:
assumes "Ide f" and "Ide g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
shows "ide (can g f)"
proof -
have "Can (Inv (g\<^bold>\<down>) \<^bold>\<cdot> f\<^bold>\<down>)"
using assms Can_red Can_Inv red_in_Hom Inv_in_Hom by simp
thus ?thesis
using assms can_def ide_eval_Can by presburger
qed
end
subsection "Strictification"
(*
* TODO: Perhaps change the typeface used for a symbol that stands for a bicategory;
* for example, to avoid the clashes here between B used as the name of a bicategory
* and B used to denote a syntactic identity term.
*)
text \<open>
The Strictness Theorem asserts that every bicategory is biequivalent to a
strict bicategory. More specifically, it shows how to construct, given an arbitrary
bicategory, a strict bicategory (its \emph{strictification}) that is biequivalent to it.
Consequently, given a property \<open>P\<close> of bicategories that is ``bicategorical''
(\emph{i.e.}~respects biequivalence), if we want to show that \<open>P\<close> holds for a bicategory \<open>B\<close>
then it suffices to show that \<open>P\<close> holds for the strictification of \<open>B\<close>, and if we want to show
that \<open>P\<close> holds for all bicategories, it is sufficient to show that it holds for all
strict bicategories. This is very useful, because it becomes quite tedious, even
with the aid of a proof assistant, to do ``diagram chases'' with all the units and
associativities fully spelled out.
Given a bicategory \<open>B\<close>, the strictification \<open>S\<close> of \<open>B\<close> may be constructed as the bicategory
whose arrows are triples \<open>(A, B, \<mu>)\<close>, where \<open>X\<close> and \<open>Y\<close> are ``normal identity terms''
(essentially, nonempty horizontally composable lists of 1-cells of \<open>B\<close>) having the same
syntactic source and target, and \<open>\<guillemotleft>\<mu> : \<lbrace>X\<rbrace> \<Rightarrow> \<lbrace>Y\<rbrace>\<guillemotright>\<close> in \<open>B\<close>.
Vertical composition in \<open>S\<close> is given by composition of the underlying arrows in \<open>B\<close>.
Horizontal composition in \<open>S\<close> is given by \<open>(A, B, \<mu>) \<star> (A', B', \<mu>') = (AA', BB', \<nu>)\<close>,
where \<open>AA'\<close> and \<open>BB'\<close> denote concatenations of lists and where \<open>\<nu>\<close> is defined as the
composition \<open>can BB' (B \<^bold>\<star> B') \<cdot> (\<mu> \<star> \<mu>') \<cdot> can (A \<^bold>\<star> A') AA'\<close>, where \<open>can (A \<^bold>\<star> A') AA'\<close> and
\<open>can BB' (B \<^bold>\<star> B')\<close> are canonical isomorphisms in \<open>B\<close>. The canonical isomorphism
\<open>can (A \<^bold>\<star> A') AA'\<close> corresponds to taking a pair of lists \<open>A \<^bold>\<star> A'\<close> and
``shifting the parentheses to the right'' to obtain a single list \<open>AA'\<close>.
The canonical isomorphism can \<open>BB' (B \<^bold>\<star> B')\<close> corresponds to the inverse rearrangement.
The bicategory \<open>B\<close> embeds into its strictification \<open>S\<close> via the functor \<open>UP\<close> that takes
each arrow \<open>\<mu>\<close> of \<open>B\<close> to \<open>(\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>, \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>, \<mu>)\<close>, where \<open>\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>\<close> and \<open>\<^bold>\<langle>cod \<mu>\<^bold>\<rangle>\<close> denote
one-element lists. This mapping extends to a pseudofunctor.
There is also a pseudofunctor \<open>DN\<close>, which maps \<open>(A, B, \<mu>)\<close> in \<open>S\<close> to \<open>\<mu>\<close> in \<open>B\<close>;
this is such that \<open>DN o UP\<close> is the identity on \<open>B\<close> and \<open>UP o DN\<close> is equivalent to the
identity on \<open>S\<close>, so we obtain a biequivalence between \<open>B\<close> and \<open>S\<close>.
It seems difficult to find references that explicitly describe a strictification
construction in elementary terms like this (in retrospect, it ought to have been relatively
easy to rediscover such a construction, but my thinking got off on the wrong track).
One reference that I did find useful was \cite{unapologetic-strictification},
which discusses strictification for monoidal categories.
\<close>
locale strictified_bicategory =
B: bicategory V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
for V\<^sub>B :: "'a comp" (infixr "\<cdot>\<^sub>B" 55)
and H\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>\<^sub>B" 53)
and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
and \<i>\<^sub>B :: "'a \<Rightarrow> 'a" ("\<i>\<^sub>B[_]")
and src\<^sub>B :: "'a \<Rightarrow> 'a"
and trg\<^sub>B :: "'a \<Rightarrow> 'a"
begin
sublocale E: self_evaluation_map V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B ..
notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
notation B.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
notation E.eval ("\<lbrace>_\<rbrace>")
notation E.Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
text \<open>
The following gives the construction of a bicategory whose arrows are triples \<open>(A, B, \<mu>)\<close>,
where \<open>Nml A \<and> Ide A\<close>, \<open>Nml B \<and> Ide B\<close>, \<open>Src A = Src B\<close>, \<open>Trg A = Trg B\<close>, and \<open>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow> \<lbrace>B\<rbrace>\<close>.
We use @{locale concrete_category} to construct the vertical composition, so formally the
arrows of the bicategory will be of the form \<open>MkArr A B \<mu>\<close>.
\<close>
text \<open>
The 1-cells of the bicategory correspond to normal, identity terms \<open>A\<close>
in the bicategorical language associated with \<open>B\<close>.
\<close>
abbreviation IDE
where "IDE \<equiv> {A. E.Nml A \<and> E.Ide A}"
text \<open>
If terms \<open>A\<close> and \<open>B\<close> determine 1-cells of the strictification and have a
common source and target, then the 2-cells between these 1-cells correspond
to arrows \<open>\<mu>\<close> of the underlying bicategory such that \<open>\<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>\<close>.
\<close>
abbreviation HOM
where "HOM A B \<equiv> {\<mu>. E.Src A = E.Src B \<and> E.Trg A = E.Trg B \<and> \<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>}"
text \<open>
The map taking term \<open>A \<in> OBJ\<close> to its evaluation \<open>\<lbrace>A\<rbrace> \<in> HOM A A\<close> defines the
embedding of 1-cells as identity 2-cells.
\<close>
abbreviation EVAL
where "EVAL \<equiv> E.eval"
sublocale concrete_category IDE HOM EVAL \<open>\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>\<close>
using E.ide_eval_Ide B.comp_arr_dom B.comp_cod_arr B.comp_assoc
by (unfold_locales, auto)
lemma is_concrete_category:
shows "concrete_category IDE HOM EVAL (\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>)"
..
- notation comp (infixr "\<cdot>" 55)
- abbreviation vcomp where "vcomp \<equiv> comp"
+ abbreviation vcomp (infixr "\<cdot>" 55)
+ where "vcomp \<equiv> COMP"
lemma arr_char:
shows "arr F \<longleftrightarrow>
E.Nml (Dom F) \<and> E.Ide (Dom F) \<and> E.Nml (Cod F) \<and> E.Ide (Cod F) \<and>
E.Src (Dom F) = E.Src (Cod F) \<and> E.Trg (Dom F) = E.Trg (Cod F) \<and>
\<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright> \<and> F \<noteq> Null"
using arr_char by auto
lemma arrI (* [intro] *):
assumes "E.Nml (Dom F)" and "E.Ide (Dom F)" and "E.Nml (Cod F)" and "E.Ide (Cod F)"
and "E.Src (Dom F) = E.Src (Cod F)" and "E.Trg (Dom F) = E.Trg (Cod F)"
and "\<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>" and "F \<noteq> Null"
shows "arr F"
using assms arr_char by blast
lemma arrE [elim]:
assumes "arr F"
shows "(\<lbrakk> E.Nml (Dom F); E.Ide (Dom F); E.Nml (Cod F); E.Ide (Cod F);
E.Src (Dom F) = E.Src (Cod F); E.Trg (Dom F) = E.Trg (Cod F);
\<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>; F \<noteq> Null \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
using assms arr_char by simp
lemma ide_char:
shows "ide F \<longleftrightarrow> endo F \<and> B.ide (Map F)"
proof
show "ide F \<Longrightarrow> endo F \<and> B.ide (Map F)"
using ide_char by (simp add: E.ide_eval_Ide)
show "endo F \<and> B.ide (Map F) \<Longrightarrow> ide F"
by (metis (no_types, lifting) B.ide_char B.in_homE arr_char ide_char
mem_Collect_eq seq_char)
qed
lemma ideI [intro]:
assumes "arr F" and "Dom F = Cod F" and "B.ide (Map F)"
shows "ide F"
using assms ide_char dom_char cod_char seq_char by presburger
lemma ideE [elim]:
assumes "ide F"
shows "(\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
proof -
assume 1: "\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T"
show T
proof -
have "arr F"
using assms by auto
moreover have "Dom F = Cod F"
using assms ide_char dom_char cod_char
by (metis (no_types, lifting) Dom_cod calculation ideD(3))
moreover have "B.ide (Map F)"
using assms ide_char by blast
moreover have "Map F = \<lbrace>Dom F\<rbrace>"
using assms ide_char dom_char Map_ide(1) by blast
ultimately show T
using 1 by simp
qed
qed
text \<open>
Source and target are defined by the corresponding syntactic operations on terms.
\<close>
definition src
where "src F \<equiv> if arr F then MkIde (E.Src (Dom F)) else null"
definition trg
where "trg F \<equiv> if arr F then MkIde (E.Trg (Dom F)) else null"
lemma src_simps [simp]:
assumes "arr F"
shows "Dom (src F) = E.Src (Dom F)" and "Cod (src F) = E.Src (Dom F)"
and "Map (src F) = \<lbrace>E.Src (Dom F)\<rbrace>"
using assms src_def arr_char by auto
lemma trg_simps [simp]:
assumes "arr F"
shows "Dom (trg F) = E.Trg (Dom F)" and "Cod (trg F) = E.Trg (Dom F)"
and "Map (trg F) = \<lbrace>E.Trg (Dom F)\<rbrace>"
using assms trg_def arr_char by auto
interpretation src: endofunctor vcomp src
using src_def comp_char
apply (unfold_locales)
apply auto[4]
proof -
show "\<And>g f. seq g f \<Longrightarrow> src (g \<cdot> f) = src g \<cdot> src f"
proof -
fix g f
assume gf: "seq g f"
have "src (g \<cdot> f) = MkIde (E.Src (Dom (g \<cdot> f)))"
using gf src_def comp_char by simp
also have "... = MkIde (E.Src (Dom f))"
using gf by (simp add: seq_char)
also have "... = MkIde (E.Src (Dom g)) \<cdot> MkIde (E.Src (Dom f))"
using gf seq_char by auto
also have "... = src g \<cdot> src f"
using gf src_def comp_char by auto
finally show "src (g \<cdot> f) = src g \<cdot> src f" by blast
qed
qed
interpretation trg: endofunctor vcomp trg
using trg_def comp_char
apply (unfold_locales)
apply auto[4]
proof -
show "\<And>g f. seq g f \<Longrightarrow> trg (g \<cdot> f) = trg g \<cdot> trg f"
proof -
fix g f
assume gf: "seq g f"
- have "trg (g \<cdot> f) = MkIde (E.Trg (Dom (comp g f)))"
+ have "trg (g \<cdot> f) = MkIde (E.Trg (Dom (g \<cdot> f)))"
using gf trg_def comp_char by simp
also have "... = MkIde (E.Trg (Dom f))"
using gf by (simp add: seq_char)
also have "... = MkIde (E.Trg (Dom g)) \<cdot> MkIde (E.Trg (Dom f))"
using gf seq_char by auto
also have "... = trg g \<cdot> trg f"
using gf trg_def comp_char by auto
finally show "trg (g \<cdot> f) = trg g \<cdot> trg f" by blast
qed
qed
interpretation horizontal_homs vcomp src trg
using src_def trg_def Cod_in_Obj Map_in_Hom
by (unfold_locales, auto)
notation in_hhom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
definition hcomp (infixr "\<star>" 53)
where "\<mu> \<star> \<nu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>
then MkArr (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)
(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))
else null"
lemma arr_hcomp:
assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
shows "arr (\<mu> \<star> \<nu>)"
proof -
have 1: "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and> E.Nml (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and>
E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and> E.Nml (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
using assms arr_char src_def trg_def E.Ide_HcompNml E.Nml_HcompNml(1) by auto
moreover
have "\<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
\<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
proof -
have "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
using assms arr_char dom_char cod_char src_def trg_def E.eval_simps'(2-3)
by simp
moreover
have "\<guillemotleft>B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
\<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace>\<guillemotright> \<and>
\<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) :
\<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
using assms 1 arr_char B.can_in_hom src_def trg_def E.Ide.simps(3) by auto
ultimately show ?thesis by auto
qed
moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and>
E.Trg (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
using assms arr_char src_def trg_def
by (simp add: E.Src_HcompNml E.Trg_HcompNml)
ultimately show ?thesis
unfolding hcomp_def
using assms by (intro arrI, auto)
qed
lemma src_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
shows "src (\<mu> \<star> \<nu>) = src \<nu>"
using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Src_HcompNml by simp
lemma trg_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
shows "trg (hcomp \<mu> \<nu>) = trg \<mu>"
using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Trg_HcompNml by simp
lemma hseq_char:
shows "arr (\<mu> \<star> \<nu>) \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
using arr_hcomp hcomp_def by simp
lemma Dom_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
shows "Dom (\<mu> \<star> \<nu>) = Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>"
using assms hcomp_def [of \<mu> \<nu>] by simp
lemma Cod_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
shows "Cod (\<mu> \<star> \<nu>) = Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"
using assms hcomp_def [of \<mu> \<nu>] by simp
lemma Map_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
shows "Map (\<mu> \<star> \<nu>) = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
using assms hcomp_def [of \<mu> \<nu>] by simp
interpretation VxV: product_category vcomp vcomp ..
interpretation VV: subcategory VxV.comp
\<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
using subcategory_VV by simp
interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
proof
show "\<And>f. \<not> VV.arr f \<Longrightarrow> fst f \<star> snd f = null"
using hcomp_def by auto
show A: "\<And>f. VV.arr f \<Longrightarrow> arr (fst f \<star> snd f)"
using VV.arrE hseq_char by blast
show "\<And>f. VV.arr f \<Longrightarrow> dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
proof -
fix f
assume f: "VV.arr f"
have "dom (fst f \<star> snd f) = MkIde (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
using f VV.arrE [of f] dom_char arr_hcomp hcomp_def by simp
also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
proof -
have "hcomp (fst (VV.dom f)) (snd (VV.dom f)) =
MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))
(B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
(\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
using f VV.arrE [of f] arr_hcomp hcomp_def by simp
moreover have "B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
(\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
\<lbrace>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<rbrace>"
proof -
have 1: "E.Ide (Dom (fst f) \<^bold>\<star> Dom (snd f))"
using f VV.arr_char arr_char dom_char
apply simp
by (metis (no_types, lifting) src_simps(1) trg_simps(1))
have 2: "E.Ide (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
using f VV.arr_char arr_char dom_char
apply simp
by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
have 3: "\<^bold>\<lfloor>Dom (fst f) \<^bold>\<star> Dom (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<^bold>\<rfloor>"
using f VV.arr_char arr_char dom_char
apply simp
by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
src_simps(1) trg_simps(1))
have "(\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
proof -
have "B.in_hom (B.can (Dom (fst f) \<^bold>\<star> Dom (snd f))
(Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))
\<lbrace>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<rbrace> (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>)"
using 1 2 3 f VV.arr_char arr_char
B.can_in_hom [of "Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)" "Dom (fst f) \<^bold>\<star> Dom (snd f)"]
by simp
thus ?thesis
using B.comp_cod_arr by auto
qed
thus ?thesis
using 1 2 3 f VV.arr_char B.can_Ide_self B.vcomp_can by simp
qed
ultimately show ?thesis by simp
qed
finally show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
by simp
qed
show "\<And>f. VV.arr f \<Longrightarrow> cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
proof -
fix f
assume f: "VV.arr f"
have "cod (fst f \<star> snd f) = MkIde (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
using f VV.arrE [of f] cod_char arr_hcomp hcomp_def by simp
also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
proof -
have "hcomp (fst (VV.cod f)) (snd (VV.cod f)) =
MkArr (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
(B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
(\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)))"
using f VV.arrE [of f] arr_hcomp hcomp_def by simp
moreover have "B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
(\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
\<lbrace>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<rbrace>"
proof -
have 1: "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
using f VV.arr_char arr_char dom_char
apply simp
by (metis (no_types, lifting) src_simps(1) trg_simps(1))
have 2: "E.Ide (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
using f VV.arr_char arr_char dom_char
apply simp
by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
have 3: "\<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<^bold>\<rfloor>"
using f VV.arr_char arr_char dom_char
apply simp
by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
src_simps(1) trg_simps(1))
have "(\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
proof -
have "B.in_hom (B.can (Cod (fst f) \<^bold>\<star> Cod (snd f))
(Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)))
\<lbrace>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<rbrace> (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>)"
using 1 2 3 f VV.arr_char arr_char
B.can_in_hom [of "Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)"
"Cod (fst f) \<^bold>\<star> Cod (snd f)"]
by simp
thus ?thesis
using B.comp_cod_arr by auto
qed
thus ?thesis
using 1 2 3 f VV.arr_char B.can_Ide_self B.vcomp_can by simp
qed
ultimately show ?thesis by simp
qed
finally show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
by simp
qed
show "\<And>g f. VV.seq g f \<Longrightarrow>
fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
proof -
fix f g
assume fg: "VV.seq g f"
have f: "arr (fst f) \<and> arr (snd f) \<and> src (fst f) = trg (snd f)"
using fg VV.seq_char VV.arr_char by simp
have g: "arr (fst g) \<and> arr (snd g) \<and> src (fst g) = trg (snd g)"
using fg VV.seq_char VV.arr_char by simp
have 1: "arr (fst (VV.comp g f)) \<and> arr (snd (VV.comp g f)) \<and>
src (fst (VV.comp g f)) = trg (snd (VV.comp g f))"
using fg VV.arrE by blast
have 0: "VV.comp g f = (fst g \<cdot> fst f, snd g \<cdot> snd f)"
using fg 1 VV.comp_char VxV.comp_char
by (metis (no_types, lifting) VV.seq_char VxV.seqE)
let ?X = "MkArr (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f)))
(Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
(B.can (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
(Cod (fst (VV.comp g f)) \<^bold>\<star> Cod (snd (VV.comp g f))) \<cdot>\<^sub>B
(Map (fst (VV.comp g f)) \<star>\<^sub>B Map (snd (VV.comp g f))) \<cdot>\<^sub>B
B.can (Dom (fst (VV.comp g f)) \<^bold>\<star> Dom (snd (VV.comp g f)))
(Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f))))"
have 2: "fst (VV.comp g f) \<star> snd (VV.comp g f) = ?X"
unfolding hcomp_def using 1 by simp
also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
proof -
let ?GG = "MkArr (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g))
(B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
(Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)))"
let ?FF = "MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
(B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
(Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
have 4: "arr ?FF \<and> arr ?GG \<and> Dom ?GG = Cod ?FF"
proof -
have "arr ?FF \<and> arr ?GG"
using f g fg VV.arr_char VV.seqE hcomp_def A by presburger
thus ?thesis
using 0 1 by (simp add: fg seq_char)
qed
have "(fst g \<star> snd g) \<cdot> (fst f \<star> snd f) = ?GG \<cdot> ?FF"
unfolding hcomp_def
using 1 f g fg VV.arr_char VV.seqE by simp
also have "... = ?X"
proof (intro arr_eqI)
show "seq ?GG ?FF"
using fg 4 seq_char by blast
show "arr ?X"
using fg 1 arr_hcomp hcomp_def by simp
show "Dom (?GG \<cdot> ?FF) = Dom ?X"
using fg 0 1 4 seq_char by simp
show "Cod (?GG \<cdot> ?FF) = Cod ?X"
using fg 0 1 4 seq_char by simp
show "Map (?GG \<cdot> ?FF) = Map ?X"
proof -
have "Map (?GG \<cdot> ?FF) = Map ?GG \<cdot>\<^sub>B Map ?FF"
using 4 by auto
also have
"... = (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
(Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
(B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
(Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
using fg by simp
also have
"... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
proof -
have "(B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
(Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
(B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
(Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))) =
B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
(Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
using B.comp_assoc by simp
also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
proof -
have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
(B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
\<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
proof -
have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
(B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Cod (fst f) \<^bold>\<star> Cod (snd f))"
proof -
have "E.Ide (Dom (fst g) \<^bold>\<star> Dom (snd g))"
using g arr_char
apply simp
by (metis (no_types, lifting) src_simps(1) trg_simps(1))
moreover have "E.Ide (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))"
using g arr_char
apply simp
by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
moreover have "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
using f arr_char
apply simp
by (metis (no_types, lifting) src_simps(1) trg_simps(1))
moreover have
"\<^bold>\<lfloor>Dom (fst g) \<^bold>\<star> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor>"
using g
apply simp
by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
arrE src_simps(1) trg_simps(1))
moreover have
"\<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor>"
using g
apply simp
by (metis (no_types, lifting) "0" "1" E.Nmlize.simps(3)
calculation(4) fst_conv seq_char snd_conv)
moreover have
"Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g) = Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)"
using 0 1 by (simp add: seq_char)
ultimately show ?thesis
using B.vcomp_can by simp
qed
also have "... = \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
proof -
have "Dom (fst g) \<^bold>\<star> Dom (snd g) = Cod (fst f) \<^bold>\<star> Cod (snd f)"
using 0 f g fg seq_char VV.seq_char VV.arr_char
by simp
thus ?thesis
using f B.can_Ide_self [of "Dom (fst f) \<^bold>\<star> Dom (snd f)"]
apply simp
by (metis (no_types, lifting) B.can_Ide_self E.eval.simps(3)
E.Ide.simps(3) arr_char src_simps(2) trg_simps(2))
qed
finally show ?thesis by simp
qed
hence "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
(Map (fst f) \<star>\<^sub>B Map (snd f)) =
\<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace> \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))"
by simp
also have "... = Map (fst f) \<star>\<^sub>B Map (snd f)"
proof -
have 1: "\<forall>p. arr p \<longrightarrow> map (cod p) \<cdot> map p = map p"
by blast
have 3: "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) = Map (map (cod (fst f)) \<cdot> map (fst f))"
by (simp add: f)
have 4: "map (cod (fst f)) \<cdot> map (fst f) = fst f"
using 1 f map_simp by simp
show ?thesis
proof -
have 2: "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) = Map (snd f)"
proof -
have "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
Map (map (cod (snd f)) \<cdot> map (snd f))"
by (simp add: f)
moreover have "map (cod (snd f)) \<cdot> map (snd f) = snd f"
using 1 f map_simp by simp
ultimately show ?thesis by presburger
qed
have "B.seq \<lbrace>Cod (snd f)\<rbrace> (Map (snd f))"
using f 2 by auto
moreover have "B.seq \<lbrace>Cod (fst f)\<rbrace> (Map (fst f))"
using 4 f 3 by auto
moreover have
"\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
Map (fst f) \<star>\<^sub>B Map (snd f)"
using 2 3 4 by presburger
ultimately show ?thesis
by (simp add: B.interchange)
qed
qed
finally have
"(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
(Map (fst f) \<star>\<^sub>B Map (snd f)) =
Map (fst f) \<star>\<^sub>B Map (snd f)"
by simp
thus ?thesis
using fg B.comp_cod_arr by simp
qed
finally show ?thesis by simp
qed
also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
(Map (fst g \<cdot> fst f) \<star>\<^sub>B Map (snd g \<cdot> snd f)) \<cdot>\<^sub>B
B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
proof -
have 2: "Dom (fst g) = Cod (fst f)"
using 0 f g fg VV.seq_char [of g f] VV.arr_char arr_char seq_char
by (metis (no_types, lifting) fst_conv)
hence "Map (fst g \<cdot> fst f) = Map (fst g) \<cdot>\<^sub>B Map (fst f)"
using f g Map_comp [of "fst f" "fst g"] by simp
moreover have "B.seq (Map (fst g)) (Map (fst f)) \<and>
B.seq (Map (snd g)) (Map (snd f))"
using f g 0 1 2 arr_char
by (metis (no_types, lifting) B.seqI' prod.sel(2) seq_char)
ultimately show ?thesis
using 0 1 seq_char Map_comp B.interchange by auto
qed
also have "... = Map ?X"
using fg 0 1 by (simp add: seq_char)
finally show ?thesis by simp
qed
qed
finally show ?thesis by simp
qed
finally show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
by simp
qed
qed
interpretation H: horizontal_composition vcomp hcomp src trg
using hseq_char by (unfold_locales, auto)
lemma hcomp_assoc:
assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>"
and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
proof (intro arr_eqI)
have \<mu>\<nu>: "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
using assms src_def trg_def arr_char
by (auto simp add: E.eval_simps'(2-3) Pair_inject)
have \<nu>\<tau>: "\<guillemotleft>Map \<nu> \<star>\<^sub>B Map \<tau> : \<lbrace>Dom \<nu> \<^bold>\<star> Dom \<tau>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<nu> \<^bold>\<star> Cod \<tau>\<rbrace>\<guillemotright>"
using assms src_def trg_def arr_char
by (auto simp add: E.eval_simps'(2-3) Pair_inject)
show "H.hseq (\<mu> \<star> \<nu>) \<tau>"
using assms \<mu>\<nu> \<nu>\<tau> by auto
show "H.hseq \<mu> (\<nu> \<star> \<tau>)"
using assms \<mu>\<nu> \<nu>\<tau> by auto
show "Dom ((\<mu> \<star> \<nu>) \<star> \<tau>) = Dom (\<mu> \<star> \<nu> \<star> \<tau>)"
unfolding hcomp_def
using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
B.can_in_hom [of "Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>" "Dom \<mu> \<^bold>\<star> Dom \<nu>"]
B.can_in_hom [of "Cod \<mu> \<^bold>\<star> Cod \<nu>" "Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"]
B.can_in_hom [of "Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>" "Dom \<nu> \<^bold>\<star> Dom \<tau>"]
B.can_in_hom [of "Cod \<nu> \<^bold>\<star> Cod \<tau>" "Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>"]
by simp
show "Cod ((\<mu> \<star> \<nu>) \<star> \<tau>) = Cod (\<mu> \<star> \<nu> \<star> \<tau>)"
unfolding hcomp_def
using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
B.can_in_hom [of "Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>" "Dom \<mu> \<^bold>\<star> Dom \<nu>"]
B.can_in_hom [of "Cod \<mu> \<^bold>\<star> Cod \<nu>" "Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"]
B.can_in_hom [of "Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>" "Dom \<nu> \<^bold>\<star> Dom \<tau>"]
B.can_in_hom [of "Cod \<nu> \<^bold>\<star> Cod \<tau>" "Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>"]
by simp
show "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
proof -
have "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
proof -
have 1: "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
unfolding hcomp_def
using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
B.can_in_hom [of "Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>" "Dom \<mu> \<^bold>\<star> Dom \<nu>"]
B.can_in_hom [of "Cod \<mu> \<^bold>\<star> Cod \<nu>" "Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"]
B.can_in_hom [of "Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>" "Dom \<nu> \<^bold>\<star> Dom \<tau>"]
B.can_in_hom [of "Cod \<nu> \<^bold>\<star> Cod \<tau>" "Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>"]
by simp
also have
"... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
proof -
have
"B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau> =
B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
proof -
have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)
\<star>\<^sub>B Map \<tau> =
(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>)"
proof -
have "B.seq (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>))
((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
by (metis (no_types, lifting) B.arrI Map_hcomp arrE arr_hcomp
assms(1) assms(2) assms(4))
moreover have "B.seq (B.can (Cod \<tau>) (Cod \<tau>)) (Map \<tau>)"
using B.can_in_hom assms(3) by blast
moreover have "B.ide (B.can (Cod \<tau>) (Cod \<tau>))"
using B.can_Ide_self E.ide_eval_Ide arr_char assms(3) by presburger
ultimately show ?thesis
by (metis (no_types) B.comp_ide_arr B.interchange)
qed
also have
"... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
((Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
B.can (Dom \<tau>) (Dom \<tau>))"
proof -
have "B.seq (Map \<mu> \<star>\<^sub>B Map \<nu>) (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
by (metis (no_types, lifting) B.arrI B.comp_null(2) B.ext Map_hcomp
arrE arr_hcomp assms(1) assms(2) assms(4))
moreover have "B.seq (Map \<tau>) (B.can (Dom \<tau>) (Dom \<tau>))"
using assms(3) by fastforce
ultimately show ?thesis
using B.interchange
by (metis (no_types, lifting) B.can_Ide_self B.comp_arr_ide E.ide_eval_Ide
arrE assms(3))
qed
also have
"... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
(B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
(B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
B.can (Dom \<tau>) (Dom \<tau>))"
proof -
have "(Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau> =
B.\<a>' \<lbrace>Cod \<mu>\<rbrace> \<lbrace>Cod \<nu>\<rbrace> \<lbrace>Cod \<tau>\<rbrace> \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
\<a>\<^sub>B \<lbrace>Dom \<mu>\<rbrace> \<lbrace>Dom \<nu>\<rbrace> \<lbrace>Dom \<tau>\<rbrace>"
using B.hcomp_reassoc(1)
by (metis (no_types, lifting) B.hcomp_in_vhomE B.in_homE \<mu>\<nu> \<nu>\<tau> arrE
assms(1) assms(2) assms(3))
also have "... = B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
using assms arr_char src_def trg_def arr_char B.canE_associator by simp
finally show ?thesis by simp
qed
also have
"... = ((B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
(B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
B.can (Dom \<tau>) (Dom \<tau>)))"
using B.comp_assoc by simp
also have
"... = B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
proof -
have "(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
(B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) =
B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
proof -
have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu>)"
by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
src_simps(1) trg_simps(1))
moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
using E.Ide_HcompNml assms(1) assms(2) calculation by auto
moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<^bold>\<rfloor>"
using E.Nml_HcompNml(1) assms(1) assms(2) calculation(1) by fastforce
moreover have "E.Src (Cod \<mu> \<^bold>\<star> Cod \<nu>) = E.Trg (Cod \<tau>)"
by (metis (no_types, lifting) E.Src.simps(3) arrE assms(2-3,5)
src_simps(2) trg_simps(2))
moreover have "E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) = E.Trg (Cod \<tau>)"
using E.Src_HcompNml assms(1) assms(2) calculation(1) calculation(4)
by fastforce
moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
by (metis (no_types, lifting) E.Arr.simps(3) E.Nmlize_Hcomp_Hcomp
E.Nmlize_Hcomp_Hcomp' E.Ide_implies_Arr E.Src.simps(3) arrE assms(3)
calculation(1) calculation(4))
ultimately show ?thesis
using assms(3) B.hcomp_can B.vcomp_can by auto
qed
moreover have
"B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B B.can (Dom \<tau>) (Dom \<tau>)) =
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
proof -
have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
by (metis (no_types, lifting) E.Ide_HcompNml arrE assms(1-2,4)
src_simps(2) trg_simps(2))
moreover have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu>)"
by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
src_simps(1) trg_simps(1))
moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu>\<^bold>\<rfloor>"
using E.Nml_HcompNml(1) assms(1-2) calculation(2) by fastforce
moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Dom \<tau>)"
by (metis (no_types, lifting) E.Ide.simps(3) E.Src_HcompNml arrE
assms(1-3,5) calculation(2) src_simps(2) trg_simps(2))
moreover have "E.Src (Dom \<mu> \<^bold>\<star> Dom \<nu>) = E.Trg (Dom \<tau>)"
using E.Src_HcompNml assms(1-2) calculation(2) calculation(4)
by fastforce
moreover have "E.Ide ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
using E.Ide.simps(3) assms(3) calculation(2) calculation(5) by blast
moreover have "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
using E.Nmlize_Hcomp_Hcomp calculation(6) by auto
ultimately show ?thesis
using assms(3) B.hcomp_can B.vcomp_can by auto
qed
ultimately show ?thesis by simp
qed
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have
"... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
using B.comp_assoc by simp
also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
proof -
have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) =
B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
proof -
have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
using assms src_def trg_def by fastforce
moreover have "E.Ide ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>)"
using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
by auto
moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>)"
using assms arr_char src_def trg_def
by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
moreover have "\<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>\<^bold>\<rfloor>"
using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
by simp
ultimately show ?thesis by simp
qed
moreover have
"B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
proof -
have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>)"
using assms src_def trg_def by fastforce
moreover have "E.Ide ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
by auto
moreover have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
using assms arr_char src_def trg_def
by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
moreover have
"\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>\<^bold>\<rfloor>"
using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
by simp
ultimately show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
finally show ?thesis by simp
qed
also have "... = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
proof -
have 1: "Map (\<mu> \<star> \<nu> \<star> \<tau>) =
B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
using assms H.hseqI' Map_hcomp [of \<mu> "\<nu> \<star> \<tau>"] Map_hcomp [of \<nu> \<tau>] by simp
also have
"... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
((B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
proof -
have "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
(B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
using assms B.interchange B.comp_cod_arr
by (metis (no_types, lifting) B.can_Ide_self B.in_homE Map_hcomp arrE hseq_char)
also have "... = (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B
B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
using assms B.interchange B.comp_arr_dom [of "Map \<mu>" "B.can (Dom \<mu>) (Dom \<mu>)"]
by (metis (no_types, lifting) B.can_Ide_self B.comp_null(2) B.ext B.in_homE
Map_hcomp arrE hseq_char)
finally have
"Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
(B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
(B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
by simp
thus ?thesis by simp
qed
also have
"... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
(B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
((B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
using B.comp_assoc by simp
also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
(Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
by simp
finally show ?thesis by simp
qed
ultimately show ?thesis by metis
qed
qed
lemma obj_char:
shows "obj a \<longleftrightarrow> endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
proof
assume a: "obj a"
show "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
proof (intro conjI)
show "endo a"
using a ide_char by blast
show "E.Obj (Dom a)"
using a ide_char src_def
by (metis (no_types, lifting) E.Ide_implies_Arr E.Obj_Trg arrE obj_def
trg_simps(1) trg_src)
show "Map a = \<lbrace>Dom a\<rbrace>"
using a ide_char src_def by blast
qed
next
assume a: "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
show "obj a"
proof -
have "arr a" using a by auto
moreover have "src a = a"
using a E.Obj_in_Hom(1) seq_char by (intro arr_eqI, auto)
ultimately show ?thesis
using obj_def by simp
qed
qed
lemma hcomp_obj_self:
assumes "obj a"
shows "a \<star> a = a"
proof (intro arr_eqI)
show "H.hseq a a"
using assms by auto
show "arr a"
using assms by auto
show 1: "Dom (a \<star> a) = Dom a"
unfolding hcomp_def
using assms arr_char E.HcompNml_Trg_Nml
apply simp
by (metis (no_types, lifting) objE obj_def trg_simps(1))
show 2: "Cod (a \<star> a) = Cod a"
unfolding hcomp_def
using assms 1 arr_char E.HcompNml_Trg_Nml
apply simp
by (metis (no_types, lifting) Dom_hcomp ideE objE)
show "Map (a \<star> a) = Map a"
proof -
have "Map (a \<star> a) = B.can (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a) (Cod a \<^bold>\<star> Cod a) \<cdot>\<^sub>B
(Map a \<star>\<^sub>B Map a) \<cdot>\<^sub>B
B.can (Dom a \<^bold>\<star> Dom a) (Dom a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a)"
using assms Map_hcomp by auto
also have "... = B.can (Dom a) (Dom a \<^bold>\<star> Dom a) \<cdot>\<^sub>B
(\<lbrace>Dom a\<rbrace> \<star>\<^sub>B \<lbrace>Dom a\<rbrace>) \<cdot>\<^sub>B
B.can (Dom a \<^bold>\<star> Dom a) (Dom a)"
proof -
have "Dom a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a = Dom a"
using assms obj_char arr_char E.HcompNml_Trg_Nml
by (metis (no_types, lifting) ideE objE obj_def' trg_simps(2))
moreover have "Cod a = Dom a"
using assms obj_char arr_char dom_char cod_char objE ide_char'
by (metis (no_types, lifting) src_simps(1) src_simps(2))
moreover have "Map a = \<lbrace>Dom a\<rbrace>"
using assms obj_char by simp
ultimately show ?thesis by simp
qed
also have "... = B.can (Dom a) (Dom a \<^bold>\<star> Dom a) \<cdot>\<^sub>B B.can (Dom a \<^bold>\<star> Dom a) (Dom a)"
using assms obj_char arr_char B.comp_cod_arr E.ide_eval_Ide B.can_in_hom
by (metis (no_types, lifting) H.ide_hcomp obj_def obj_def'
calculation B.comp_ide_arr B.ide_hcomp B.hseqE B.ideD(1) ide_char B.seqE)
also have "... = \<lbrace>Dom a\<rbrace>"
using assms 1 2 obj_char arr_char B.vcomp_can calculation H.ide_hcomp ideE objE
by (metis (no_types, lifting))
also have "... = Map a"
using assms obj_char by simp
finally show ?thesis by simp
qed
qed
lemma hcomp_ide_src:
assumes "ide f"
shows "f \<star> src f = f"
proof (intro arr_eqI)
show "H.hseq f (src f)"
using assms by simp
show "arr f"
using assms by simp
show 1: "Dom (f \<star> src f) = Dom f"
unfolding hcomp_def
using assms apply simp
using assms ide_char arr_char E.HcompNml_Nml_Src
by (metis (no_types, lifting) ideD(1))
show "Cod (f \<star> src f) = Cod f"
unfolding hcomp_def
using assms apply simp
using assms ide_char arr_char E.HcompNml_Nml_Src
by (metis (no_types, lifting) ideD(1))
show "Map (f \<star> src f) = Map f"
proof -
have "Map (f \<star> src f) = B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (src f)) (Cod f \<^bold>\<star> Cod (src f)) \<cdot>\<^sub>B
(Map f \<star>\<^sub>B Map (src f)) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom (src f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (src f))"
unfolding hcomp_def
using assms by simp
also have "... = B.can (Dom f) (Dom f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
(\<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f)"
using assms arr_char E.HcompNml_Nml_Src by fastforce
also have "... = B.can (Dom f) (Dom f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f)"
proof -
have "\<guillemotleft>B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f) :
\<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
using assms ide_char arr_char B.can_in_hom
by (metis (no_types, lifting) B.canE_unitor(3) B.runit'_in_vhom E.eval_simps(2)
E.Ide_implies_Arr ideE)
thus ?thesis
using B.comp_cod_arr by auto
qed
also have "... = \<lbrace>Dom f\<rbrace>"
using assms 1 ide_char arr_char
by (metis (no_types, lifting) H.ide_hcomp calculation ideE ide_src obj_def' obj_src)
also have "... = Map f"
using assms by auto
finally show ?thesis by simp
qed
qed
lemma hcomp_trg_ide:
assumes "ide f"
shows "trg f \<star> f = f"
proof (intro arr_eqI)
show "H.hseq (trg f) f"
using assms by auto
show "arr f"
using assms by auto
show 1: "Dom (trg f \<star> f) = Dom f"
unfolding hcomp_def
using assms apply simp
using assms ide_char arr_char E.HcompNml_Trg_Nml
by (metis (no_types, lifting) ideD(1))
show "Cod (trg f \<star> f) = Cod f"
unfolding hcomp_def
using assms apply simp
using assms ide_char arr_char E.HcompNml_Trg_Nml
by (metis (no_types, lifting) ideD(1))
show "Map (trg f \<star> f) = Map f"
proof -
have "Map (trg f \<star> f) = B.can (Cod (trg f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (Cod (trg f) \<^bold>\<star> Cod f) \<cdot>\<^sub>B
(Map (trg f) \<star>\<^sub>B Map f) \<cdot>\<^sub>B
B.can (Dom (trg f) \<^bold>\<star> Dom f) (Dom (trg f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f)"
unfolding hcomp_def
using assms by simp
also have "... = B.can (Dom f) (E.Trg (Dom f) \<^bold>\<star> Dom f) \<cdot>\<^sub>B
(\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>) \<cdot>\<^sub>B
B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (Dom f)"
using assms arr_char E.HcompNml_Trg_Nml by fastforce
also have "... = B.can (Dom f) (E.Trg (Dom f) \<^bold>\<star> Dom f) \<cdot>\<^sub>B
B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (Dom f)"
proof -
have "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (Dom f) :
\<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>\<guillemotright>"
using assms ide_char arr_char B.can_in_hom
by (metis (no_types, lifting) B.canE_unitor(4) B.lunit'_in_vhom E.Nml_implies_Arr
E.eval_simps'(3) ideE)
thus ?thesis
using B.comp_cod_arr by auto
qed
also have "... = \<lbrace>Dom f\<rbrace>"
using assms 1 ide_char arr_char
by (metis (no_types, lifting) H.ide_hcomp Map_ide(1) calculation ideD(1)
src_trg trg.preserves_ide)
also have "... = Map f"
using assms by auto
finally show ?thesis by simp
qed
qed
interpretation L: endofunctor vcomp H.L
using H.endofunctor_L by auto
interpretation R: endofunctor vcomp H.R
using H.endofunctor_R by auto
interpretation L: full_functor vcomp vcomp H.L
proof
fix a a' g
assume a: "ide a" and a': "ide a'"
assume g: "in_hom g (H.L a') (H.L a)"
have a_eq: "a = MkIde (Dom a)"
using a dom_char [of a] by simp
have a'_eq: "a' = MkIde (Dom a')"
using a' dom_char [of a'] by simp
have 1: "Cod g = Dom a"
proof -
have "Dom (H.L a) = Dom a"
proof -
have "Dom (H.L a) = E.Trg (Dom a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a"
using a trg_def hcomp_def
apply simp
by (metis (no_types, lifting) ideE src_trg trg.preserves_reflects_arr)
also have "... = Dom a"
using a arr_char E.Trg_HcompNml
by (metis (no_types, lifting) E.HcompNml_Trg_Nml ideD(1))
finally show ?thesis by simp
qed
thus ?thesis
using g cod_char [of g]
by (metis (no_types, lifting) Dom_cod in_homE)
qed
have 2: "Dom g = Dom a'"
proof -
have "Dom (H.L a') = Dom a'"
proof -
have "Dom (H.L a') = E.Trg (Dom a') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a'"
using a' trg_def hcomp_def
apply simp
by (metis (no_types, lifting) ideE src_trg trg.preserves_reflects_arr)
also have "... = Dom a'"
using a' arr_char E.Trg_HcompNml
by (metis (no_types, lifting) E.HcompNml_Trg_Nml ideD(1))
finally show ?thesis by simp
qed
thus ?thesis
using g dom_char [of g]
by (metis (no_types, lifting) Dom_dom in_homE)
qed
let ?f = "MkArr (Dom a') (Cod a) (Map g)"
have f: "in_hom ?f a' a"
proof (intro in_homI)
show 3: "arr (MkArr (Dom a') (Cod a) (Map g))"
proof (intro arr_MkArr [of "Dom a'" "Cod a" "Map g"])
show "Dom a' \<in> IDE"
using a' ide_char arr_char by blast
show "Cod a \<in> IDE"
using a ide_char arr_char by blast
show "Map g \<in> HOM (Dom a') (Cod a)"
proof
show "E.Src (Dom a') = E.Src (Cod a) \<and> E.Trg (Dom a') = E.Trg (Cod a) \<and>
\<guillemotleft>Map g : \<lbrace>Dom a'\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod a\<rbrace>\<guillemotright>"
using a a' a_eq g 1 2 ide_char arr_char src_def trg_def trg_hcomp
by (metis (no_types, lifting) Cod.simps(1) in_homE)
qed
qed
show "dom (MkArr (Dom a') (Cod a) (Map g)) = a'"
using a a' 3 dom_char by auto
show "cod (MkArr (Dom a') (Cod a) (Map g)) = a"
using a a' 3 cod_char by auto
qed
moreover have "H.L ?f = g"
proof -
have "H.L ?f =
trg (MkArr (Dom a') (Cod a) (Map g)) \<star> MkArr (Dom a') (Cod a) (Map g)"
using f by auto
also have "... = MkIde (E.Trg (Cod a)) \<star> MkArr (Dom a') (Cod a) (Map g)"
using a a' f trg_def [of a] vconn_implies_hpar by auto
also have "... = MkArr (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a)
(B.can (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
(\<lbrace>E.Trg (Cod a)\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a'))"
using hcomp_def
apply simp
by (metis (no_types, lifting) Cod.simps(1) arrE f in_homE src_trg trg.preserves_arr
trg_def)
also have "... = MkArr (Dom a') (Cod a)
(B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
(trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (Dom a'))"
proof -
have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a' = Dom a'"
using a a' arr_char E.HcompNml_Trg_Nml
by (metis (no_types, lifting) f ideE trg_simps(1) vconn_implies_hpar(4))
moreover have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a = Cod a"
using a a' arr_char E.HcompNml_Trg_Nml by blast
moreover have "\<lbrace>E.Trg (Cod a)\<rbrace> = trg\<^sub>B \<lbrace>Cod a\<rbrace>"
using a a' arr_char E.eval_simps'(3) by fastforce
ultimately show ?thesis by simp
qed
also have "... = MkArr (Dom a') (Cod a)
(B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace>)"
proof -
have "E.Trg (Cod a) = E.Trg (Dom a')"
using a a' a_eq g ide_char arr_char src_def trg_def trg_hcomp
\<open>Cod g = Dom a\<close> \<open>Dom g = Dom a'\<close>
by (metis (no_types, lifting) Cod.simps(1) in_homE)
moreover have "B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) = B.lunit \<lbrace>Cod a\<rbrace>"
using a ide_char arr_char B.canE_unitor(2) by blast
moreover have "B.can (E.Trg (Dom a') \<^bold>\<star> Dom a') (Dom a') = B.lunit' \<lbrace>Dom a'\<rbrace>"
using a' ide_char arr_char B.canE_unitor(4) by blast
ultimately show ?thesis by simp
qed
also have "... = MkArr (Dom g) (Cod g) (Map g)"
proof -
have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
using a f g ide_char arr_char src_def B.comp_cod_arr
by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
Cod.simps(1) Map.simps(1) in_homE)
moreover have
"B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> = Map g"
proof -
have "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> =
B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
using g ide_char arr_char B.lunit'_naturality
by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
also have "... = (B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
using B.comp_assoc by simp
also have "... = Map g"
using g arr_char E.ide_eval_Ide B.comp_arr_inv' B.comp_cod_arr by fastforce
finally show ?thesis by simp
qed
ultimately have
"B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace> = Map g"
using a a' 1 2 f g hcomp_def dom_char cod_char
by (metis (no_types, lifting) B.comp_null(2) B.ext B.lunit_simps(2) B.lunit_simps(3)
B.src.preserves_reflects_arr B.trg_vcomp B.vseq_implies_hpar(1) ideE)
thus ?thesis
using a 1 2 by auto
qed
also have "... = g"
using g MkArr_Map by blast
finally show ?thesis by simp
qed
ultimately show "\<exists>f. in_hom f a' a \<and> H.L f = g"
by blast
qed
interpretation R: full_functor vcomp vcomp H.R
proof
fix a a' g
assume a: "ide a" and a': "ide a'"
assume g: "in_hom g (H.R a') (H.R a)"
have a_eq: "a = MkIde (Dom a)"
using a dom_char [of a] by simp
have a'_eq: "a' = MkIde (Dom a')"
using a' dom_char [of a'] by simp
have 1: "Cod g = Dom a"
proof -
have "Dom (H.R a) = Dom a"
proof -
have "Dom (H.R a) = Dom a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom a)"
using a src_def hcomp_def
apply simp
by (metis (no_types, lifting) ideE trg_src src.preserves_reflects_arr)
also have "... = Dom a"
using a arr_char E.Src_HcompNml
by (metis (no_types, lifting) E.HcompNml_Nml_Src ideD(1))
finally show ?thesis by simp
qed
thus ?thesis
using g cod_char [of g]
by (metis (no_types, lifting) Dom_cod in_homE)
qed
have 2: "Dom g = Dom a'"
proof -
have "Dom (H.R a') = Dom a'"
proof -
have "Dom (H.R a') = Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom a')"
using a' src_def hcomp_def
apply simp
by (metis (no_types, lifting) ideE trg_src src.preserves_reflects_arr)
also have "... = Dom a'"
using a' arr_char E.Src_HcompNml
by (metis (no_types, lifting) E.HcompNml_Nml_Src ideD(1))
finally show ?thesis by simp
qed
thus ?thesis
using g dom_char [of g]
by (metis (no_types, lifting) Dom_dom in_homE)
qed
let ?f = "MkArr (Dom a') (Cod a) (Map g)"
have f: "in_hom ?f a' a"
proof (intro in_homI)
show 3: "arr (MkArr (Dom a') (Cod a) (Map g))"
proof (intro arr_MkArr [of "Dom a'" "Cod a" "Map g"])
show "Dom a' \<in> IDE"
using a' ide_char arr_char by blast
show "Cod a \<in> IDE"
using a ide_char arr_char by blast
show "Map g \<in> HOM (Dom a') (Cod a)"
proof
show "E.Src (Dom a') = E.Src (Cod a) \<and> E.Trg (Dom a') = E.Trg (Cod a) \<and>
\<guillemotleft>Map g : \<lbrace>Dom a'\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod a\<rbrace>\<guillemotright>"
using a a' a_eq g 1 2 ide_char arr_char src_def trg_def trg_hcomp
by (metis (no_types, lifting) Cod.simps(1) in_homE)
qed
qed
show "dom (MkArr (Dom a') (Cod a) (Map g)) = a'"
using a a' 3 dom_char by auto
show "cod (MkArr (Dom a') (Cod a) (Map g)) = a"
using a a' 3 cod_char by auto
qed
moreover have "H.R ?f = g"
proof -
have "H.R ?f =
MkArr (Dom a') (Cod a) (Map g) \<star> src (MkArr (Dom a') (Cod a) (Map g))"
using f by auto
also have "... = MkArr (Dom a') (Cod a) (Map g) \<star> MkIde (E.Src (Cod a))"
using a a' f src_def [of a] vconn_implies_hpar by auto
also have "... = MkArr (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a))
(B.can (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B \<lbrace>E.Src (Cod a)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)))"
using hcomp_def
apply simp
by (metis (no_types, lifting) Cod_cod arrE f in_homE trg_src src.preserves_arr src_def)
also have "... = MkArr (Dom a') (Cod a)
(B.can (Cod a) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B
B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a'))"
proof -
have "Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Dom a'"
using a a' arr_char E.HcompNml_Nml_Src
by (metis (no_types, lifting) f ideE src_simps(1) vconn_implies_hpar(3))
moreover have "Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Cod a"
using a a' arr_char E.HcompNml_Nml_Src by blast
moreover have "\<lbrace>E.Src (Cod a)\<rbrace> = src\<^sub>B \<lbrace>Cod a\<rbrace>"
using a a' arr_char E.eval_simps'(2) by fastforce
ultimately show ?thesis by simp
qed
also have "... = MkArr (Dom a') (Cod a)
(B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace>)"
proof -
have "E.Src (Cod a) = E.Src (Dom a')"
using a a' g ide_char arr_char src_def trg_def src_hcomp
by (metis (no_types, lifting) Cod_dom f ideE in_homE src_cod src_simps(1))
moreover have "B.can (Cod a) (Cod a \<^bold>\<star> E.Src (Cod a)) = B.runit \<lbrace>Cod a\<rbrace>"
using a ide_char arr_char B.canE_unitor(1) by blast
moreover have "B.can (Dom a' \<^bold>\<star> E.Src (Dom a')) (Dom a') = B.runit' \<lbrace>Dom a'\<rbrace>"
using a' ide_char arr_char B.canE_unitor(3) by blast
ultimately show ?thesis by simp
qed
also have "... = MkArr (Dom g) (Cod g) (Map g)"
proof -
have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
using a f g ide_char arr_char src_def B.comp_cod_arr
by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
Cod.simps(1) Map.simps(1) in_homE)
moreover have
"B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> = Map g"
proof -
have "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> =
B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit'\<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
using g ide_char arr_char B.runit'_naturality [of "Map g"]
by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
also have "... = (B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
using B.comp_assoc by simp
also have "... = Map g"
using g arr_char E.ide_eval_Ide B.comp_arr_inv' B.comp_cod_arr by fastforce
finally show ?thesis by simp
qed
ultimately have
"B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace> = Map g"
using a a' 1 2 f g hcomp_def dom_char cod_char
by (metis (no_types, lifting) ideE)
thus ?thesis
using a 1 2 by auto
qed
also have "... = g"
using g MkArr_Map by blast
finally show ?thesis by simp
qed
ultimately show "\<exists>f. in_hom f a' a \<and> H.R f = g"
by blast
qed
interpretation L: faithful_functor vcomp vcomp H.L
proof
fix f f'
assume par: "par f f'" and eq: "H.L f = H.L f'"
show "f = f'"
proof (intro arr_eqI)
have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
using par dom_char cod_char by auto
show "arr f"
using par by simp
show "arr f'"
using par by simp
show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
using 1 by auto
show "Map f = Map f'"
proof -
have "B.L (Map f) = trg\<^sub>B (Map f) \<star>\<^sub>B Map f"
using par by auto
also have "... = trg\<^sub>B (Map f') \<star>\<^sub>B Map f'"
proof -
have "\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f = \<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f'"
proof -
have A: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) :
\<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>\<guillemotright>"
using par arr_char B.can_in_hom E.Ide_HcompNml
E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
src_def trg_def
by (metis (no_types, lifting) E.eval_simps(3) E.ide_eval_Ide E.Ide_implies_Arr
B.canE_unitor(4) B.lunit'_in_vhom)
have B: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) :
\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f\<rbrace>\<guillemotright>"
using par arr_char B.can_in_hom E.Ide_HcompNml
E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
src_def trg_def
by (metis (no_types, lifting) E.Nmlize.simps(3) E.eval.simps(3) E.Ide.simps(3)
E.Ide_implies_Arr E.Src_Trg trg.preserves_arr trg_simps(2))
have C: "\<guillemotleft>\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f :
\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace>\<guillemotright>"
using par arr_char
by (metis (no_types, lifting) E.eval_simps'(1) E.eval_simps(3) E.ide_eval_Ide
E.Ide_implies_Arr E.Obj_Trg E.Obj_implies_Ide B.hcomp_in_vhom
B.ide_in_hom(2) B.src_trg)
have 3: "(\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
(\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
proof -
have 2: "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) \<cdot>\<^sub>B
(\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f') \<cdot>\<^sub>B
(\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
using par eq hcomp_def trg_def src_trg trg.preserves_arr Map_hcomp
trg_simps(1) trg_simps(2) trg_simps(3)
by auto
have "B.mono (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))"
using par arr_char B.inverse_arrows_can B.iso_is_section B.section_is_mono
src_def trg_def E.Nmlize_Nml E.HcompNml_Trg_Nml E.Ide_implies_Arr
trg.preserves_arr trg_simps(1)
by auto
moreover have
"B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
((\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
using A B C by auto
moreover have
"B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
((\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f'))"
using par 1 2 arr_char calculation(2) by auto
moreover have "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) =
B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f')"
using par 1 arr_char by simp
ultimately show ?thesis
using 2 B.monoE cod_char by auto
qed
show ?thesis
proof -
have "B.epi (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
using par arr_char B.inverse_arrows_can B.iso_is_retraction
B.retraction_is_epi E.Nmlize_Nml E.HcompNml_Trg_Nml src_def trg_def
E.Ide_implies_Arr
by (metis (no_types, lifting) E.Nmlize.simps(3) E.Ide.simps(3) E.Src_Trg
trg.preserves_arr trg_simps(1))
moreover have "B.seq (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f)
(B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
using A C by auto
moreover have "B.seq (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f')
(B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
using 1 3 calculation(2) by auto
ultimately show ?thesis
using par 1 3 arr_char B.epiE by simp
qed
qed
moreover have "trg\<^sub>B (Map f) = \<lbrace>E.Trg (Dom f)\<rbrace> \<and>
trg\<^sub>B (Map f') = \<lbrace>E.Trg (Dom f')\<rbrace>"
using par arr_char trg_def E.Ide_implies_Arr B.comp_arr_dom
B.vseq_implies_hpar(2) E.eval_simps(3)
by (metis (no_types, lifting) B.vconn_implies_hpar(2))
ultimately show ?thesis by simp
qed
also have "... = B.L (Map f')"
using par B.hseqE B.hseq_char' by auto
finally have "B.L (Map f) = B.L (Map f')"
by simp
thus ?thesis
using 2 3 par arr_char B.L.is_faithful
by (metis (no_types, lifting) B.in_homE)
qed
qed
qed
interpretation R: faithful_functor vcomp vcomp H.R
proof
fix f f'
assume par: "par f f'" and eq: "H.R f = H.R f'"
show "f = f'"
proof (intro arr_eqI)
have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
using par dom_char cod_char by auto
show "arr f"
using par by simp
show "arr f'"
using par by simp
show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
using 1 by auto
show "Map f = Map f'"
proof -
have "B.R (Map f) = Map f \<star>\<^sub>B src\<^sub>B (Map f)"
using par apply simp by (metis B.hseqE B.hseq_char')
also have "... = Map f' \<star>\<^sub>B src\<^sub>B (Map f')"
proof -
have "Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> = Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>"
proof -
have 2: "E.Ide (Cod f \<^bold>\<star> E.Src (Dom f))"
using par arr_char src.preserves_arr by auto
hence 3: "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f))"
using par arr_char E.Nml_Src E.Ide_HcompNml calculation by auto
have 4: "\<^bold>\<lfloor>Cod f \<^bold>\<star> E.Src (Dom f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<^bold>\<rfloor>"
using par arr_char by (simp add: E.Nml_HcompNml(1))
have A: "\<guillemotleft>B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) :
\<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
using par arr_char B.can_in_hom E.Ide_HcompNml
E.Ide_Nmlize_Ide E.Nml_Src E.Nmlize_Nml E.HcompNml_Nml_Src
src_def trg_def
by (metis (no_types, lifting) E.eval_simps(2) E.ide_eval_Ide E.Ide_implies_Arr
B.canE_unitor(3) B.runit'_in_vhom)
have B: "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) :
\<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace>\<guillemotright>"
using 2 3 4 B.can_in_hom [of "Cod f \<^bold>\<star> E.Src (Dom f)" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)"]
by simp
have C: "\<guillemotleft>Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> :
\<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
using par arr_char E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
src_def trg_def E.ide_eval_Ide E.Ide_implies_Arr E.Obj_implies_Ide
apply (intro B.hcomp_in_vhom)
apply (simp add: B.ide_in_hom(2))
apply simp
by (metis (no_types, lifting) A B.ideD(1) B.not_arr_null B.seq_if_composable
B.src.preserves_reflects_arr B.vconn_implies_hpar(3) E.HcompNml_Nml_Src)
have 5: "(Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
(Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
proof -
have 6: "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
(Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f')) \<cdot>\<^sub>B
(Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
using par eq hcomp_def src_def trg_src src.preserves_arr Map_hcomp
src_simps(1) src_simps(2) src_simps(3)
by auto
have "B.mono (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))"
using 2 3 4 B.inverse_arrows_can(1) B.iso_is_section B.section_is_mono
by simp
moreover have
"B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
((Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
using A B C by auto
moreover have
"B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
((Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')))"
using par 1 6 arr_char calculation(2) by auto
moreover have "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) =
B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f'))"
using par 1 arr_char by simp
ultimately show ?thesis
using 6 B.monoE cod_char by auto
qed
show ?thesis
proof -
have "B.epi (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
using 2 3 4 B.inverse_arrows_can(1) B.iso_is_retraction B.retraction_is_epi
by (metis (no_types, lifting) E.Nml_Src E.Nmlize.simps(3) E.Nmlize_Nml
E.HcompNml_Nml_Src E.Ide.simps(3) par arrE)
moreover have "B.seq (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>)
(B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
using A C by auto
moreover have "B.seq (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>)
(B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
using 1 5 calculation(2) by auto
ultimately show ?thesis
using par 1 5 arr_char B.epiE by simp
qed
qed
moreover have "src\<^sub>B (Map f) = \<lbrace>E.Src (Dom f)\<rbrace> \<and>
src\<^sub>B (Map f') = \<lbrace>E.Src (Dom f')\<rbrace>"
using par arr_char src_def
by (metis (no_types, lifting) B.vconn_implies_hpar(1) E.Nml_implies_Arr
E.eval_simps(2))
ultimately show ?thesis by simp
qed
also have "... = B.R (Map f')"
using par B.hseqE B.hseq_char' by auto
finally have "B.R (Map f) = B.R (Map f')"
by simp
thus ?thesis
using 2 3 par arr_char B.R.is_faithful
by (metis (no_types, lifting) B.in_homE)
qed
qed
qed
interpretation VxVxV: product_category vcomp VxV.comp ..
interpretation VVV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and> src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using subcategory_VVV by auto
interpretation HoHV: "functor" VVV.comp vcomp H.HoHV
using H.functor_HoHV by auto
interpretation HoVH: "functor" VVV.comp vcomp H.HoVH
using H.functor_HoVH by auto
definition \<a>
where "\<a> \<tau> \<mu> \<nu> \<equiv> if VVV.arr (\<tau>, \<mu>, \<nu>) then hcomp \<tau> (hcomp \<mu> \<nu>) else null"
interpretation natural_isomorphism VVV.comp vcomp H.HoHV H.HoVH
\<open>\<lambda>\<tau>\<mu>\<nu>. \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))\<close>
proof
show "\<And>\<tau>\<mu>\<nu>. \<not> VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow> \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>)) = null"
using \<a>_def by simp
show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
dom (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = H.HoHV (VVV.dom \<tau>\<mu>\<nu>)"
using VVV.arr_char VV.arr_char \<a>_def H.hseqI' hcomp_assoc H.HoHV_def by force
show 1: "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
cod (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = H.HoVH (VVV.cod \<tau>\<mu>\<nu>)"
using VVV.arr_char VV.arr_char \<a>_def H.hseqI' H.HoVH_def by force
show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
H.HoVH \<tau>\<mu>\<nu> \<cdot>
\<a> (fst (VVV.dom \<tau>\<mu>\<nu>)) (fst (snd (VVV.dom \<tau>\<mu>\<nu>)))
(snd (snd (VVV.dom \<tau>\<mu>\<nu>))) =
\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
using \<a>_def HoVH.is_natural_1 H.HoVH_def by auto
show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
\<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>)))
(snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot> H.HoHV \<tau>\<mu>\<nu> =
\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
proof -
fix \<tau>\<mu>\<nu>
assume \<tau>\<mu>\<nu>: "VVV.arr \<tau>\<mu>\<nu>"
have "H.HoHV \<tau>\<mu>\<nu> = \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
unfolding \<a>_def H.HoHV_def
using \<tau>\<mu>\<nu> HoHV.preserves_cod hcomp_assoc VVV.arr_char VV.arr_char
by simp
thus "\<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>))) (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot>
H.HoHV \<tau>\<mu>\<nu> =
\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
using 1 \<tau>\<mu>\<nu> comp_cod_arr \<a>_def
by (metis (no_types, lifting) H.HoVH_def HoHV.preserves_arr prod.collapse)
qed
show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<a> (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
using \<a>_def HoVH.preserves_ide H.HoVH_def by auto
qed
definition \<i>
where "\<i> \<equiv> \<lambda>a. a"
- sublocale bicategory comp hcomp \<a> \<i> src trg
+ sublocale bicategory vcomp hcomp \<a> \<i> src trg
using hcomp_obj_self \<a>_def hcomp_assoc VVV.arr_char VV.arr_char
apply unfold_locales
by (auto simp add: \<i>_def ide_in_hom(2))
lemma is_bicategory:
- shows "bicategory comp hcomp \<a> \<i> src trg"
+ shows "bicategory vcomp hcomp \<a> \<i> src trg"
..
sublocale strict_bicategory vcomp hcomp \<a> \<i> src trg
proof
show "\<And>fgh. ide fgh \<Longrightarrow> lunit fgh = fgh"
proof -
fix fgh
assume fgh: "ide fgh"
have "fgh = lunit fgh"
proof (intro lunit_eqI)
show "ide fgh" using fgh by simp
show "\<guillemotleft>fgh : trg fgh \<star> fgh \<Rightarrow> fgh\<guillemotright>"
using fgh hcomp_def hcomp_trg_ide by auto
show "trg fgh \<star> fgh = (\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
proof -
have "(\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh =
(trg fgh \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
using fgh \<i>_def by metis
also have "... = (trg fgh \<star> fgh) \<cdot> (trg fgh \<star> trg fgh \<star> fgh)"
using fgh \<a>_def by fastforce
also have "... = trg fgh \<star> fgh"
using fgh hcomp_obj_self hcomp_assoc
by (simp add: hcomp_trg_ide)
finally show ?thesis by simp
qed
qed
thus "lunit fgh = fgh" by simp
qed
show "\<And>fgh. ide fgh \<Longrightarrow> runit fgh = fgh"
proof -
fix fgh
assume fgh: "ide fgh"
have "fgh = runit fgh"
proof (intro runit_eqI)
show "ide fgh" using fgh by simp
show "\<guillemotleft>fgh : fgh \<star> src fgh \<Rightarrow> fgh\<guillemotright>"
using fgh hcomp_def hcomp_ide_src by auto
show "fgh \<star> src fgh = (fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh)"
proof -
have "(fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh) =
(fgh \<star> src fgh) \<cdot> \<a> fgh (src fgh) (src fgh)"
using fgh \<i>_def by metis
also have "... = (fgh \<star> src fgh) \<cdot> (fgh \<star> src fgh \<star> src fgh)"
using fgh \<a>_def by fastforce
also have "... = fgh \<star> src fgh"
using fgh comp_arr_dom hcomp_obj_self by simp
finally show ?thesis by simp
qed
qed
thus "runit fgh = fgh" by simp
qed
show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow> ide (\<a> f g h)"
using \<a>_def VV.arr_char VVV.arr_char by auto
qed
theorem is_strict_bicategory:
shows "strict_bicategory vcomp hcomp \<a> \<i> src trg"
..
subsection "The Strictness Theorem"
text \<open>
The Strictness Theorem asserts: ``Every bicategory is biequivalent to a strict bicategory.''
This amounts to an equivalent (and perhaps more desirable) formulation of the
Coherence Theorem.
In this section we prove the Strictness Theorem by constructing an equivalence pseudofunctor
from a bicategory to its strictification.
\<close>
lemma iso_char:
shows "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
and "iso \<mu> \<Longrightarrow> inv \<mu> = MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
proof -
have 1: "iso \<mu> \<Longrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
proof -
assume \<mu>: "iso \<mu>"
obtain \<nu> where \<nu>: "inverse_arrows \<mu> \<nu>"
using \<mu> by auto
have "B.inverse_arrows (Map \<mu>) (Map \<nu>)"
proof
show "B.ide (Map \<mu> \<cdot>\<^sub>B Map \<nu>)"
proof -
have "Map \<mu> \<cdot>\<^sub>B Map \<nu> = Map (\<mu> \<cdot> \<nu>)"
using \<mu> \<nu> inverse_arrows_def Map_comp arr_char seq_char
by (metis (no_types, lifting) ide_compE)
moreover have "B.ide ..."
using \<nu> ide_char by blast
ultimately show ?thesis by simp
qed
show "B.ide (Map \<nu> \<cdot>\<^sub>B Map \<mu>)"
proof -
have "Map \<nu> \<cdot>\<^sub>B Map \<mu> = Map (\<nu> \<cdot> \<mu>)"
using \<mu> \<nu> inverse_arrows_def comp_char [of \<nu> \<mu>] by simp
moreover have "B.ide ..."
using \<nu> ide_char by blast
ultimately show ?thesis by simp
qed
qed
thus "arr \<mu> \<and> B.iso (Map \<mu>)"
using \<mu> by auto
qed
let ?\<nu> = "MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
have 2: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu> \<and> inv \<mu> = ?\<nu>"
proof
assume \<mu>: "arr \<mu> \<and> B.iso (Map \<mu>)"
have \<nu>: "\<guillemotleft>?\<nu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
using \<mu> arr_char dom_char cod_char by auto
have 4: "inverse_arrows \<mu> ?\<nu>"
proof
show "ide (?\<nu> \<cdot> \<mu>)"
proof -
have "?\<nu> \<cdot> \<mu> = dom \<mu>"
using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_inv_arr' dom_char by auto
thus ?thesis
using \<mu> by simp
qed
show "ide (\<mu> \<cdot> ?\<nu>)"
proof -
have "\<mu> \<cdot> ?\<nu> = cod \<mu>"
using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_arr_inv' cod_char by auto
thus ?thesis
using \<mu> by simp
qed
qed
thus "iso \<mu>" by auto
show "inv \<mu> = ?\<nu>"
using 4 inverse_unique by simp
qed
have 3: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu>"
using 2 by simp
show "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
using 1 3 by blast
show "iso \<mu> \<Longrightarrow> inv \<mu> = ?\<nu>"
using 1 2 by blast
qed
text \<open>
We next define a map \<open>UP\<close> from the given bicategory \<open>B\<close> to its strictification,
and show that it is an equivalence pseudofunctor.
The following auxiliary definition is not logically necessary, but it provides some
terms that can be the targets of simplification rules and thereby enables some proofs
to be done by simplification that otherwise could not be. Trying to eliminate it
breaks some short proofs below, so I have kept it.
\<close>
definition UP\<^sub>0
where "UP\<^sub>0 a \<equiv> if B.obj a then MkIde \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 else null"
lemma obj_UP\<^sub>0 [simp]:
assumes "B.obj a"
shows "obj (UP\<^sub>0 a)"
using assms UP\<^sub>0_def ide_MkIde [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] src_def obj_def by simp
lemma UP\<^sub>0_in_hom [intro]:
assumes "B.obj a"
shows "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<rightarrow> UP\<^sub>0 a\<guillemotright>"
and "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<Rightarrow> UP\<^sub>0 a\<guillemotright>"
using assms obj_UP\<^sub>0 by blast+
lemma UP\<^sub>0_simps [simp]:
assumes "B.obj a"
shows "ide (UP\<^sub>0 a)" "arr (UP\<^sub>0 a)"
and "src (UP\<^sub>0 a) = UP\<^sub>0 a" and "trg (UP\<^sub>0 a) = UP\<^sub>0 a"
and "dom (UP\<^sub>0 a) = UP\<^sub>0 a" and "cod (UP\<^sub>0 a) = UP\<^sub>0 a"
using assms obj_UP\<^sub>0
apply blast
using assms obj_UP\<^sub>0
apply blast
using assms obj_UP\<^sub>0
apply simp_all
using ideD(2) obj_UP\<^sub>0
apply blast
using ideD(3) obj_UP\<^sub>0
by blast
definition UP
where "UP \<mu> \<equiv> if B.arr \<mu> then MkArr \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle> \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle> \<mu> else null"
lemma Dom_UP [simp]:
assumes "B.arr \<mu>"
shows "Dom (UP \<mu>) = \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle>"
using assms UP_def by fastforce
lemma Cod_UP [simp]:
assumes "B.arr \<mu>"
shows "Cod (UP \<mu>) = \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle>"
using assms UP_def by fastforce
lemma Map_UP [simp]:
assumes "B.arr \<mu>"
shows "Map (UP \<mu>) = \<mu>"
using assms UP_def by fastforce
lemma arr_UP:
assumes "B.arr \<mu>"
shows "arr (UP \<mu>)"
using assms UP_def
by (intro arrI, fastforce+)
lemma UP_in_hom [intro]:
assumes "B.arr \<mu>"
shows "\<guillemotleft>UP \<mu> : UP\<^sub>0 (src\<^sub>B \<mu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B \<mu>)\<guillemotright>"
and "\<guillemotleft>UP \<mu> : UP (B.dom \<mu>) \<Rightarrow> UP (B.cod \<mu>)\<guillemotright>"
using assms arr_UP UP_def UP\<^sub>0_def dom_char cod_char src_def trg_def by auto
lemma UP_simps [simp]:
assumes "B.arr \<mu>"
shows "arr (UP \<mu>)"
and "src (UP \<mu>) = UP\<^sub>0 (src\<^sub>B \<mu>)" and "trg (UP \<mu>) = UP\<^sub>0 (trg\<^sub>B \<mu>)"
and "dom (UP \<mu>) = UP (B.dom \<mu>)" and "cod (UP \<mu>) = UP (B.cod \<mu>)"
using assms arr_UP UP_in_hom by auto
interpretation UP: "functor" V\<^sub>B vcomp UP
using UP_def arr_UP UP_simps(4-5)
apply unfold_locales
apply auto[4]
using arr_UP UP_def comp_char seq_char
by auto
interpretation UP: weak_arrow_of_homs V\<^sub>B src\<^sub>B trg\<^sub>B vcomp src trg UP
proof
fix \<mu>
assume \<mu>: "B.arr \<mu>"
show "isomorphic (UP (src\<^sub>B \<mu>)) (src (UP \<mu>))"
proof -
let ?\<phi> = "MkArr \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (src\<^sub>B \<mu>)"
have \<phi>: "\<guillemotleft>?\<phi> : UP (src\<^sub>B \<mu>) \<Rightarrow> src (UP \<mu>)\<guillemotright>"
proof
show 1: "arr ?\<phi>"
using \<mu> by (intro arrI, auto)
show "dom ?\<phi> = UP (src\<^sub>B \<mu>)"
using \<mu> 1 dom_char UP_def by simp
show "cod ?\<phi> = src (UP \<mu>)"
using \<mu> 1 cod_char src_def by auto
qed
have "iso ?\<phi>"
using \<mu> \<phi> iso_char src_def by auto
thus ?thesis
using \<phi> isomorphic_def by auto
qed
show "isomorphic (UP (trg\<^sub>B \<mu>)) (trg (UP \<mu>))"
proof -
let ?\<phi> = "MkArr \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B \<mu>)"
have \<phi>: "\<guillemotleft>?\<phi> : UP (trg\<^sub>B \<mu>) \<Rightarrow> trg (UP \<mu>)\<guillemotright>"
proof
show 1: "arr ?\<phi>"
using \<mu> by (intro arrI, auto)
show "dom ?\<phi> = UP (trg\<^sub>B \<mu>)"
using \<mu> 1 dom_char UP_def by simp
show "cod ?\<phi> = trg (UP \<mu>)"
using \<mu> 1 cod_char trg_def by auto
qed
have "iso ?\<phi>"
using \<mu> \<phi> iso_char trg_def by auto
thus ?thesis
using \<phi> isomorphic_def by auto
qed
qed
interpretation "functor" B.VV.comp VV.comp UP.FF
using UP.functor_FF by auto
interpretation HoUP_UP: composite_functor B.VV.comp VV.comp vcomp
UP.FF \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
interpretation UPoH: composite_functor B.VV.comp V\<^sub>B vcomp
\<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close> UP ..
abbreviation \<Phi>\<^sub>o
where "\<Phi>\<^sub>o fg \<equiv> MkArr (\<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>) \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle> (fst fg \<star>\<^sub>B snd fg)"
interpretation \<Phi>: transformation_by_components
B.VV.comp vcomp HoUP_UP.map UPoH.map \<Phi>\<^sub>o
proof
fix fg
assume fg: "B.VV.ide fg"
show "\<guillemotleft>\<Phi>\<^sub>o fg : HoUP_UP.map fg \<Rightarrow> UPoH.map fg\<guillemotright>"
using fg arr_char dom_char cod_char B.VV.ide_char B.VV.arr_char
UP.FF_def UP_def hcomp_def B.can_Ide_self src_def trg_def
apply (intro in_homI) by auto
next
fix \<mu>\<nu>
assume \<mu>\<nu>: "B.VV.arr \<mu>\<nu>"
show "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
proof -
have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
(fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
proof -
have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
MkArr (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>) (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
(B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>
MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
(fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
using \<mu>\<nu> B.VV.arr_char arr_char UP.FF_def hcomp_def UP_def
src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
by auto
also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
+ ((B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>))"
+ using \<mu>\<nu> B.VV.arr_char arr_MkArr
+ by (intro comp_MkArr arr_MkArr, auto)
+ also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
(fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
- using \<mu>\<nu> B.VV.arr_char arr_char comp_def B.comp_cod_arr
- apply (intro arr_eqI) by auto
+ using \<mu>\<nu> B.VV.arr_char B.comp_cod_arr by auto
finally show ?thesis by simp
qed
also have "... = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
proof -
have "UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>) =
MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
(fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>
MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>))"
using \<mu>\<nu> B.VV.arr_char arr_char UP.FF_def hcomp_def UP_def
src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
by auto
also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
(\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
+ ((fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>\<^sub>B (B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)))"
+ using \<mu>\<nu> B.VV.arr_char arr_MkArr
+ by (intro comp_MkArr arr_MkArr, auto)
+ also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
(fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
- using \<mu>\<nu> B.VV.arr_char arr_char comp_def B.comp_arr_dom
- by (intro arr_eqI, auto)
+ using \<mu>\<nu> B.VV.arr_char B.comp_arr_dom by auto
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
qed
abbreviation \<Phi>
where "\<Phi> \<equiv> \<Phi>.map"
lemma \<Phi>_in_hom [intro]:
assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
shows "\<guillemotleft>\<Phi> \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>)) \<rightarrow> UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))\<guillemotright>"
and "\<guillemotleft>\<Phi> \<mu>\<nu> : UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))
\<Rightarrow> UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))\<guillemotright>"
proof -
let ?\<mu> = "fst \<mu>\<nu>" and ?\<nu> = "snd \<mu>\<nu>"
show 1: "\<guillemotleft>\<Phi> \<mu>\<nu> : UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>) \<Rightarrow> UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)\<guillemotright>"
proof
show "arr (\<Phi> \<mu>\<nu>)"
using assms by auto
show "dom (\<Phi> \<mu>\<nu>) = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
proof -
have "B.VV.in_hom (?\<mu>, ?\<nu>) (B.dom ?\<mu>, B.dom ?\<nu>) (B.cod ?\<mu>, B.cod ?\<nu>)"
using assms B.VV.in_hom_char B.VV.arr_char by auto
hence "dom (\<Phi> \<mu>\<nu>) = HoUP_UP.map (B.dom ?\<mu>, B.dom ?\<nu>)"
by auto
also have "... = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
using assms UP.FF_def by auto
finally show ?thesis by simp
qed
show "cod (\<Phi> \<mu>\<nu>) = UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)"
using assms B.VV.in_hom_char B.VV.arr_char by auto
qed
show "\<guillemotleft>\<Phi> \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B ?\<nu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B ?\<mu>)\<guillemotright>"
using assms 1 src_dom [of "\<Phi> \<mu>\<nu>"] trg_dom [of "\<Phi> \<mu>\<nu>"] by auto
qed
lemma \<Phi>_simps [simp]:
assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
shows "arr (\<Phi> \<mu>\<nu>)"
and "src (\<Phi> \<mu>\<nu>) = UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>))" and "trg (\<Phi> \<mu>\<nu>) = UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))"
and "dom (\<Phi> \<mu>\<nu>) = UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))"
and "cod (\<Phi> \<mu>\<nu>) = UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))"
using assms \<Phi>_in_hom [of \<mu>\<nu>] by auto
lemma \<Phi>_ide_simps [simp]:
assumes "B.ide (fst fg)" and "B.ide (snd fg)" and "src\<^sub>B (fst fg) = trg\<^sub>B (snd fg)"
shows "Dom (\<Phi> fg) = \<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>"
and "Cod (\<Phi> fg) = \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle>"
and "Map (\<Phi> fg) = fst fg \<star>\<^sub>B snd fg"
using assms B.VV.ide_char B.VV.arr_char by auto
interpretation \<Phi>: natural_isomorphism B.VV.comp vcomp HoUP_UP.map UPoH.map \<Phi>
proof
fix fg
assume fg: "B.VV.ide fg"
have "arr (\<Phi> fg)"
using fg \<Phi>.preserves_reflects_arr [of fg] by simp
thus "iso (\<Phi> fg)"
using fg iso_char by simp
qed
lemma \<Phi>_ide_simp:
assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
shows "\<Phi> (f, g) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
using assms B.VV.ide_char B.VV.arr_char by simp
lemma \<Phi>'_ide_simp:
assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
shows "inv (\<Phi> (f, g)) = MkArr \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
using assms \<Phi>_ide_simp iso_char \<Phi>.components_are_iso [of "(f, g)"]
B.VV.ide_char B.VV.arr_char
by simp
interpretation UP: pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>
proof
fix f g h
assume f: "B.ide f" and g: "B.ide g" and h: "B.ide h"
and fg: "src\<^sub>B f = trg\<^sub>B g" and gh: "src\<^sub>B g = trg\<^sub>B h"
show "UP \<a>\<^sub>B[f, g, h] \<cdot> \<Phi> (f \<star>\<^sub>B g, h) \<cdot> (\<Phi> (f, g) \<star> UP h) =
\<Phi> (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> \<Phi> (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
proof -
have "UP \<a>\<^sub>B[f, g, h] \<cdot> \<Phi> (f \<star>\<^sub>B g, h) \<cdot> (\<Phi> (f, g) \<star> UP h) =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
proof -
have 1: "UP.hseq\<^sub>D (MkIde \<^bold>\<langle>f\<^bold>\<rangle>) (MkIde \<^bold>\<langle>g\<^bold>\<rangle>)"
using f g fg hseq_char src_def trg_def arr_char by auto
have 2: "UP.hseq\<^sub>D (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>))
(MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
proof -
have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
- using f g fg comp_def by auto
+ proof -
+ have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
+ using f g fg by simp
+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<cdot>\<^sub>B (f \<star>\<^sub>B g))"
+ using f g fg by (intro comp_MkArr arr_MkArr, auto)
+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
+ using f g fg by simp
+ finally show ?thesis by blast
+ qed
thus ?thesis
using f g h fg gh arr_char src_def trg_def by auto
qed
have "UP \<a>\<^sub>B[f, g, h] = MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h]"
using f g h fg gh UP_def B.HoHV_def B.HoVH_def B.VVV.arr_char B.VV.arr_char
B.VVV.dom_char B.VVV.cod_char
by simp
moreover have
"\<Phi> (f \<star>\<^sub>B g, h) = MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)"
using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def UP.FF_def UP_def hcomp_def
B.VV.arr_char B.can_Ide_self B.comp_arr_dom B.comp_cod_arr src_def trg_def
apply simp
by (metis (no_types, lifting) B.ide_hcomp B.ide_char arr_UP)
moreover have "\<Phi> (f, g) \<star> UP h =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
proof -
have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)
(B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<cdot>\<^sub>B (f \<star>\<^sub>B g) \<cdot>\<^sub>B B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)) =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
using f g fg B.can_Ide_self B.comp_arr_dom B.comp_cod_arr by simp
moreover have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot>
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g) =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
- using f g fg comp_def by auto
+ proof -
+ have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot>
+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g) =
+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<cdot>\<^sub>B (f \<star>\<^sub>B g))"
+ using f g fg arr_MkArr by (intro comp_MkArr arr_MkArr, auto)
+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
+ using f g fg by simp
+ finally show ?thesis by blast
+ qed
moreover have "B.can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) = B.inv \<a>\<^sub>B[f, g, h]"
using f g h fg gh B.canI_associator_0 B.inverse_arrows_can by simp
ultimately show ?thesis
using 1 2 f g h fg gh \<Phi>.map_def UP_def hcomp_def UP.FF_def
B.VV.arr_char trg_def B.can_Ide_self B.comp_cod_arr
by (simp del: B.hcomp_in_vhom)
qed
ultimately have "UP \<a>\<^sub>B[f, g, h] \<cdot> \<Phi> (f \<star>\<^sub>B g, h) \<cdot> (\<Phi> (f, g) \<star> UP h) =
MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h] \<cdot>
MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle>
(\<a>\<^sub>B[f, g, h] \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B
B.inv \<a>\<^sub>B[f, g, h])"
proof -
have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])) \<and>
Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)
(((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle>
(((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
Arr (MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h])"
using f g h fg gh B.\<alpha>.preserves_hom B.HoHV_def B.HoVH_def by auto
thus ?thesis
using f g h fg gh comp_def B.comp_arr_dom B.comp_cod_arr by simp
qed
also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
using B.comp_cod_arr B.comp_arr_inv'
by (auto simp add: f fg g gh h)
finally show ?thesis by simp
qed
also have "... = \<Phi> (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> \<Phi> (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
proof -
have "\<Phi> (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> \<Phi> (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h) =
\<Phi> (f, g \<star>\<^sub>B h) \<cdot> (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> \<Phi> (g, h)) \<cdot> (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
using f g h fg gh VVV.arr_char VV.arr_char arr_char src_def trg_def UP_def \<a>_def
by auto
also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
proof -
have "\<Phi> (f, g \<star>\<^sub>B h) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def UP.FF_def UP_def hcomp_def
B.VV.arr_char B.can_Ide_self B.comp_arr_dom B.comp_cod_arr src_def trg_def
arr_char
apply simp_all
by blast
moreover
have "\<Phi> (g, h) = MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h)"
using f g h fg gh \<Phi>.map_def UP.FF_def UP_def hcomp_def B.VV.arr_char
B.can_Ide_self src_def trg_def arr_char
by auto
moreover have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h) =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
B.comp_arr_dom B.comp_cod_arr
by auto
moreover
have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle> =
MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
proof -
have "\<guillemotleft>f : f \<Rightarrow>\<^sub>B f\<guillemotright> \<and> \<guillemotleft>g : g \<Rightarrow>\<^sub>B g\<guillemotright> \<and> \<guillemotleft>h : h \<Rightarrow>\<^sub>B h\<guillemotright>"
using f g h by auto
thus ?thesis
using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
B.comp_arr_dom B.comp_cod_arr
by simp
qed
ultimately show ?thesis
using comp_assoc by auto
qed
also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
proof -
have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h))"
using f g h fg gh by auto
thus ?thesis
using f g h fg gh comp_def by auto
qed
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
qed
lemma UP_is_pseudofunctor:
shows "pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>" ..
lemma UP_map\<^sub>0_obj [simp]:
assumes "B.obj a"
shows "UP.map\<^sub>0 a = UP\<^sub>0 a"
using assms UP.map\<^sub>0_def by auto
interpretation UP: full_functor V\<^sub>B vcomp UP
proof
fix \<mu> f g
assume f: "B.ide f" and g: "B.ide g"
assume \<mu>: "\<guillemotleft>\<mu> : UP f \<Rightarrow> UP g\<guillemotright>"
show "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow>\<^sub>B g\<guillemotright> \<and> UP \<nu> = \<mu>"
proof -
have 1: "\<guillemotleft>Map \<mu> : f \<Rightarrow>\<^sub>B g\<guillemotright>"
using f g \<mu> UP_def arr_char in_hom_char by auto
moreover have "UP (Map \<mu>) = \<mu>"
proof -
have "\<mu> = MkArr (Dom \<mu>) (Cod \<mu>) (Map \<mu>)"
using \<mu> MkArr_Map by auto
also have "... = UP (Map \<mu>)"
using f g \<mu> 1 UP_def arr_char dom_char cod_char
apply simp
by (metis (no_types, lifting) B.in_homE Dom.simps(1) in_homE)
finally show ?thesis by auto
qed
ultimately show ?thesis by blast
qed
qed
interpretation UP: faithful_functor V\<^sub>B vcomp UP
using arr_char UP_def
by (unfold_locales, simp_all)
interpretation UP: fully_faithful_functor V\<^sub>B vcomp UP ..
lemma UP_is_fully_faithful_functor:
shows "fully_faithful_functor V\<^sub>B vcomp UP"
..
no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>") (* Inherited from functor, I think. *)
lemma Map_reflects_hhom:
assumes "B.obj a" and "B.obj b" and "ide g"
and "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
shows "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
proof
have 1: "B.ide (Map g)"
using assms ide_char by blast
show "B.arr (Map g)"
using 1 by simp
show "src\<^sub>B (Map g) = a"
proof -
have "src\<^sub>B (Map g) = Map (src g)"
using assms src_def apply simp
by (metis (no_types, lifting) E.eval_simps(2) E.Ide_implies_Arr arr_char ideE)
also have "... = Map (UP.map\<^sub>0 a)"
using assms by (metis (no_types, lifting) in_hhomE)
also have "... = a"
using assms UP.map\<^sub>0_def UP_def [of a] src_def by auto
finally show ?thesis by simp
qed
show "trg\<^sub>B (Map g) = b"
proof -
have "trg\<^sub>B (Map g) = Map (trg g)"
using assms trg_def apply simp
by (metis (no_types, lifting) E.eval_simps(3) E.Ide_implies_Arr arr_char ideE)
also have "... = Map (UP.map\<^sub>0 b)"
using assms by (metis (no_types, lifting) in_hhomE)
also have "... = b"
using assms UP.map\<^sub>0_def UP_def [of b] src_def by auto
finally show ?thesis by simp
qed
qed
lemma eval_Dom_ide [simp]:
assumes "ide g"
shows "\<lbrace>Dom g\<rbrace> = Map g"
using assms dom_char ideD by auto
lemma Cod_ide:
assumes "ide f"
shows "Cod f = Dom f"
using assms dom_char by auto
lemma Map_preserves_objects:
assumes "obj a"
shows "B.obj (Map a)"
proof -
have "src\<^sub>B (Map a) = Map (src a)"
using assms src_def apply simp
using E.eval_simps(2) E.Ide_implies_Arr arr_char ideE
by (metis (no_types, lifting) objE)
also have 1: "... = \<lbrace>E.Src (Dom a)\<rbrace>"
using assms src_def by auto
also have "... = \<lbrace>\<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0\<rbrace>"
using assms B.src.is_extensional 1 by force
also have "... = Map a"
using assms by auto
finally have "src\<^sub>B (Map a) = Map a" by simp
moreover have "B.arr (Map a)"
using assms B.ideD arr_char by auto
ultimately show ?thesis
using B.obj_def by simp
qed
interpretation UP: equivalence_pseudofunctor
V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>
proof
(* UP is full, hence locally full. *)
show "\<And>f f' \<nu>. \<lbrakk> B.ide f; B.ide f'; src\<^sub>B f = src\<^sub>B f'; trg\<^sub>B f = trg\<^sub>B f';
\<guillemotleft>\<nu> : UP f \<Rightarrow> UP f'\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> UP \<mu> = \<nu>"
using UP.is_full by simp
(* UP is essentially surjective up to equivalence on objects. *)
show "\<And>b. obj b \<Longrightarrow> \<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
proof -
fix b
assume b: "obj b"
have 1: "B.obj (Map b)"
using b Map_preserves_objects by simp
have 3: "UP.map\<^sub>0 (Map b) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
using b 1 UP.map\<^sub>0_def [of "Map b"] UP_def src_def arr_char by auto
have 4: "b = MkArr (Dom b) (Dom b) (Map b)"
using b objE eval_Dom_ide
by (metis (no_types, lifting) dom_char ideD(2) obj_def)
let ?\<phi> = "MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Dom b) (Map b)"
have \<phi>: "arr ?\<phi>"
proof -
have 2: "E.Obj (Dom b)"
proof -
have "Dom b = Dom (src b)"
using b obj_def by simp
moreover have "Dom (src b) = E.Src (Dom b)"
using b obj_def src_def arr_char by simp
moreover have "E.Obj (E.Src (Dom b))"
using b obj_def src_def arr_char arr_def E.Obj_Src by simp
ultimately show ?thesis by simp
qed
have "E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0"
using 1 by auto
moreover have "E.Nml (Dom b) \<and> E.Ide (Dom b)"
using b arr_char [of b] by auto
moreover have "E.Src \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Src (Dom b)"
using b 1 2 B.obj_def obj_char
by (cases "Dom b", simp_all)
moreover have "E.Trg \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Trg (Dom b)"
using b 1 2 B.obj_def obj_char
by (cases "Dom b", simp_all)
moreover have "\<guillemotleft>Map b : \<lbrace>\<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom b\<rbrace>\<guillemotright>"
using b 1 by (elim objE, auto)
ultimately show ?thesis
using arr_char \<open>E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<close> by auto
qed
hence "iso ?\<phi>"
using 1 iso_char by auto
moreover have "dom ?\<phi> = UP.map\<^sub>0 (Map b)"
using \<phi> dom_char b 1 3 B.objE UP.map\<^sub>0_def UP_def src_def by auto
moreover have "cod ?\<phi> = b"
using \<phi> cod_char b 4 1 by auto
ultimately have "isomorphic (UP.map\<^sub>0 (Map b)) b"
using \<phi> 3 4 isomorphic_def by blast
moreover have 5: "obj (UP.map\<^sub>0 (Map b))"
using 1 UP.map\<^sub>0_simps(2) by simp
ultimately have 6: "UP.map\<^sub>0 (Map b) = b"
using b isomorphic_objects_are_equal by simp
have "equivalent_objects (UP.map\<^sub>0 (Map b)) b"
using b 6 equivalent_objects_reflexive [of b] by simp
thus "\<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
using 1 6 by auto
qed
(* UP is locally essentially surjective. *)
show "\<And>a b g. \<lbrakk> B.obj a; B.obj b; \<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>; ide g \<rbrakk> \<Longrightarrow>
\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
proof -
fix a b g
assume a: "B.obj a" and b: "B.obj b"
assume g_in_hhom: "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
assume ide_g: "ide g"
have 1: "B.ide (Map g)"
using ide_g ide_char by blast
have "arr (UP a)"
using a by auto
have "arr (UP b)"
using b by auto
have Map_g_eq: "Map g = \<lbrace>Dom g\<rbrace>"
using ide_g by simp
have Map_g_in_hhom: "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
using a b ide_g g_in_hhom Map_reflects_hhom by simp
let ?\<phi> = "MkArr \<^bold>\<langle>Map g\<^bold>\<rangle> (Dom g) (Map g)"
have \<phi>: "arr ?\<phi>"
proof -
have "\<guillemotleft>Map ?\<phi> : \<lbrace>Dom ?\<phi>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<phi>\<rbrace>\<guillemotright>"
using 1 Map_g_eq by auto
moreover have "E.Ide \<^bold>\<langle>Map g\<^bold>\<rangle> \<and> E.Nml \<^bold>\<langle>Map g\<^bold>\<rangle>"
using 1 by simp
moreover have "E.Ide (Dom g) \<and> E.Nml (Dom g)"
using ide_g arr_char ide_char by blast
moreover have "E.Src \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Src (Dom g)"
using ide_g g_in_hhom src_def Map_g_in_hhom
by (metis (no_types, lifting) B.ideD(2) B.in_hhom_def B.objE B.obj_def'
Dom.simps(1) E.Src.simps(2) UP.map\<^sub>0_def \<open>arr (UP a)\<close> a in_hhomE UP_def)
moreover have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Trg (Dom g)"
proof -
have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
using Map_g_in_hhom by auto
also have "... = E.Trg (Dom g)"
proof -
have "E.Trg (Dom g) = Dom (trg g)"
using ide_g trg_def by simp
also have "... = Dom (UP.map\<^sub>0 b)"
using g_in_hhom by auto
also have "... = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
using b \<open>arr (UP b)\<close> UP.map\<^sub>0_def src_def UP_def B.objE by auto
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
ultimately show ?thesis
using arr_char by simp
qed
have "\<guillemotleft>?\<phi> : UP (Map g) \<Rightarrow> g\<guillemotright>"
proof
show "arr ?\<phi>"
using \<phi> by simp
show "dom ?\<phi> = UP (Map g)"
using \<phi> 1 dom_char UP_def by simp
show "cod ?\<phi> = g"
proof -
have "cod ?\<phi> = MkArr (Dom g) (Dom g) (Map g)"
using ide_g cod_char Map_g_eq \<phi> by auto
moreover have "Dom g = Cod g"
using ide_g Cod_ide by simp
ultimately have "cod ?\<phi> = MkArr (Dom g) (Cod g) (Map g)"
by simp
thus ?thesis
by (metis (no_types, lifting) "1" B.comp_ide_self
\<open>Dom g = Cod g\<close> comp_cod_arr ideD(1) ideD(3) ide_g comp_char)
qed
qed
moreover have "iso ?\<phi>"
using \<phi> 1 iso_char by simp
ultimately have "isomorphic (UP (Map g)) g"
using isomorphic_def by auto
thus "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
using 1 Map_g_in_hhom by auto
qed
qed
theorem UP_is_equivalence_pseudofunctor:
shows "equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>" ..
text \<open>
Next, we work out the details of the equivalence pseudofunctor \<open>DN\<close> in the
converse direction.
\<close>
definition DN
where "DN \<mu> \<equiv> if arr \<mu> then Map \<mu> else B.null"
lemma DN_in_hom [intro]:
assumes "arr \<mu>"
shows "\<guillemotleft>DN \<mu> : DN (src \<mu>) \<rightarrow>\<^sub>B DN (trg \<mu>)\<guillemotright>"
and "\<guillemotleft>DN \<mu> : DN (dom \<mu>) \<Rightarrow>\<^sub>B DN (cod \<mu>)\<guillemotright>"
using assms DN_def arr_char [of \<mu>] B.vconn_implies_hpar(1-2) E.eval_in_hom(1)
B.in_hhom_def
by auto
lemma DN_simps [simp]:
assumes "arr \<mu>"
shows "B.arr (DN \<mu>)"
and "src\<^sub>B (DN \<mu>) = DN (src \<mu>)" and "trg\<^sub>B (DN \<mu>) = DN (trg \<mu>)"
and "B.dom (DN \<mu>) = DN (dom \<mu>)" and "B.cod (DN \<mu>) = DN (cod \<mu>)"
using assms DN_in_hom by auto
interpretation "functor" vcomp V\<^sub>B DN
using DN_def seqE Map_comp seq_char
by (unfold_locales, auto)
interpretation DN: weak_arrow_of_homs vcomp src trg V\<^sub>B src\<^sub>B trg\<^sub>B DN
proof
fix \<mu>
assume \<mu>: "arr \<mu>"
show "B.isomorphic (DN (src \<mu>)) (src\<^sub>B (DN \<mu>))"
proof -
have "DN (src \<mu>) = src\<^sub>B (DN \<mu>)"
using \<mu> DN_def arr_char E.eval_simps(2) E.Ide_implies_Arr
apply simp
by (metis (no_types, lifting) B.vconn_implies_hpar(1) E.Nml_implies_Arr ideE
ide_src src_simps(3))
moreover have "B.ide (DN (src \<mu>))"
using \<mu> by simp
ultimately show ?thesis
using \<mu> B.isomorphic_reflexive by auto
qed
show "B.isomorphic (DN (trg \<mu>)) (trg\<^sub>B (DN \<mu>))"
proof -
have "DN (trg \<mu>) = trg\<^sub>B (DN \<mu>)"
using \<mu> DN_def arr_char E.eval_simps(3) E.Ide_implies_Arr
apply simp
by (metis (no_types, lifting) B.vconn_implies_hpar(2) E.Nml_implies_Arr ideE
ide_trg trg_simps(3))
moreover have "B.ide (DN (trg \<mu>))"
using \<mu> by simp
ultimately show ?thesis
using B.isomorphic_reflexive by auto
qed
qed
interpretation "functor" VV.comp B.VV.comp DN.FF
using DN.functor_FF by auto
interpretation HoDN_DN: composite_functor VV.comp B.VV.comp V\<^sub>B
DN.FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>B (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
interpretation DNoH: composite_functor VV.comp vcomp V\<^sub>B
\<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> DN ..
abbreviation \<Psi>\<^sub>o
where "\<Psi>\<^sub>o fg \<equiv> B.can (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
abbreviation \<Psi>\<^sub>o'
where "\<Psi>\<^sub>o' fg \<equiv> B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
lemma \<Psi>\<^sub>o_in_hom:
assumes "VV.ide fg"
shows "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
and "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
and "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
proof -
have 1: "E.Ide (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
unfolding E.Ide.simps(3)
apply (intro conjI)
using assms VV.ide_char VV.arr_char arr_char
apply simp
using VV.arr_char VV.ideD(1) assms
apply blast
by (metis (no_types, lifting) VV.arrE VV.ideD(1) assms src_simps(1) trg_simps(1))
have 2: "E.Ide (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
using 1
by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char assms)
have 3: "\<^bold>\<lfloor>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<^bold>\<rfloor>"
by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml VV.arr_char VV.ideD(1) arr_char assms 1)
have 4: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
using assms VV.ide_char VV.arr_char arr_char by simp
show "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
using 1 2 3 4 by auto
show "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
using 1 2 3 4 by auto
show "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
using 1 2 3 B.inverse_arrows_can by blast
qed
interpretation \<Psi>: transformation_by_components
VV.comp V\<^sub>B HoDN_DN.map DNoH.map \<Psi>\<^sub>o
proof
fix fg
assume fg: "VV.ide fg"
have 1: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
using fg VV.ide_char VV.arr_char arr_char by simp
show "\<guillemotleft>\<Psi>\<^sub>o fg : HoDN_DN.map fg \<Rightarrow>\<^sub>B DNoH.map fg\<guillemotright>"
proof
show "B.arr (\<Psi>\<^sub>o fg)"
using fg \<Psi>\<^sub>o_in_hom by blast
show "B.dom (\<Psi>\<^sub>o fg) = HoDN_DN.map fg"
proof -
have "B.dom (\<Psi>\<^sub>o fg) = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
using fg \<Psi>\<^sub>o_in_hom by blast
also have "... = HoDN_DN.map fg"
using fg DN.FF_def DN_def VV.arr_char src_def trg_def VV.ide_char by auto
finally show ?thesis by simp
qed
show "B.cod (\<Psi>\<^sub>o fg) = DNoH.map fg"
proof -
have "B.cod (\<Psi>\<^sub>o fg) = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
using fg \<Psi>\<^sub>o_in_hom by blast
also have "... = DNoH.map fg"
proof -
have "DNoH.map fg =
B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
(Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
using fg DN_def Map_hcomp VV.arr_char
apply simp
using VV.ideD(1) by blast
also have "... =
B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
proof -
have "(Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) =
B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
using fg 1 \<Psi>\<^sub>o_in_hom B.comp_cod_arr by blast
thus ?thesis by simp
qed
also have "... = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
proof -
have "B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) = \<Psi>\<^sub>o fg"
using fg VV.ide_char Cod_ide by simp
thus ?thesis
using fg 1 \<Psi>\<^sub>o_in_hom [of fg] B.comp_arr_inv' by fastforce
qed
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
qed
next
show "\<And>f. VV.arr f \<Longrightarrow>
\<Psi>\<^sub>o (VV.cod f) \<cdot>\<^sub>B HoDN_DN.map f = DNoH.map f \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom f)"
proof -
fix \<mu>\<nu>
assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
show "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
proof -
have 1: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>))"
unfolding E.Ide.simps(3)
apply (intro conjI)
using \<mu>\<nu> VV.ide_char VV.arr_char arr_char
apply simp
using VV.arr_char VV.ideD(1) \<mu>\<nu>
apply blast
by (metis (no_types, lifting) VV.arrE \<mu>\<nu> src_simps(1) trg_simps(1))
have 2: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>))"
using 1
by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char \<mu>\<nu>)
have 3: "\<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor>"
by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml VV.arr_char arr_char \<mu>\<nu> 1)
have 4: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>))"
unfolding E.Ide.simps(3)
apply (intro conjI)
using \<mu>\<nu> VV.ide_char VV.arr_char arr_char
apply simp
using VV.arr_char VV.ideD(1) \<mu>\<nu>
apply blast
by (metis (no_types, lifting) "1" E.Ide.simps(3) VV.arrE \<mu>\<nu> arrE)
have 5: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))"
using 4
by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char \<mu>\<nu>)
have 6: "\<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor>"
by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml VV.arr_char arr_char \<mu>\<nu> 1)
have A: "\<guillemotleft>\<Psi>\<^sub>o' \<mu>\<nu> : \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<rbrace>
\<Rightarrow>\<^sub>B \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
using 1 2 3 by auto
have B: "\<guillemotleft>Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>) :
\<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
using \<mu>\<nu> VV.arr_char arr_char src_def trg_def E.Nml_implies_Arr E.eval_simps'(2-3)
by auto
have C: "\<guillemotleft>B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) :
\<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
using 4 5 6 by auto
have "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> =
B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
(Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>))"
using \<mu>\<nu> VV.arr_char VV.cod_char arr_char src_def trg_def cod_char DN.FF_def DN_def
by auto
also have "... = B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))
(Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
(Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o \<mu>\<nu>"
using B B.comp_assoc \<mu>\<nu> VV.arr_char arr_char src_def trg_def B.inverse_arrows_can
E.Ide_HcompNml E.Nmlize_Nml E.Nml_HcompNml(1) B.can_Ide_self B.comp_arr_dom
by auto
also have "... = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
proof -
have "DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>) =
B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
(Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
using \<mu>\<nu> VV.arr_char arr_char src_def trg_def E.Ide_HcompNml E.Nml_HcompNml
E.Src_HcompNml E.Trg_HcompNml \<mu>\<nu> A B C DN_def hcomp_def B.comp_assoc
by auto
moreover have "\<Psi>\<^sub>o (VV.dom \<mu>\<nu>) = \<Psi>\<^sub>o \<mu>\<nu>"
using \<mu>\<nu> VV.dom_char VV.arr_char by auto
ultimately show ?thesis
using B.comp_assoc by simp
qed
finally show ?thesis by blast
qed
qed
qed
abbreviation \<Psi>
where "\<Psi> \<equiv> \<Psi>.map"
interpretation \<Psi>: natural_isomorphism VV.comp V\<^sub>B HoDN_DN.map DNoH.map \<Psi>
proof
show "\<And>fg. VV.ide fg \<Longrightarrow> B.iso (\<Psi> fg)"
proof -
fix fg
assume fg: "VV.ide fg"
have "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
using fg \<Psi>\<^sub>o_in_hom by simp
thus "B.iso (\<Psi> fg)"
using fg B.iso_def \<Psi>.map_simp_ide by auto
qed
qed
no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
lemma \<Psi>_in_hom [intro]:
assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
shows "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
and "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
\<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
proof -
have 1: "VV.arr \<mu>\<nu>"
using assms VV.arr_char by simp
show 2: "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
\<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
proof -
have "HoDN_DN.map (VV.dom \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
using assms 1 DN.FF_def by auto
moreover have "DNoH.map (VV.cod \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
using assms 1 by simp
ultimately show ?thesis
using assms 1 \<Psi>.preserves_hom by auto
qed
show "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
using assms 1 2 B.src_dom [of "\<Psi> \<mu>\<nu>"] B.trg_dom [of "\<Psi> \<mu>\<nu>"] by auto
qed
lemma \<Psi>_simps [simp]:
assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
shows "B.arr (\<Psi> \<mu>\<nu>)"
and "src\<^sub>B (\<Psi> \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))" and "trg\<^sub>B (\<Psi> \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
and "B.dom (\<Psi> \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
and "B.cod (\<Psi> \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
proof
show "VV.arr \<mu>\<nu>"
using assms by blast
have 1: "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
using assms by blast
show "src\<^sub>B (\<Psi> \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))"
using 1 by fast
show "trg\<^sub>B (\<Psi> \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
using 1 by fast
have 2: "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
\<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
using assms by blast
show "B.dom (\<Psi> \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
using 2 by fast
show "B.cod (\<Psi> \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
using 2 by fast
qed
interpretation DN: pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>
proof
show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
proof -
fix f g h
assume f: "ide f" and g: "ide g" and h: "ide h"
and fg: "src f = trg g" and gh: "src g = trg h"
show "DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
proof -
have 1: "E.Trg (Dom g) = E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<and>
\<lbrace>E.Trg (Dom g)\<rbrace> = \<lbrace>E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<rbrace>"
using f g h fg gh arr_char src_def trg_def E.Trg_HcompNml
by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
have 2: "arr (MkArr (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
(B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
(Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
proof -
have "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
(Map f \<star>\<^sub>B
B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
proof (intro B.comp_in_homI)
show 2: "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B
EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<guillemotright>"
using f g h fg gh 1
apply (intro B.can_in_hom)
apply (metis (no_types, lifting) E.Ide_HcompNml E.Nml_HcompNml(1)
arr_char ideD(1) src_simps(1) trg_simps(1))
apply (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml ideD(1)
arr_char src_simps(1) trg_simps(1))
by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml ideD(1) arr_char src_simps(1) trg_simps(1))
show "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) :
EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<Rightarrow>\<^sub>B
EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
proof -
have "E.Ide (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
using f g h fg gh 1 Cod_ide E.Ide_HcompNml arr_char
apply simp
by (metis (no_types, lifting) ideD(1) src_simps(1) trg_simps(1))
moreover have "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
using f g h fg gh
by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
arr_char calculation ideD(1) src_simps(1) trg_simps(1))
moreover have "E.Nmlize (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) =
E.Nmlize (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
using f g h fg gh
by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml arr_char calculation(1) ideD(1) src_simps(1) trg_simps(1))
ultimately show ?thesis
using B.can_in_hom [of "Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h"]
by blast
qed
show
"\<guillemotleft>Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
using f g h fg gh B.can_in_hom
apply simp
proof (intro B.hcomp_in_vhom B.comp_in_homI)
show 1: "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
EVAL (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Dom g \<^bold>\<star> Dom h)\<guillemotright>"
using g h gh B.can_in_hom
by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1) src_simps(1) trg_simps(1))
show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
EVAL (Cod g \<^bold>\<star> Cod h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
using g h gh B.can_in_hom
by (metis (no_types, lifting) Cod_ide E.Ide.simps(3) E.Ide_HcompNml
E.Nml_HcompNml(1) E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1)
src_simps(2) trg_simps(2))
show "\<guillemotleft>Map g \<star>\<^sub>B Map h : EVAL (Dom g \<^bold>\<star> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<star> Cod h)\<guillemotright>"
using g h gh 1 Map_in_Hom B.hcomp_in_vhom B.not_arr_null B.seq_if_composable
B.trg.is_extensional B.trg.preserves_hom B.vconn_implies_hpar(2)
B.vconn_implies_hpar(4) Cod_ide E.eval.simps(3) Map_ide(1)
arr_char ideD(1)
by (metis (no_types, lifting))
show "\<guillemotleft>Map f : Map f \<Rightarrow>\<^sub>B EVAL (Cod f)\<guillemotright>"
using f arr_char Cod_ide by auto
show "src\<^sub>B (Map f) = trg\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
using f g h fg gh 1 2 src_def trg_def B.arrI B.hseqE B.not_arr_null
B.trg.is_extensional B.trg.preserves_hom B.vconn_implies_hpar(2)
B.vconn_implies_hpar(4) E.eval.simps(3)
by (metis (no_types, lifting) Map_ide(1))
qed
qed
thus ?thesis
using f g h fg gh arr_char src_def trg_def E.Nml_HcompNml E.Ide_HcompNml
ideD(1)
apply (intro arr_MkArr) by auto
qed
have 3: "E.Ide (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using g h gh ide_char arr_char src_def trg_def E.Ide_HcompNml Cod_ide
by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
have 4: "E.Ide (Dom g \<^bold>\<star> Dom h)"
using g h gh ide_char arr_char src_def trg_def Cod_ide
by (metis (no_types, lifting) E.Ide.simps(3) arrE ideD(1) src_simps(2) trg_simps(2))
have 5: "E.Nmlize (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Nmlize (Dom g \<^bold>\<star> Dom h)"
using g h gh ide_char arr_char src_def trg_def E.Nml_HcompNml
by (metis (no_types, lifting) 4 E.Ide.simps(3) E.Nmlize.simps(3) E.Nmlize_Nml
ideD(1))
have 6: "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h fg gh arr_char src_def trg_def
by (metis (no_types, lifting) 1 E.Nml_HcompNml(1) E.Ide_HcompNml ideD(1)
src_simps(2) trg_simps(2))
have 7: "E.Ide (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h fg gh arr_char src_def trg_def
by (metis (no_types, lifting) 1 3 E.Ide.simps(3) ideD(1) src_simps(2) trg_simps(2))
have 8: "E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
E.Nmlize (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h fg gh arr_char src_def trg_def
7 E.Nml_HcompNml(1) ideD(1)
by auto
have "DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
proof -
have 9: "VVV.arr (f, g, h)"
using f g h fg gh VVV.arr_char VV.arr_char arr_char ideD by simp
have 10: "VV.ide (f, g)"
using f g fg VV.ide_char by auto
have 11: "VV.ide (hcomp f g, h)"
using f g h fg gh VV.ide_char VV.arr_char by simp
have 12: "arr (MkArr (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
(B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
proof (intro arr_MkArr)
show "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE"
using g h gh
by (metis (no_types, lifting) 3 E.Nml_HcompNml(1) arr_char ideD(1)
mem_Collect_eq src_simps(2) trg_simps(2))
show "Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h \<in> IDE"
using g h gh Cod_ide \<open>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE\<close> by auto
show "B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)
\<in> HOM (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
proof
show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
\<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
proof (intro conjI)
show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
using g h gh Cod_ide by simp
show "E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
using g h gh Cod_ide by simp
show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
\<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
proof (intro B.comp_in_homI)
show "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
\<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace>\<guillemotright>"
using 3 4 5 by blast
show "\<guillemotleft>Map g \<star>\<^sub>B Map h : \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace>\<guillemotright>"
using g h gh
by (metis (no_types, lifting) 4 B.ide_in_hom(2) Cod_ide E.eval.simps(3)
E.ide_eval_Ide Map_ide(2))
show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
\<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
using 3 4 5 Cod_ide g h by auto
qed
qed
qed
qed
have "DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
proof -
have "DN (\<a> f g h) =
(B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
((Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))"
using f g h fg gh 1 2 9 10 11 12 DN_def \<a>_def hcomp_def src_def trg_def
B.comp_assoc Cod_ide
by simp
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
(Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
proof -
have "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
\<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map g \<star>\<^sub>B Map h\<guillemotright>"
using g h 3 4 5 B.can_in_hom [of "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom g \<^bold>\<star> Dom h"]
by simp
hence "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using B.comp_cod_arr by auto
also have "... = Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
using f g h fg gh arr_char src_def trg_def B.vcomp_can
B.can_Ide_self
using 3 4 5 by auto
finally have "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
(Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
by simp
thus ?thesis by simp
qed
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
proof -
have "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
\<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<guillemotright>"
using f g h 6 7 8
B.can_in_hom [of "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h"]
by simp
hence "(Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using B.comp_cod_arr by auto
thus ?thesis by simp
qed
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h fg gh src_def trg_def B.vcomp_can
using 6 7 8 by auto
also have "... = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
using f g h fg gh src_def trg_def B.can_Ide_self
using 6 by blast
finally show ?thesis by simp
qed
have "DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
(B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
proof -
have "DN (\<a> f g h) =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h fg gh DN_def 1 4 6 7 B.can_Ide_self E.HcompNml_assoc
E.Ide.simps(3) \<open>DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<close> ide_char
by (metis (no_types, lifting) arr_char ideD(1))
thus ?thesis
using f g h fg gh 1 2 4 5 6 7 8 9 10 11 12 DN_def \<alpha>_def
\<Psi>.map_simp_ide hcomp_def src_def trg_def Cod_ide
by simp
qed
also have
"... = (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)) \<cdot>\<^sub>B
(B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
using B.comp_assoc by simp
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
proof -
have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
proof -
have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B B.can (Dom h) (Dom h)"
using h B.can_Ide_self by fastforce
also have "... = B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
using f g h 1 4 7 arr_char E.Nml_HcompNml(1) E.Src_HcompNml
B.hcomp_can [of "Dom f \<^bold>\<star> Dom g" "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g" "Dom h" "Dom h"]
by (metis (no_types, lifting) E.Nmlize.simps(3) E.Nmlize_Nml
E.Ide.simps(3) E.Ide_HcompNml E.Src.simps(3) arrE ideD(1))
finally show ?thesis by simp
qed
moreover have
"B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
proof -
have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
using f g h 1 4 7
by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
arrE ideD(1))
moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h 1 4 7 E.Ide_HcompNml E.Nml_HcompNml(1) arr_char calculation
ideD(1)
by auto
moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h 1 4 6 by blast
moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h 1 4 7
by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml E.Ide.simps(3) arrE calculation(1) ideD(1))
moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h 1 4 7 E.HcompNml_assoc by fastforce
ultimately show ?thesis
using B.vcomp_can by simp
qed
ultimately show ?thesis by simp
qed
also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
proof -
have "E.Ide ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
using 1 4 7 by simp
moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
using f g 1 4 7
by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
arrE ideD(1))
moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h 1 8 6 7 by blast
moreover have "E.Nmlize ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h) =
E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
using f g h 1 4 7 E.Nml_HcompNml(1) by fastforce
moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
using f g h 1 4 7
by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
E.Nmlize_Nml E.HcompNml_assoc E.Ide.simps(3) arrE ideD(1))
ultimately show ?thesis
using B.vcomp_can by simp
qed
finally show ?thesis by simp
qed
also have "... = \<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
proof -
have "\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h] =
(\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h))) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
using B.comp_assoc by simp
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
proof -
have "\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
proof -
have "\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) =
B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
(Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
proof -
have "VV.ide (g, h)"
using g h gh VV.ide_char VV.arr_char by simp
moreover have "VV.ide (f, hcomp g h)"
using f g h fg gh VV.ide_char VV.arr_char by simp
ultimately show ?thesis
using f g h fg gh \<Psi>.map_simp_ide DN_def hcomp_def src_def trg_def
by simp
qed
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
(B.can (Dom f) (Dom f) \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
proof -
have "Map f = B.can (Dom f) (Dom f)"
using f arr_char B.can_Ide_self [of "Dom f"] Map_ide
by (metis (no_types, lifting) ide_char')
thus ?thesis by simp
qed
also have
"... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
using 1 4 5 7 B.hcomp_can by auto
also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
using 1 4 5 6 7 8 B.vcomp_can by auto
finally show ?thesis by simp
qed
moreover have "\<a>\<^sub>B[DN f, DN g, DN h] =
B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
using f g h 1 4 7 DN_def B.canE_associator(1) Map_ide
by auto
ultimately show ?thesis by simp
qed
also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
using 1 4 5 6 7 8 E.Nmlize_Hcomp_Hcomp
B.vcomp_can [of "(Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h" "Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h"
"Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h"]
by simp
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
qed
qed
lemma DN_is_pseudofunctor:
shows "pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>"
..
interpretation faithful_functor vcomp V\<^sub>B DN
proof
fix \<mu> \<mu>'
assume par: "par \<mu> \<mu>'" and eq: "DN \<mu> = DN \<mu>'"
show "\<mu> = \<mu>'"
proof (intro arr_eqI)
show "arr \<mu>"
using par by simp
show "arr \<mu>'"
using par by simp
show "Dom \<mu> = Dom \<mu>'"
using par arr_char dom_char by force
show "Cod \<mu> = Cod \<mu>'"
using par arr_char cod_char by force
show "Map \<mu> = Map \<mu>'"
using par eq DN_def by simp
qed
qed
no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
lemma DN_UP:
assumes "B.arr \<mu>"
shows "DN (UP \<mu>) = \<mu>"
using assms UP_def DN_def arr_UP by auto
interpretation DN: equivalence_pseudofunctor
vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>
proof
(* DN is locally (but not globally) full. *)
show "\<And>f f' \<nu>. \<lbrakk> ide f; ide f'; src f = src f'; trg f = trg f'; \<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright> \<rbrakk>
\<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
proof -
fix f f' \<nu>
assume f: "ide f" and f': "ide f'"
and eq_src: "src f = src f'" and eq_trg: "trg f = trg f'"
and \<nu>: "\<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright>"
show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
proof -
let ?\<mu> = "MkArr (Dom f) (Dom f') \<nu>"
have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright>"
proof
have "Map f = \<lbrace>Dom f\<rbrace>"
using f by simp
have "Map f' = \<lbrace>Dom f'\<rbrace>"
using f' by simp
have "Dom f' = Cod f'"
using f' Cod_ide by simp
show \<mu>: "arr ?\<mu>"
proof -
have "E.Nml (Dom ?\<mu>) \<and> E.Ide (Dom ?\<mu>)"
proof -
have "E.Nml (Dom f) \<and> E.Ide (Dom f)"
using f ide_char arr_char by blast
thus ?thesis
using f by simp
qed
moreover have "E.Nml (Cod ?\<mu>) \<and> E.Ide (Cod ?\<mu>)"
proof -
have "E.Nml (Dom f') \<and> E.Ide (Dom f')"
using f' ide_char arr_char by blast
thus ?thesis
using f' by simp
qed
moreover have "E.Src (Dom ?\<mu>) = E.Src (Cod ?\<mu>)"
using f f' \<nu> arr_char src_def eq_src ideD(1) by auto
moreover have "E.Trg (Dom ?\<mu>) = E.Trg (Cod ?\<mu>)"
using f f' \<nu> arr_char trg_def eq_trg ideD(1) by auto
moreover have "\<guillemotleft>Map ?\<mu> : \<lbrace>Dom ?\<mu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<mu>\<rbrace>\<guillemotright>"
proof -
have "\<guillemotleft>\<nu> : \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f'\<rbrace>\<guillemotright>"
using f f' \<nu> ide_char arr_char DN_def Cod_ide Map_ide
by (metis (no_types, lifting) ideD(1))
thus ?thesis by simp
qed
ultimately show ?thesis
using f f' \<nu> ide_char arr_char by blast
qed
show "dom ?\<mu> = f"
using f \<mu> dom_char MkArr_Map MkIde_Dom' by simp
show "cod ?\<mu> = f'"
proof -
have "cod ?\<mu> = MkIde (Dom f')"
using \<mu> cod_char by simp
also have "... = MkArr (Dom f') (Cod f') (Map f')"
using f' by auto
also have "... = f'"
using f' MkArr_Map by simp
finally show ?thesis by simp
qed
qed
moreover have "DN ?\<mu> = \<nu>"
using \<mu> DN_def by auto
ultimately show ?thesis by blast
qed
qed
(* DN is essentially surjective up to equivalence on objects. *)
show "\<And>a'. B.obj a' \<Longrightarrow> \<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
proof -
fix a'
assume a': "B.obj a'"
have "obj (UP.map\<^sub>0 a')"
using a' UP.map\<^sub>0_simps(1) by simp
moreover have "B.equivalent_objects (DN.map\<^sub>0 (UP.map\<^sub>0 a')) a'"
proof -
have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle> \<^bold>\<langle>a'\<^bold>\<rangle> a')"
using a' UP_def [of a'] UP.preserves_reflects_arr [of a'] by auto
moreover have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 a')"
using a' arr_char B.obj_def by auto
ultimately have "DN.map\<^sub>0 (UP.map\<^sub>0 a') = a'"
using a' UP.map\<^sub>0_def UP_def DN.map\<^sub>0_def DN_def src_def UP.map\<^sub>0_simps(1)
by auto
thus ?thesis
using a' B.equivalent_objects_reflexive by simp
qed
ultimately show "\<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
by blast
qed
(* DN is locally essentially surjective. *)
show "\<And>a b g. \<lbrakk> obj a; obj b; \<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>; B.ide g \<rbrakk> \<Longrightarrow>
\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
proof -
fix a b g
assume a: "obj a" and b: "obj b"
and g: "\<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>" and ide_g: "B.ide g"
have "ide (UP g)"
using ide_g UP.preserves_ide by simp
moreover have "B.isomorphic (DN (UP g)) g"
using ide_g DN_UP B.isomorphic_reflexive by simp
moreover have "\<guillemotleft>UP g : a \<rightarrow> b\<guillemotright>"
proof
show "arr (UP g)"
using g UP.preserves_reflects_arr by auto
show "src (UP g) = a"
proof -
have "src (UP g) = MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g)"
using ide_g src_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
also have "... = a"
proof -
have "src\<^sub>B g = src\<^sub>B (DN.map\<^sub>0 a)"
using a g B.in_hhom_def by simp
also have "... = Map a"
using a Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src by auto
finally have "src\<^sub>B g = Map a" by simp
hence "MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g) = MkArr \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 (Map a)"
by simp
also have "... = a"
using a obj_char apply (cases "Dom a", simp_all)
by (metis (no_types, lifting) B.obj_def' a comp_ide_arr dom_char dom_eqI objE)
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
show "trg (UP g) = b"
proof -
have "trg (UP g) = MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g)"
using ide_g trg_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
also have "... = b"
proof -
have "trg\<^sub>B g = trg\<^sub>B (DN.map\<^sub>0 b)"
using b g B.in_hhom_def by simp
also have "... = Map b"
using b Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src by auto
finally have "trg\<^sub>B g = Map b" by simp
hence "MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
by simp
also have "... = b"
using b obj_char apply (cases "Dom b", simp_all)
by (metis (no_types, lifting) B.obj_def' b comp_ide_arr dom_char dom_eqI objE)
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
qed
ultimately show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
by blast
qed
qed
theorem DN_is_equivalence_pseudofunctor:
shows "equivalence_pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>"
..
text \<open>
The following gives an explicit formula for a component of the unit isomorphism of
the pseudofunctor \<open>UP\<close> from a bicategory to its strictification.
It is not currently being used -- I originally proved it in order to establish something
that I later proved in a more abstract setting -- but it might be useful at some point.
\<close>
interpretation L: bicategorical_language V\<^sub>B src\<^sub>B trg\<^sub>B ..
interpretation E: evaluation_map V\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
\<open>\<lambda>\<mu>. if B.arr \<mu> then \<mu> else B.null\<close>
using B.src.is_extensional B.trg.is_extensional
by (unfold_locales, auto)
notation E.eval ("\<lbrace>_\<rbrace>")
interpretation UP: equivalence_pseudofunctor
V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>
using UP_is_equivalence_pseudofunctor by auto
lemma UP_\<Psi>_char:
assumes "B.obj a"
shows "UP.\<Psi> a = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
proof -
have " MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a = UP.\<Psi> a"
proof (intro UP.\<Psi>_eqI)
show "B.obj a"
using assms by simp
have 0: "\<guillemotleft>a : a \<Rightarrow>\<^sub>B a\<guillemotright>"
using assms by auto
have 1: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
apply (unfold arr_char, intro conjI)
using assms by auto
have 2: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> a)"
apply (unfold arr_char, intro conjI)
using assms by auto
have 3: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a)"
apply (unfold arr_char, intro conjI)
using assms by auto
show "\<guillemotleft>MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a : UP.map\<^sub>0 a \<Rightarrow> UP a\<guillemotright>"
proof
show "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)" by fact
show "dom (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP.map\<^sub>0 a"
using assms 1 2 dom_char UP.map\<^sub>0_def UP_def src_def by auto
show "cod (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP a"
using assms 1 2 cod_char UP.map\<^sub>0_def UP_def src_def by auto
qed
show "iso (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
using assms 1 iso_char by auto
show "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) =
(UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
proof -
have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
- proof -
- have "\<i> (UP.map\<^sub>0 a) = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a"
- unfolding \<i>_def UP.map\<^sub>0_def UP_def
- using assms 2 src_def by auto
- moreover have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
- using assms 0 1 2 comp_def by auto
- ultimately show ?thesis by simp
- qed
+ unfolding \<i>_def UP.map\<^sub>0_def UP_def
+ using assms 0 1 2 src_def by auto
also have "... = (UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
proof -
- have "UP \<i>\<^sub>B[a] = MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a]"
- using assms UP_def by simp
- moreover have "\<Phi> (a, a) = MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a)"
- using assms \<Phi>_ide_simp by auto
- ultimately have "UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a) = MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a]"
- using assms comp_def B.comp_arr_dom
- by (elim B.objE, auto)
- moreover have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a =
- MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
+ have "(UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) =
+ (MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a))
+ \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
+ using assms UP_def \<Phi>_ide_simp by auto
+ also have "... = (MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a))
+ \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
+ using assms 0 1 2 3 hcomp_def B.comp_cod_arr src_def trg_def
+ B.can_Ide_self B.canE_unitor [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] B.comp_cod_arr
+ by auto
+ also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> ((\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a)) \<cdot>\<^sub>B B.runit' a)"
proof -
- have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a =
- MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>)
- (B.can (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<cdot>\<^sub>B B.can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
- using assms 0 1 2 3 hcomp_def B.comp_cod_arr src_def trg_def by auto
- moreover have
- "B.can (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<cdot>\<^sub>B B.can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = B.runit' a"
- proof -
- have "B.can (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<cdot>\<^sub>B B.can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 =
- (a \<star>\<^sub>B a) \<cdot>\<^sub>B B.inv (B.runit a)"
- using assms B.can_Ide_self B.canE_unitor [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] by auto
- also have "... = B.runit' a"
- using assms B.comp_cod_arr by auto
- finally show ?thesis by simp
- qed
- ultimately show ?thesis by simp
+ have "MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a) =
+ MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> (\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a))"
+ using assms by (intro comp_MkArr arr_MkArr, auto)
+ moreover have "MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> (\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a))
+ \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a) =
+ MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> ((\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a)) \<cdot>\<^sub>B B.runit' a)"
+ using assms 0 by (intro comp_MkArr arr_MkArr, auto)
+ ultimately show ?thesis by argo
qed
- ultimately have "(UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) =
- MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
- by simp
also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
- using assms comp_def B.unitor_coincidence B.iso_unit B.comp_arr_inv
- B.inv_is_inverse
- by auto
- finally show ?thesis by simp
+ using assms B.comp_arr_dom B.comp_arr_inv' B.iso_unit B.unitor_coincidence(2)
+ by simp
+ finally show ?thesis by argo
qed
finally show ?thesis by simp
qed
qed
thus ?thesis by simp
qed
end
subsection "Pseudofunctors into a Strict Bicategory"
text \<open>
In the special case of a pseudofunctor into a strict bicategory, we can obtain
explicit formulas for the images of the units and associativities under the pseudofunctor,
which only involve the structure maps of the pseudofunctor, since the units and associativities
in the target bicategory are all identities. This is useful in applying strictification.
\<close>
locale pseudofunctor_into_strict_bicategory =
pseudofunctor +
D: strict_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
begin
lemma image_of_unitor:
assumes "C.ide g"
shows "F \<l>\<^sub>C[g] = (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
and "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
and "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)"
and "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
proof -
show A: "F \<l>\<^sub>C[g] = (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
proof -
have 1: "\<guillemotleft>(D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) :
F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
proof
show "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g : F (trg\<^sub>C g) \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F g\<guillemotright>"
using assms \<Psi>_char by (auto simp add: D.hcomp_obj_arr D.hseqI')
show "\<guillemotleft>D.inv (\<Phi> (trg\<^sub>C g, g)) : F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C g) \<star>\<^sub>D F g\<guillemotright>"
using assms \<Phi>_components_are_iso \<Phi>_in_hom(2) D.inv_is_inverse by simp
qed
have "(D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) =
F g \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
using 1 D.comp_cod_arr by auto
also have "... = (F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
(D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
using assms lunit_coherence [of g] D.strict_lunit by simp
also have "... = F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D
((\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
D.inv (\<Phi> (trg\<^sub>C g, g))"
using D.comp_assoc by simp
also have "... = F \<l>\<^sub>C[g]"
proof -
have "(\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) = F (trg\<^sub>C g) \<star>\<^sub>D F g"
using assms \<Psi>_char D.whisker_right
by (metis C.ideD(1) C.obj_trg C.trg.preserves_reflects_arr D.comp_arr_inv'
\<Psi>_simps(5) preserves_arr preserves_ide)
moreover have "\<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) = F (trg\<^sub>C g \<star>\<^sub>C g)"
using assms \<Phi>_components_are_iso D.comp_arr_inv D.inv_is_inverse by simp
ultimately show ?thesis
using assms D.comp_arr_dom D.comp_cod_arr \<Psi>_char \<Phi>_in_hom(2) by auto
qed
finally show ?thesis by simp
qed
show B: "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
proof -
have 1: "\<guillemotleft>(F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) :
F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
proof
show "\<guillemotleft>F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g)) : F g \<star>\<^sub>D F (src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
using assms \<Psi>_char by (auto simp add: D.hcomp_arr_obj D.hseqI')
show "\<guillemotleft>D.inv (\<Phi> (g, src\<^sub>C g)) : F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F (src\<^sub>C g)\<guillemotright>"
using assms \<Phi>_components_are_iso \<Phi>_in_hom(2) D.inv_is_inverse by simp
qed
have "(F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) =
F g \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
using 1 D.comp_cod_arr by auto
also have "... = (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D
(F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
using assms runit_coherence [of g] D.strict_runit by simp
also have "... = F \<r>\<^sub>C[g] \<cdot>\<^sub>D (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D
(F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
using D.comp_assoc by simp
also have "... = F \<r>\<^sub>C[g]"
proof -
have "(F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) = F g \<star>\<^sub>D F (src\<^sub>C g)"
using assms D.whisker_left \<Psi>_char
by (metis C.ideD(1) C.obj_src C.src.preserves_ide D.comp_arr_inv' D.ideD(1)
\<Psi>_simps(5) preserves_ide)
moreover have "\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) = F (g \<star>\<^sub>C src\<^sub>C g)"
using assms \<Phi>_components_are_iso D.comp_arr_inv D.inv_is_inverse by simp
ultimately show ?thesis
using assms D.comp_arr_dom D.comp_cod_arr \<Psi>_char \<Phi>_in_hom(2) [of g "src\<^sub>C g"]
by auto
qed
finally show ?thesis by simp
qed
show "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)"
proof -
have "F (C.lunit' g) = D.inv (F \<l>\<^sub>C[g])"
using assms C.iso_lunit preserves_inv by simp
also have "... = D.inv ((D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)))"
using A by simp
also have "... = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)"
proof -
have "D.iso (D.inv (\<Phi> (trg\<^sub>C g, g))) \<and> D.inv (D.inv (\<Phi> (trg\<^sub>C g, g))) = \<Phi> (trg\<^sub>C g, g)"
using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
moreover have "D.iso (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<and>
D.inv (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) = \<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g"
using assms \<Psi>_char D.iso_inv_iso by simp
moreover have "D.seq (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) (D.inv (\<Phi> (trg\<^sub>C g, g)))"
using assms \<Psi>_char by (metis A C.lunit_simps(1) preserves_arr)
ultimately show ?thesis
using D.inv_comp by simp
qed
finally show ?thesis by simp
qed
show "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
proof -
have "F (C.runit' g) = D.inv (F \<r>\<^sub>C[g])"
using assms C.iso_runit preserves_inv by simp
also have "... = D.inv ((F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)))"
using B by simp
also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
proof -
have "D.iso (D.inv (\<Phi> (g, src\<^sub>C g))) \<and> D.inv (D.inv (\<Phi> (g, src\<^sub>C g))) = \<Phi> (g, src\<^sub>C g)"
using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
moreover have "D.iso (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<and>
D.inv (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) = F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)"
using assms \<Psi>_char D.iso_inv_iso by simp
moreover have "D.seq (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) (D.inv (\<Phi> (g, src\<^sub>C g)))"
using assms \<Psi>_char by (metis B C.runit_simps(1) preserves_arr)
ultimately show ?thesis
using D.inv_comp by simp
qed
finally show ?thesis by simp
qed
qed
lemma image_of_associator:
assumes "C.ide f" and "C.ide g" and "C.ide h" and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C h"
shows "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
and "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
proof -
show 1: "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
proof -
have 2: "D.seq (\<Phi> (f, g \<star>\<^sub>C h)) ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
proof (intro D.seqI)
show "D.arr \<a>\<^sub>D[F f, F g, F h]"
using assms D.assoc_in_hom(2) [of "F f" "F g" "F h"] by auto
show "D.hseq (F f) (\<Phi> (g, h))"
using assms by fastforce
show "D.dom (F f \<star>\<^sub>D \<Phi> (g, h)) = D.cod \<a>\<^sub>D[F f, F g, F h]"
using assms \<open>D.hseq (F f) (\<Phi> (g, h))\<close> by simp
show "D.arr (\<Phi> (f, g \<star>\<^sub>C h))"
using assms by auto
show "D.dom (\<Phi> (f, g \<star>\<^sub>C h)) = D.cod ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
using assms \<open>D.hseq (F f) (\<Phi> (g, h))\<close> by simp
qed
moreover have 3: "F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
using assms assoc_coherence [of f g h] by blast
moreover have "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
proof -
have "D.iso (\<Phi> (f \<star>\<^sub>C g, h)) \<and> D.iso (\<Phi> (f, g)) \<and> D.iso (F h)"
using assms \<Phi>_components_are_iso by simp
moreover have "D.seq (\<Phi> (f \<star>\<^sub>C g, h)) (\<Phi> (f, g) \<star>\<^sub>D F h)"
proof (intro D.seqI)
show "D.hseq (\<Phi> (f, g)) (F h)"
using assms C.VV.arr_char D.hseqI' by simp
show "D.arr (\<Phi> (f \<star>\<^sub>C g, h))"
using assms C.VV.arr_char by simp
show "D.dom (\<Phi> (f \<star>\<^sub>C g, h)) = D.cod (\<Phi> (f, g) \<star>\<^sub>D F h)"
using assms 2 3 by (metis D.seqE)
qed
ultimately show ?thesis
using assms D.isos_compose by simp
qed
ultimately have "F \<a>\<^sub>C[f, g, h] =
(\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])) \<cdot>\<^sub>D
D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
using D.invert_side_of_triangle(2)
[of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
"F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
by presburger
also have "... = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
proof -
have "D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)) =
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
proof -
have "D.iso (\<Phi> (f \<star>\<^sub>C g, h))"
using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
moreover have "D.iso (\<Phi> (f, g) \<star>\<^sub>D F h) \<and>
D.inv (\<Phi> (f, g) \<star>\<^sub>D F h) = D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h"
using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
moreover have "D.seq (\<Phi> (f \<star>\<^sub>C g, h)) (\<Phi> (f, g) \<star>\<^sub>D F h)"
using assms by fastforce
ultimately show ?thesis
using D.inv_comp by simp
qed
moreover have "(F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] = (F f \<star>\<^sub>D \<Phi> (g, h))"
using assms D.comp_arr_dom D.assoc_in_hom [of "F f" "F g" "F h"] \<Phi>_in_hom
by (metis "2" "3" D.comp_arr_ide D.hseq_char D.seqE D.strict_assoc
\<Phi>_simps(2) \<Phi>_simps(3) preserves_ide)
ultimately show ?thesis
using D.comp_assoc by simp
qed
finally show ?thesis
by simp
qed
show "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
proof -
have "F (C.\<a>' f g h) = D.inv (F \<a>\<^sub>C[f, g, h])"
using assms preserves_inv by simp
also have "... = D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
(D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
using 1 by simp
also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
using assms \<Phi>_components_are_iso C.VV.arr_char D.iso_inv_iso FF_def D.hcomp_assoc
D.comp_assoc
(* OK, this is pretty cool, but not as cool as if I didn't have to direct it. *)
by (simp add: D.inv_comp D.isos_compose D.hseqI')
finally show ?thesis by simp
qed
qed
end
subsection "Internal Equivalences in a Strict Bicategory"
text \<open>
In this section we prove a useful fact about internal equivalences in a strict bicategory:
namely, that if the ``right'' triangle identity holds for such an equivalence then the
``left'' does, as well. Later we will dualize this property, and use strictification to
extend it to arbitrary bicategories.
\<close>
locale equivalence_in_strict_bicategory =
strict_bicategory +
equivalence_in_bicategory
begin
lemma triangle_right_implies_left:
shows "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g \<Longrightarrow> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
proof -
text \<open>
The formal proof here was constructed following the string diagram sketch below,
which appears in \cite{nlab-zigzag-diagram}
(see it also in context in \cite{nlab-adjoint-equivalence}).
The diagram is reproduced here by permission of its author, Mike Shulman,
who says (private communication):
``Just don't give the impression that the proof itself is due to me, because it's not.
I don't know who first gave that proof; it's probably folklore.''
\begin{figure}[h]
\includegraphics[width=6.5in]{triangle_right_implies_left.png}
\end{figure}
\<close>
assume 1: "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
have 2: "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = g"
proof -
have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = inv ((g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g))"
using antipar unit_is_iso counit_is_iso inv_comp hcomp_assoc hseqI'
by simp
also have "... = g"
using 1 by simp
finally show ?thesis by blast
qed
have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>)"
proof -
have "(f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) = f \<star> \<eta>"
using 2 ide_left ide_right antipar whisker_left
by (metis comp_cod_arr unit_simps(1) unit_simps(3))
thus ?thesis by simp
qed
also have "... = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) \<star> (inv \<eta> \<cdot> \<eta>)"
proof -
have "inv \<eta> \<cdot> \<eta> = src f"
by (simp add: comp_inv_arr')
thus ?thesis
by (metis antipar(1) antipar(2) arrI calculation
comp_ide_arr hcomp_arr_obj ideD(1) ide_left ide_right obj_src seqE
strict_assoc' triangle_in_hom(1) vconn_implies_hpar(1))
qed
also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> ((f \<star> inv \<eta>) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
using ide_left ide_right antipar unit_is_iso
by (metis "2" arr_inv calculation comp_arr_dom comp_inv_arr' counit_simps(1)
counit_simps(2) dom_inv hcomp_arr_obj ideD(1) unit_simps(1) unit_simps(2)
unit_simps(5) obj_trg seqI whisker_left)
also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star>
((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
proof -
have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (f \<star> g) \<star> f"
using whisker_right [of f "inv \<epsilon>" \<epsilon>] counit_in_hom
by (simp add: antipar(1) comp_inv_arr')
thus ?thesis
using hcomp_assoc comp_arr_dom
by (metis comp_cod_arr ide_left local.unit_simps(1) local.unit_simps(3)
whisker_left)
qed
also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<cdot> (f \<star> g)) \<star>
(((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
(f \<star> \<eta>)"
using ide_left ide_right antipar counit_is_iso comp_assoc whisker_right comp_cod_arr
by (metis "2" comp_arr_dom counit_simps(1) counit_simps(2))
also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
(f \<star> \<eta>)"
proof -
have 3: "seq (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) (f \<star> g)"
using 2 antipar counit_is_iso by auto
moreover have 4: "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) ((\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))"
using antipar unit_is_iso counit_is_iso hseqI' hcomp_assoc by auto
ultimately show ?thesis
using interchange by simp
qed
also have "... = ((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>)"
- using comp_assoc by simp
+ using comp_assoc by presburger
also have "... = ((\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)) \<cdot>
(f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
proof -
have "(\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) =
(\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)"
proof -
have "seq \<epsilon> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))"
using antipar by (simp add: "2")
moreover have "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) f"
using antipar unit_is_iso counit_is_iso hcomp_assoc hcomp_obj_arr hseqI' by auto
ultimately show ?thesis
using antipar counit_is_iso comp_assoc comp_arr_dom hcomp_obj_arr hseqI'
interchange [of \<epsilon> "f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)" "(f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)" f]
by simp
qed
moreover have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
(f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
proof -
have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
(f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) \<cdot> (f \<star> \<eta> \<star> src f)"
using antipar comp_assoc hcomp_assoc whisker_left hcomp_arr_obj hseqI' by simp
also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> ((g \<star> f) \<star> \<eta>) \<cdot> (\<eta> \<cdot> src f))"
using antipar comp_arr_dom whisker_left hcomp_arr_obj hseqI' by simp
also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> \<eta>)"
using antipar comp_arr_dom comp_cod_arr hcomp_arr_obj
interchange [of "g \<star> f" \<eta> \<eta> "src f"]
by simp
also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f) \<cdot> (f \<star> src f \<star> \<eta>)"
using antipar comp_arr_dom comp_cod_arr whisker_left hseqI'
interchange [of \<eta> "src f" "g \<star> f" \<eta>]
by simp
also have "... = ((f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f)) \<cdot> (f \<star> \<eta>)"
using antipar comp_assoc by (simp add: hcomp_obj_arr)
also have "... = (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
using antipar comp_assoc whisker_left whisker_right hcomp_assoc hseqI' by simp
finally show ?thesis by blast
qed
ultimately show ?thesis by simp
qed
also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot>
(f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot> (f \<star> \<eta>)"
using comp_assoc hcomp_assoc antipar(1) antipar(2) by auto
also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot>
(f \<star> \<eta>)"
using ide_left ide_right antipar comp_cod_arr comp_assoc whisker_left
by (metis "1" "2" comp_ide_self unit_simps(1) unit_simps(3))
also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
proof -
have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
using ide_left ide_right antipar comp_arr_dom comp_assoc
by (metis "1" "2" comp_ide_self)
thus ?thesis
using antipar comp_cod_arr hseqI' by simp
qed
also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
proof -
have "(\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
(trg f \<cdot> \<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
using hcomp_obj_arr comp_cod_arr by simp
also have "... = ((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
proof -
have "seq (f \<star> inv \<eta>) (inv \<epsilon> \<star> f)"
using antipar unit_is_iso counit_is_iso hseqI' hcomp_arr_obj hcomp_assoc by auto
thus ?thesis
using unit_is_iso counit_is_iso counit_in_hom interchange by auto
qed
also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
proof -
have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (trg f \<star> inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> trg f \<star> f)"
using counit_is_iso hseqI' by (simp add: hcomp_obj_arr)
also have "... = \<epsilon> \<star> inv \<epsilon> \<star> f"
using antipar counit_is_iso hseqI' comp_arr_dom comp_cod_arr
interchange [of "trg f" \<epsilon> "inv \<epsilon> \<star> f" "trg f \<star> f"]
by force
finally have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = \<epsilon> \<star> inv \<epsilon> \<star> f" by simp
moreover have "trg f \<star> f \<star> inv \<eta> = f \<star> inv \<eta>"
using unit_is_iso hcomp_obj_arr [of "trg f" "f \<star> inv \<eta>"] hseqI'
by (simp add: antipar(1) hseq_char')
ultimately have "((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f))) \<cdot> (f \<star> \<eta>)"
by simp
thus ?thesis
using comp_assoc by simp
qed
finally show ?thesis by simp
qed
also have "... = f \<star> inv \<eta> \<cdot> \<eta>"
proof -
have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = f \<star> g \<star> f"
using ide_left ide_right antipar counit_is_iso whisker_right hcomp_assoc
by (metis comp_arr_dom comp_inv_arr' counit_simps(1) counit_simps(2) seqE)
thus ?thesis
using ide_left ide_right antipar unit_is_iso comp_cod_arr
by (metis arr_inv dom_inv unit_simps(1) unit_simps(3) seqI whisker_left)
qed
also have "... = f \<star> src f"
using antipar unit_is_iso by (simp add: comp_inv_arr')
also have "... = f"
using hcomp_arr_obj by simp
finally show ?thesis by simp
qed
end
text \<open>
Now we use strictification to generalize the preceding result to arbitrary bicategories.
I originally attempted to generalize this proof directly from the strict case, by filling
in the necessary canonical isomorphisms, but it turned out to be too daunting.
The proof using strictification is still fairly tedious, but it is manageable.
\<close>
context equivalence_in_bicategory
begin
interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
notation S.hcomp (infixr "\<star>\<^sub>S" 53)
notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
using S.UP_is_equivalence_pseudofunctor by auto
interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
..
interpretation E: equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
\<open>S.UP f\<close> \<open>S.UP g\<close>
\<open>S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f)\<close>
\<open>S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)\<close>
using equivalence_in_bicategory_axioms UP.preserves_equivalence [of f g \<eta> \<epsilon>] by auto
interpretation E: equivalence_in_strict_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
\<open>S.UP f\<close> \<open>S.UP g\<close>
\<open>S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f)\<close>
\<open>S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)\<close>
..
lemma UP_triangle:
shows "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
and "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
(S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))) \<cdot>\<^sub>S
(S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
and "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
and "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
(S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
(S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
show T1: "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
proof -
have "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.UP \<a>[g, f, g] \<cdot>\<^sub>S S.UP (\<eta> \<star> g)"
using antipar assoc_in_hom unit_in_hom counit_in_hom hseqI' by simp
also have "... = (S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S ((S.inv (S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S
S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
(((S.inv (S.\<Phi> (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g \<star> f, g)))) \<cdot>\<^sub>S
S.\<Phi> (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
proof -
have "S.UP \<a>[g, f, g] =
S.\<Phi> (g, f \<star> g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
S.inv (S.\<Phi> (g \<star> f, g))"
using ide_left ide_right antipar UP.image_of_associator [of g f g] by simp
moreover have
"S.UP (g \<star> \<epsilon>) = S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S S.inv (S.\<Phi> (g, f \<star> g))"
proof -
have "S.seq (S.\<Phi> (g, src g)) (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
using antipar UP.FF_def S.hseqI' UP.\<Phi>_in_hom [of g "src g"]
apply (intro S.seqI) by auto
moreover have
"S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.\<Phi> (g, f \<star> g) = S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
using antipar UP.\<Phi>.naturality [of "(g, \<epsilon>)"] UP.FF_def VV.arr_char by simp
moreover have "S.iso (S.\<Phi> (g, f \<star> g))"
using antipar UP.\<Phi>_components_are_iso by simp
ultimately show ?thesis
using antipar S.comp_assoc
S.invert_side_of_triangle(2)
[of "S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)" "S.UP (g \<star> \<epsilon>)" "S.\<Phi> (g, f \<star> g)"]
by simp
qed
moreover have "S.UP (\<eta> \<star> g) =
(S.\<Phi> (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
proof -
have "S.UP (\<eta> \<star> g) \<cdot>\<^sub>S S.\<Phi> (trg g, g) = S.\<Phi> (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)"
using antipar UP.\<Phi>.naturality [of "(\<eta>, g)"] UP.FF_def VV.arr_char by simp
moreover have "S.seq (S.\<Phi> (g \<star> f, g)) (S.UP \<eta> \<star>\<^sub>S S.UP g)"
using antipar UP.\<Phi>_in_hom(2) S.hseqI' by (intro S.seqI, auto)
ultimately show ?thesis
using antipar S.invert_side_of_triangle(2) by simp
qed
ultimately show ?thesis
using S.comp_assoc by simp
qed
also have "... = S.\<Phi> (g, src g) \<cdot>\<^sub>S
((S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
((S.inv (S.\<Phi> (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
S.inv (S.\<Phi> (trg g, g))"
proof -
have "(S.inv (S.\<Phi> (g \<star> f, g)) \<cdot>\<^sub>S S.\<Phi> (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g) =
(S.UP \<eta> \<star>\<^sub>S S.UP g)"
using antipar S.comp_inv_arr' UP.\<Phi>_in_hom S.comp_cod_arr S.hseqI' by auto
moreover have "(S.inv (S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g)) =
(S.UP g \<star>\<^sub>S S.\<Phi> (f, g))"
proof -
have "S.inv (S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S S.\<Phi> (g, f \<star> g) = S.UP g \<star>\<^sub>S S.UP (f \<star> g)"
using antipar S.comp_inv_arr' UP.\<Phi>_in_hom by auto
thus ?thesis
using antipar VV.arr_char S.comp_cod_arr S.hseqI' UP.\<Phi>_in_hom by simp
qed
ultimately show ?thesis
using S.comp_assoc by simp
qed
also have "... = S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
using antipar VV.arr_char S.whisker_left S.whisker_right by auto
finally show ?thesis by simp
qed
show T2: "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
(S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))) \<cdot>\<^sub>S
(S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
using UP.image_of_unitor by simp
show "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.UP \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>S S.UP (f \<star> \<eta>)"
using antipar hseqI' by simp
also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.inv (S.\<Phi> (f \<star> g, f)) \<cdot>\<^sub>S
S.\<Phi> (f \<star> g, f) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.inv (S.\<Phi> (f, g \<star> f)) \<cdot>\<^sub>S
S.\<Phi> (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
have "S.UP \<a>\<^sup>-\<^sup>1[f, g, f] =
S.\<Phi> (f \<star> g, f) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S
S.inv (S.\<Phi> (f, g \<star> f))"
using ide_left ide_right antipar UP.image_of_associator by simp
moreover have "S.UP (\<epsilon> \<star> f) =
S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.inv (S.\<Phi> (f \<star> g, f))"
proof -
have "S.seq (S.\<Phi> (trg f, f)) (S.UP \<epsilon> \<star>\<^sub>S S.UP f)"
using antipar UP.FF_def VV.ide_char VV.arr_char UP.\<Phi>_in_hom [of "trg f" f] S.hseqI'
apply (intro S.seqI) by auto
moreover have
"S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) = S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.\<Phi> (f \<star> g, f)"
using antipar UP.\<Phi>.naturality [of "(\<epsilon>, f)"] UP.FF_def VV.arr_char by simp
moreover have "S.iso (S.\<Phi> (f \<star> g, f))"
using antipar UP.\<Phi>_components_are_iso by simp
ultimately show ?thesis
using antipar S.comp_assoc
S.invert_side_of_triangle(2)
[of "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f)" "S.UP (\<epsilon> \<star> f)" "S.\<Phi> (f \<star> g, f)"]
by metis
qed
moreover have "S.UP (f \<star> \<eta>) =
(S.\<Phi> (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
have "S.\<Phi> (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) = S.UP (f \<star> \<eta>) \<cdot>\<^sub>S S.\<Phi> (f, src f)"
using antipar UP.\<Phi>.naturality [of "(f, \<eta>)"] UP.FF_def VV.arr_char by simp
moreover have "S.seq (S.\<Phi> (f, g \<star> f)) (S.UP f \<star>\<^sub>S S.UP \<eta>)"
using antipar S.hseqI' by (intro S.seqI, auto)
ultimately show ?thesis
using antipar S.invert_side_of_triangle(2) by auto
qed
ultimately show ?thesis
using S.comp_assoc by simp
qed
also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S
((S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
((S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
S.inv (S.\<Phi> (f, src f))"
proof -
have "(S.inv (S.\<Phi> (f \<star> g, f)) \<cdot>\<^sub>S S.\<Phi> (f \<star> g, f)) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) =
(S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)"
using antipar S.comp_cod_arr VV.arr_char S.hseqI' S.comp_inv_arr' by auto
moreover have "(S.inv (S.\<Phi> (f, g \<star> f)) \<cdot>\<^sub>S S.\<Phi> (f, g \<star> f)) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
(S.UP f \<star>\<^sub>S S.UP \<eta>)"
using antipar S.comp_inv_arr' S.comp_cod_arr S.hseqI' by auto
ultimately show ?thesis
using S.comp_assoc by simp
qed
also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
using antipar VV.arr_char S.whisker_left S.whisker_right by auto
finally show ?thesis by simp
qed
show "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
(S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
using UP.image_of_unitor by simp
show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
(S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
assume A: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
have B: "(S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
proof -
show "(S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
proof -
have 2: "S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g)) =
(S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))) \<cdot>\<^sub>S
(S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
using A T1 T2 by simp
show ?thesis
proof -
have 8: "S.seq (S.\<Phi> (g, src g))
((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
S.inv (S.\<Phi> (trg g, g)))"
using antipar VV.arr_char S.hseqI' S.hcomp_assoc
apply (intro S.seqI) by auto
have 7: "S.seq (S.\<Phi> (g, src g))
((S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
S.inv (S.\<Phi> (trg g, g)))"
using antipar 2 8 S.comp_assoc by auto
have 5: "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
(S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g)"
proof -
have "((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S
S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g)) =
((S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
S.inv (S.\<Phi> (trg g, g))"
proof -
have "S.mono (S.\<Phi> (g, src g))"
using antipar S.iso_is_section S.section_is_mono by simp
thus ?thesis
using 2 8 7 S.monoE S.comp_assoc by presburger
qed
moreover have "S.epi (S.inv (S.\<Phi> (trg g, g)))"
using antipar S.iso_is_retraction S.retraction_is_epi
UP.\<Phi>_components_are_iso S.iso_inv_iso
by simp
moreover have "S.seq ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S
S.UP \<eta> \<star>\<^sub>S S.UP g))
(S.inv (S.\<Phi> (trg g, g)))"
using S.comp_assoc S.seq_char 8 by presburger
moreover have
"S.seq ((S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g))
(S.inv (S.\<Phi> (trg g, g)))"
using antipar calculation(1) calculation(3) by presburger
ultimately show ?thesis
using 2 S.epiE by blast
qed
have 6: "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
using antipar VV.arr_char S.hseqI' S.hcomp_assoc by auto
have 3: "(S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
(S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g)"
proof -
have "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
using 6 by simp
moreover have "(S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) =
(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
using 5 by argo
moreover have "S.iso (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))"
using antipar UP.\<Psi>_char S.UP_map\<^sub>0_obj by simp
moreover have "S.inv (S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) =
S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))"
using antipar UP.\<Psi>_char S.UP_map\<^sub>0_obj by simp
ultimately show ?thesis
using S.invert_side_of_triangle(1)
[of "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
(S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
"S.UP g \<star>\<^sub>S UP.\<Psi> (src g)" "S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g"]
by presburger
qed
have 4: "(((S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S
(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
((S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g))
= S.UP g"
proof -
have "(((S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
((S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g)) =
(((S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
((S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g))) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g)"
using S.comp_assoc by simp
also have "... = (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g)"
using 3 S.comp_assoc by auto
also have "... = S.inv (UP.\<Psi> (trg g)) \<cdot>\<^sub>S UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g"
using UP.\<Psi>_char(2) S.whisker_right by auto
also have "... = UP.map\<^sub>0 (trg g) \<star>\<^sub>S S.UP g"
using UP.\<Psi>_char [of "trg g"] S.comp_inv_arr S.inv_is_inverse by simp
also have "... = S.UP g"
using S.UP_map\<^sub>0_obj by (simp add: S.hcomp_obj_arr)
finally show ?thesis by blast
qed
thus ?thesis
using antipar S.whisker_left S.whisker_right UP.\<Psi>_char S.comp_assoc by simp
qed
qed
qed
show "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
(S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
proof -
have "(S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
(UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
proof -
have 2: "(S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) =
S.UP f"
proof -
have "S.UP f = (S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f))"
using B antipar E.triangle_right_implies_left by argo
also have "... = (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
proof -
have "S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f =
(S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)"
using UP.\<Phi>_components_are_iso UP.\<Psi>_char S.whisker_right by simp
moreover have "S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f) =
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
using antipar UP.\<Phi>_components_are_iso UP.\<Psi>_char S.whisker_left S.comp_assoc
by simp
ultimately show ?thesis
using S.comp_assoc by presburger
qed
finally show ?thesis by argo
qed
show ?thesis
proof -
have "((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) =
(UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)"
proof -
have "S.inv (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.UP f = UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f"
using UP.\<Psi>_char S.iso_inv_iso S.comp_arr_dom S.UP_map\<^sub>0_obj
by (simp add: S.hcomp_obj_arr S.hseqI')
moreover have "S.arr (S.UP f)"
by simp
moreover have "S.iso (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f)"
using UP.\<Phi>_components_are_iso S.iso_inv_iso S.UP_map\<^sub>0_obj
by (simp add: UP.\<Psi>_char(2))
ultimately show ?thesis
using 2 S.invert_side_of_triangle(1)
[of "S.UP f" "S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f"
"((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"]
by presburger
qed
moreover have "S.hseq (UP.\<Psi> (trg f)) (S.UP f) \<and>
S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) \<and>
S.inv (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))"
using UP.\<Psi>_char S.hseqI' S.UP_map\<^sub>0_obj by simp
ultimately show ?thesis
using S.invert_side_of_triangle(2)
[of "UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f"
"(S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
"S.UP f \<star>\<^sub>S UP.\<Psi> (src f)"]
by presburger
qed
qed
hence "S.\<Phi> (trg f, f) \<cdot>\<^sub>S ((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
S.\<Phi> (trg f, f) \<cdot>\<^sub>S ((UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
by simp
thus ?thesis
using S.comp_assoc by simp
qed
qed
qed
lemma triangle_right_implies_left:
assumes "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
proof -
have "par ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
using antipar hseqI' by simp
moreover have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
using assms UP_triangle(3-5) by simp
ultimately show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
using UP.is_faithful by blast
qed
text \<open>
We \emph{really} don't want to go through the ordeal of proving a dual version of
\<open>UP_triangle(5)\<close>, do we? So let's be smart and dualize via the opposite bicategory.
\<close>
lemma triangle_left_implies_right:
assumes "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
shows "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
proof -
interpret Cop: op_bicategory V H \<a> \<i> src trg ..
interpret Eop: equivalence_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f \<eta> \<epsilon>
using antipar unit_is_iso counit_is_iso unit_in_hom counit_in_hom iso_inv_iso
by (unfold_locales, simp_all)
have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<Longrightarrow>
(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
using antipar Cop.lunit_ide_simp Cop.runit_ide_simp Cop.assoc_ide_simp
VVV.ide_char VVV.arr_char VV.arr_char Eop.triangle_right_implies_left
by simp
thus ?thesis
using assms by simp
qed
lemma triangle_left_iff_right:
shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
using triangle_left_implies_right triangle_right_implies_left by auto
end
text \<open>
We might as well specialize the dual result back to the strict case while we are at it.
\<close>
context equivalence_in_strict_bicategory
begin
lemma triangle_left_iff_right:
shows "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
proof -
have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
proof -
have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = f"
using strict_lunit strict_runit by simp
moreover have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)"
using antipar strict_assoc assoc'_in_hom(2) [of f g f] comp_cod_arr hseqI'
by auto
ultimately show ?thesis by simp
qed
also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
using triangle_left_iff_right by blast
also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
proof -
have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = g"
using strict_lunit strict_runit by simp
moreover have "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g)"
using antipar strict_assoc assoc_in_hom(2) [of g f g] comp_cod_arr hseqI'
by auto
ultimately show ?thesis by simp
qed
finally show ?thesis by simp
qed
end
end
diff --git a/thys/Bicategory/Subbicategory.thy b/thys/Bicategory/Subbicategory.thy
--- a/thys/Bicategory/Subbicategory.thy
+++ b/thys/Bicategory/Subbicategory.thy
@@ -1,1357 +1,1363 @@
(* Title: Subbicategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Sub-Bicategories"
text \<open>
In this section we give a construction of a sub-bicategory in terms of a predicate
on the arrows of an ambient bicategory that has certain closure properties with respect
to that bicategory. While the construction given here is likely to be of general use,
it is not the most general sub-bicategory construction that one could imagine,
because it requires that the sub-bicategory actually contain the unit and associativity
isomorphisms of the ambient bicategory. Our main motivation for including this construction
here is to apply it to exploit the fact that the sub-bicategory of endo-arrows of a fixed
object is a monoidal category, which will enable us to transfer to bicategories a result
about unit isomorphisms in monoidal categories.
\<close>
theory Subbicategory
imports Bicategory
begin
subsection "Construction"
locale subbicategory =
B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
subcategory V Arr
for V :: "'a comp" (infixr "\<cdot>\<^sub>B" 55)
and H :: "'a comp" (infixr "\<star>\<^sub>B" 55)
and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src\<^sub>B :: "'a \<Rightarrow> 'a"
and trg\<^sub>B :: "'a \<Rightarrow> 'a"
and Arr :: "'a \<Rightarrow> bool" +
assumes src_closed: "Arr f \<Longrightarrow> Arr (src\<^sub>B f)"
and trg_closed: "Arr f \<Longrightarrow> Arr (trg\<^sub>B f)"
and hcomp_closed: "\<lbrakk> Arr f; Arr g; trg\<^sub>B f = src\<^sub>B g \<rbrakk> \<Longrightarrow> Arr (g \<star>\<^sub>B f)"
and assoc_closed: "\<lbrakk> Arr f \<and> B.ide f; Arr g \<and> B.ide g; Arr h \<and> B.ide h;
src\<^sub>B f = trg\<^sub>B g; src\<^sub>B g = trg\<^sub>B h \<rbrakk> \<Longrightarrow> Arr (\<a>\<^sub>B f g h)"
and assoc'_closed: "\<lbrakk> Arr f \<and> B.ide f; Arr g \<and> B.ide g; Arr h \<and> B.ide h;
src\<^sub>B f = trg\<^sub>B g; src\<^sub>B g = trg\<^sub>B h \<rbrakk> \<Longrightarrow> Arr (B.inv (\<a>\<^sub>B f g h))"
and lunit_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.\<ll> f)"
and lunit'_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.inv (B.\<ll> f))"
and runit_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.\<rr> f)"
and runit'_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.inv (B.\<rr> f))"
begin
notation B.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
notation comp (infixr "\<cdot>" 55)
definition hcomp (infixr "\<star>" 53)
where "g \<star> f = (if Arr f \<and> Arr g \<and> trg\<^sub>B f = src\<^sub>B g then g \<star>\<^sub>B f else null)"
definition src
where "src \<mu> = (if Arr \<mu> then src\<^sub>B \<mu> else null)"
definition trg
where "trg \<mu> = (if Arr \<mu> then trg\<^sub>B \<mu> else null)"
interpretation src: endofunctor \<open>(\<cdot>)\<close> src
using src_def null_char inclusion arr_char src_closed trg_closed dom_closed cod_closed
apply unfold_locales
apply auto[4]
by (metis B.src.preserves_comp_2 comp_char seq_char)
interpretation trg: endofunctor \<open>(\<cdot>)\<close> trg
using trg_def null_char inclusion arr_char src_closed trg_closed dom_closed cod_closed
apply unfold_locales
apply auto[4]
by (metis B.trg.preserves_comp_2 comp_char seq_char)
interpretation horizontal_homs \<open>(\<cdot>)\<close> src trg
using src_def trg_def src.preserves_arr trg.preserves_arr null_char ide_char arr_char
inclusion
by (unfold_locales, simp_all)
interpretation VxV: product_category \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> ..
interpretation VV: subcategory VxV.comp
\<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
using subcategory_VV by auto
interpretation "functor" VV.comp \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
using hcomp_def VV.arr_char src_def trg_def arr_char hcomp_closed dom_char cod_char
VV.dom_char VV.cod_char
apply unfold_locales
apply auto[2]
proof -
fix f
assume f: "VV.arr f"
show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
proof -
have "dom (fst f \<star> snd f) = B.dom (fst f) \<star>\<^sub>B B.dom (snd f)"
proof -
have "dom (fst f \<star> snd f) = B.dom (fst f \<star> snd f)"
using f dom_char
by (simp add: arrI hcomp_closed hcomp_def)
also have "... = B.dom (fst f) \<star>\<^sub>B B.dom (snd f)"
using f
by (metis (no_types, lifting) B.hcomp_simps(3) B.hseqI' VV.arrE arrE hcomp_def
inclusion src_def trg_def)
finally show ?thesis by blast
qed
also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
using f VV.arr_char VV.dom_char arr_char hcomp_def B.seq_if_composable dom_closed
by (simp, metis)
finally show ?thesis by simp
qed
show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
proof -
have "cod (fst f \<star> snd f) = B.cod (fst f) \<star>\<^sub>B B.cod (snd f)"
using f VV.arr_char arr_char cod_char hcomp_def src_def trg_def
src_closed trg_closed hcomp_closed inclusion B.hseq_char arrE
by auto
also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
using f VV.arr_char VV.cod_char arr_char hcomp_def B.seq_if_composable cod_closed
by (simp, metis)
finally show ?thesis by simp
qed
next
fix f g
assume fg: "VV.seq g f"
show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
proof -
have "fst (VV.comp g f) \<star> snd (VV.comp g f) = fst g \<cdot> fst f \<star> snd g \<cdot> snd f"
using fg VV.seq_char VV.comp_char VxV.comp_char VxV.not_Arr_Null
by (metis (no_types, lifting) VxV.seqE prod.sel(1) prod.sel(2))
also have "... = (fst g \<cdot>\<^sub>B fst f) \<star>\<^sub>B (snd g \<cdot>\<^sub>B snd f)"
using fg comp_char hcomp_def VV.seq_char inclusion arr_char seq_char B.hseq_char
by (metis (no_types, lifting) B.hseq_char' VxV.seq_char null_char)
also have 1: "... = (fst g \<star>\<^sub>B snd g) \<cdot>\<^sub>B (fst f \<star>\<^sub>B snd f)"
proof -
have "src\<^sub>B (fst g) = trg\<^sub>B (snd g)"
by (metis (no_types, lifting) VV.arrE VV.seq_char arr_char fg src_def trg_def)
thus ?thesis
using fg VV.seq_char VV.arr_char arr_char seq_char inclusion B.interchange
by (meson VxV.seqE)
qed
also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
using fg comp_char hcomp_def VV.seq_char VV.arr_char arr_char seq_char inclusion
B.hseq_char' hcomp_closed src_def trg_def
by (metis (no_types, lifting) 1)
finally show ?thesis by auto
qed
qed
interpretation horizontal_composition \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> src trg
using arr_char src_def trg_def src_closed trg_closed
apply (unfold_locales)
using hcomp_def inclusion not_arr_null by auto
interpretation VxVxV: product_category \<open>(\<cdot>)\<close> VxV.comp ..
interpretation VVV: subcategory VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
using subcategory_VVV by auto
interpretation HoHV: "functor" VVV.comp \<open>(\<cdot>)\<close> HoHV
using functor_HoHV by auto
interpretation HoVH: "functor" VVV.comp \<open>(\<cdot>)\<close> HoVH
using functor_HoVH by auto
abbreviation \<a>
where "\<a> \<mu> \<nu> \<tau> \<equiv> if VVV.arr (\<mu>, \<nu>, \<tau>) then \<a>\<^sub>B \<mu> \<nu> \<tau> else null"
abbreviation (input) \<alpha>\<^sub>S\<^sub>B
where "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> \<equiv> \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
lemma assoc_closed':
assumes "VVV.arr \<mu>\<nu>\<tau>"
shows "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>)"
proof -
have 1: "B.VVV.arr \<mu>\<nu>\<tau>"
using assms VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char arr_char
src_def trg_def inclusion
by auto
show "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>)"
proof -
- have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> =
- (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B \<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>)"
+ have "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) =
+ Arr ((fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B \<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>))"
using assms B.\<alpha>_def 1 B.VVV.arr_char B.VV.arr_char B.VVV.dom_char B.VV.dom_char
B.assoc_is_natural_1 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
VV.arr_char VVV.arr_char arr_dom src_dom trg_dom
by auto
- moreover have "Arr (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))"
- using assms 1 B.VVV.arr_char B.VV.arr_char hcomp_closed
- by (metis (no_types, lifting) B.H.preserves_arr B.hcomp_simps(2)
- VV.arr_char VVV.arrE arrE)
- moreover have "Arr (\<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>))"
- proof -
- have "\<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>) =
- \<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>))) (B.dom (snd (snd \<mu>\<nu>\<tau>)))"
- using assms 1 B.\<alpha>_def B.VVV.dom_char B.VV.dom_char VVV.arr_char VV.arr_char
- B.VxVxV.dom_char inclusion
+ also have "..."
+ proof (intro comp_closed)
+ show "Arr (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))"
+ using assms 1 B.VVV.arr_char B.VV.arr_char hcomp_closed
+ by (metis (no_types, lifting) B.H.preserves_arr B.hcomp_simps(2)
+ VV.arr_char VVV.arrE arrE)
+ show "B.cod (\<a> (fst (B.VVV.dom \<mu>\<nu>\<tau>)) (fst (snd (B.VVV.dom \<mu>\<nu>\<tau>)))
+ (snd (snd (B.VVV.dom \<mu>\<nu>\<tau>)))) =
+ B.dom (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))"
+ using assms 1 VVV.arr_char VV.arr_char B.VxVxV.dom_char
apply simp
- by (metis (no_types, lifting) B.hseqE arr_dom calculation(2) dom_char src_dom trg_dom)
- moreover have "Arr (\<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>)))
- (B.dom (snd (snd \<mu>\<nu>\<tau>))))"
+ by (metis (no_types, lifting) B.VV.arr_char B.VVV.arrE B.\<alpha>.preserves_reflects_arr
+ B.assoc_is_natural_1 B.seqE arr_dom dom_char src_dom trg_dom)
+ show "Arr (\<a> (fst (B.VVV.dom \<mu>\<nu>\<tau>)) (fst (snd (B.VVV.dom \<mu>\<nu>\<tau>)))
+ (snd (snd (B.VVV.dom \<mu>\<nu>\<tau>))))"
proof -
- have "B.VVV.ide (B.VVV.dom \<mu>\<nu>\<tau>)"
- using 1 B.VVV.ide_dom by blast
- thus ?thesis
- using assms B.\<alpha>_def B.VVV.arr_char B.VV.arr_char B.VVV.ide_char B.VV.ide_char
- dom_closed assoc_closed
- by (metis (no_types, lifting) "1" B.ide_dom B.src_dom B.trg_dom VV.arr_char VVV.arrE
- arr_char)
+ have "VVV.arr (B.VVV.dom \<mu>\<nu>\<tau>)"
+ using 1 B.VVV.dom_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
+ apply simp
+ by (metis (no_types, lifting) VVV.arrE arr_dom assms dom_simp src_dom trg_dom)
+ moreover have "Arr (\<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>)))
+ (B.dom (snd (snd \<mu>\<nu>\<tau>))))"
+ proof -
+ have "B.VVV.ide (B.VVV.dom \<mu>\<nu>\<tau>)"
+ using 1 B.VVV.ide_dom by blast
+ thus ?thesis
+ using assms B.\<alpha>_def B.VVV.arr_char B.VV.arr_char B.VVV.ide_char B.VV.ide_char
+ dom_closed assoc_closed
+ by (metis (no_types, lifting) "1" B.ide_dom B.src_dom B.trg_dom VV.arr_char
+ VVV.arrE arr_char)
+ qed
+ ultimately show ?thesis
+ using 1 B.VVV.ide_dom assoc_closed B.VVV.dom_char
+ apply simp
+ by (metis (no_types, lifting) B.VV.arr_char B.VVV.arrE B.VVV.inclusion
+ B.VxV.dom_char B.VxVxV.arrE B.VxVxV.dom_char prod.sel(1) prod.sel(2))
qed
- ultimately show ?thesis by argo
qed
- moreover have "B.seq (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))
- (\<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>))"
- using assms 1 VVV.arr_char VV.arr_char B.VxVxV.dom_char
- apply simp
- by (metis (no_types, lifting) B.VV.arrE B.VVV.arrE B.assoc_is_natural_1
- B.\<alpha>.preserves_reflects_arr arr_dom dom_simp src_dom trg_dom)
- ultimately show ?thesis
- using comp_closed by auto
+ finally show ?thesis by blast
qed
qed
lemma lunit_closed':
assumes "Arr f"
shows "Arr (B.\<ll> f)"
proof -
have 1: "arr f \<and> arr (B.\<ll> (B.dom f))"
using assms arr_char lunit_closed dom_closed B.ide_dom inclusion by simp
moreover have "B.dom f = B.cod (B.\<ll> (B.dom f))"
using 1 arr_char B.\<ll>.preserves_cod inclusion by simp
moreover have "B.\<ll> f = f \<cdot> B.\<ll> (B.dom f)"
using assms 1 B.\<ll>.is_natural_1 inclusion comp_char arr_char by simp
ultimately show ?thesis
using arr_char comp_closed cod_char seqI by auto
qed
lemma runit_closed':
assumes "Arr f"
shows "Arr (B.\<rr> f)"
proof -
have 1: "arr f \<and> arr (B.\<rr> (B.dom f))"
using assms arr_char runit_closed dom_closed B.ide_dom inclusion
by simp
moreover have "B.dom f = B.cod (B.\<rr> (B.dom f))"
using 1 arr_char B.\<ll>.preserves_cod inclusion by simp
moreover have "B.\<rr> f = f \<cdot> B.\<rr> (B.dom f)"
using assms 1 B.\<rr>.is_natural_1 inclusion comp_char arr_char by simp
ultimately show ?thesis
using arr_char comp_closed cod_char seqI by auto
qed
interpretation natural_isomorphism VVV.comp \<open>(\<cdot>)\<close> HoHV HoVH \<alpha>\<^sub>S\<^sub>B
proof
fix \<mu>\<nu>\<tau>
show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> = null"
by simp
assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
have 1: "B.VVV.arr \<mu>\<nu>\<tau>"
using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char arr_char
src_def trg_def inclusion
by auto
show "dom (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
proof -
have "dom (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = B.HoHV (B.VVV.dom \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> 1 arr_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
B.\<alpha>_def assoc_closed'
by simp
also have "... = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
proof -
have "HoHV (VVV.dom \<mu>\<nu>\<tau>) = HoHV (VxVxV.dom \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> VVV.dom_char VV.arr_char src_def trg_def VVV.arr_char
by simp
also have "... = B.HoHV (B.VVV.dom \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> VVV.dom_char VVV.arr_char VV.arr_char src_def trg_def
HoHV_def B.HoHV_def arr_char B.VVV.arr_char B.VVV.dom_char B.VV.arr_char
dom_closed hcomp_closed hcomp_def inclusion
by auto
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
show "cod (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
proof -
have "cod (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = B.HoVH (B.VVV.cod \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> 1 arr_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
B.\<alpha>_def assoc_closed'
by simp
also have "... = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
proof -
have "HoVH (VVV.cod \<mu>\<nu>\<tau>) = HoVH (VxVxV.cod \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> VVV.cod_char VV.arr_char src_def trg_def VVV.arr_char
by simp
also have "... = B.HoVH (B.VVV.cod \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> VVV.cod_char VV.arr_char src_def trg_def VVV.arr_char
HoVH_def B.HoVH_def arr_char B.VVV.arr_char B.VVV.cod_char B.VV.arr_char
cod_closed hcomp_closed hcomp_def inclusion
by simp
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
have 3: "Arr (fst \<mu>\<nu>\<tau>) \<and> Arr (fst (snd \<mu>\<nu>\<tau>)) \<and> Arr (snd (snd \<mu>\<nu>\<tau>)) \<and>
src\<^sub>B (fst \<mu>\<nu>\<tau>) = trg\<^sub>B (fst (snd \<mu>\<nu>\<tau>)) \<and>
src\<^sub>B (fst (snd \<mu>\<nu>\<tau>)) = trg\<^sub>B (snd (snd \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char src_def trg_def arr_char by auto
show "HoVH \<mu>\<nu>\<tau> \<cdot> \<alpha>\<^sub>S\<^sub>B (VVV.dom \<mu>\<nu>\<tau>) = \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>"
proof -
have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> = (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B
\<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>))) (B.dom (snd (snd \<mu>\<nu>\<tau>)))"
using 3 inclusion B.assoc_is_natural_1 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
by (simp add: \<mu>\<nu>\<tau>)
also have "... = (fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>) \<star> snd (snd \<mu>\<nu>\<tau>)) \<cdot>
\<a>\<^sub>B (dom (fst \<mu>\<nu>\<tau>)) (dom (fst (snd \<mu>\<nu>\<tau>))) (dom (snd (snd \<mu>\<nu>\<tau>)))"
using 1 3 \<mu>\<nu>\<tau> hcomp_closed assoc_closed dom_closed hcomp_def comp_def inclusion
comp_char dom_char VVV.arr_char VV.arr_char
apply simp
using B.hcomp_simps(2-3) by presburger
also have "... = HoVH \<mu>\<nu>\<tau> \<cdot> \<alpha>\<^sub>S\<^sub>B (VVV.dom \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> B.\<alpha>_def HoVH_def VVV.dom_char VV.dom_char VxVxV.dom_char
apply simp
by (metis (no_types, lifting) VV.arr_char VVV.arrE VVV.arr_dom VxV.dom_char
dom_simp)
finally show ?thesis by argo
qed
show "\<alpha>\<^sub>S\<^sub>B (VVV.cod \<mu>\<nu>\<tau>) \<cdot> HoHV \<mu>\<nu>\<tau> = \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>"
proof -
have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> =
\<a>\<^sub>B (B.cod (fst \<mu>\<nu>\<tau>)) (B.cod (fst (snd \<mu>\<nu>\<tau>))) (B.cod (snd (snd \<mu>\<nu>\<tau>))) \<cdot>\<^sub>B
(fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>)) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)"
using 3 inclusion B.assoc_is_natural_2 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
by (simp add: \<mu>\<nu>\<tau>)
also have "... = \<a>\<^sub>B (cod (fst \<mu>\<nu>\<tau>)) (cod (fst (snd \<mu>\<nu>\<tau>))) (cod (snd (snd \<mu>\<nu>\<tau>))) \<cdot>
((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>)) "
using 1 3 \<mu>\<nu>\<tau> hcomp_closed assoc_closed cod_closed hcomp_def comp_def inclusion
comp_char cod_char VVV.arr_char VV.arr_char
by simp
also have "... = \<alpha>\<^sub>S\<^sub>B (VVV.cod \<mu>\<nu>\<tau>) \<cdot> HoHV \<mu>\<nu>\<tau>"
using \<mu>\<nu>\<tau> B.\<alpha>_def HoHV_def VVV.cod_char VV.cod_char VxVxV.cod_char
VVV.arr_char VV.arr_char arr_cod src_cod trg_cod
by simp
finally show ?thesis by argo
qed
next
fix fgh
assume fgh: "VVV.ide fgh"
show "iso (\<alpha>\<^sub>S\<^sub>B fgh)"
proof -
have 1: "B.arr (fst (snd fgh)) \<and> B.arr (snd (snd fgh)) \<and>
src\<^sub>B (fst (snd fgh)) = trg\<^sub>B (snd (snd fgh)) \<and>
src\<^sub>B (fst fgh) = trg\<^sub>B (fst (snd fgh))"
using fgh VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
arr_char inclusion
by auto
have 2: "B.ide (fst fgh) \<and> B.ide (fst (snd fgh)) \<and> B.ide (snd (snd fgh))"
using fgh VVV.ide_char ide_char by blast
have "\<alpha>\<^sub>S\<^sub>B fgh = \<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"
using fgh B.\<alpha>_def by simp
moreover have "B.VVV.ide fgh"
using fgh 1 2 VVV.ide_char B.VVV.ide_char VVV.arr_char B.VVV.arr_char
src_def trg_def inclusion arr_char B.VV.arr_char
by simp
moreover have "Arr (\<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
using fgh 1 VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
arr_char assoc_closed' B.\<alpha>_def
by simp
moreover have "Arr (B.inv (\<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))))"
using fgh 1 VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
arr_char assoc'_closed
by (simp add: VVV.arr_char "2" B.VVV.ide_char calculation(2))
ultimately show ?thesis
using fgh iso_char B.\<alpha>.components_are_iso by auto
qed
qed
interpretation L: endofunctor \<open>(\<cdot>)\<close> L
using endofunctor_L by auto
interpretation R: endofunctor \<open>(\<cdot>)\<close> R
using endofunctor_R by auto
interpretation L: faithful_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> L
proof
fix f f'
assume par: "par f f'"
assume eq: "L f = L f'"
have "B.par f f'"
using par inclusion arr_char by fastforce
moreover have "B.L f = B.L f'"
proof -
have "\<forall>a. Arr a \<longrightarrow> B.arr a"
by (simp add: inclusion)
moreover have 1: "\<forall>a. arr a \<longrightarrow> (if arr a then hseq (trg a) a else arr null)"
using L.preserves_arr by presburger
moreover have "Arr f \<and> Arr (trg f) \<and> trg\<^sub>B f = src\<^sub>B (trg f)"
by (meson 1 hcomp_def hseq_char' par)
ultimately show ?thesis
by (metis (no_types) eq hcomp_def hseq_char' par trg_def)
qed
ultimately show "f = f'"
using B.L.is_faithful by blast
qed
interpretation L: full_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> L
proof
fix f f' \<nu>
assume f: "ide f" and f': "ide f'" and \<nu>: "\<guillemotleft>\<nu> : L f \<Rightarrow> L f'\<guillemotright>"
have 1: "L f = trg\<^sub>B f \<star>\<^sub>B f \<and> L f' = trg\<^sub>B f' \<star>\<^sub>B f'"
using f f' hcomp_def trg_def arr_char ide_char trg_closed by simp
have 2: "\<guillemotleft>\<nu> : trg\<^sub>B f \<star>\<^sub>B f \<Rightarrow>\<^sub>B trg\<^sub>B f' \<star>\<^sub>B f'\<guillemotright>"
using 1 f f' \<nu> hcomp_def trg_def src_def inclusion
dom_char cod_char hseq_char' arr_char ide_char trg_closed null_char
by (simp add: arr_char in_hom_char)
show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> L \<mu> = \<nu>"
proof -
let ?\<mu> = "B.\<ll> f' \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B B.inv (B.\<ll> f)"
have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
proof -
have "\<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
using f f' \<nu> 2 B.\<ll>_ide_simp lunit'_closed lunit_closed' ide_char by auto
thus ?thesis
using f f' \<nu> in_hom_char arr_char comp_closed ide_char
lunit'_closed lunit_closed
by (metis (no_types, lifting) B.arrI B.seqE in_homE)
qed
have \<mu>_eq: "?\<mu> = B.\<ll> f' \<cdot> \<nu> \<cdot> B.inv (B.\<ll> f)"
proof -
have "?\<mu> = B.\<ll> f' \<cdot> \<nu> \<cdot>\<^sub>B B.inv (B.\<ll> f)"
using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
lunit'_closed lunit_closed
by (metis (no_types, lifting) B.seqE in_homE)
also have "... = B.\<ll> f' \<cdot> \<nu> \<cdot> B.inv (B.\<ll> f)"
using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
lunit'_closed lunit_closed
by (metis (no_types, lifting) B.seqE in_homE)
finally show ?thesis by simp
qed
have "L ?\<mu> = \<nu>"
proof -
have "L ?\<mu> = trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>"
using \<mu> \<mu>_eq hcomp_def trg_def inclusion arr_char trg_closed by auto
also have "... = (trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) \<cdot>\<^sub>B (B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f)"
proof -
have "B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f = trg\<^sub>B f \<star>\<^sub>B f"
using f ide_char B.comp_inv_arr B.inv_is_inverse by auto
moreover have "B.dom (trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) = trg\<^sub>B f \<star>\<^sub>B f"
using f \<mu> \<mu>_eq ide_char arr_char B.trg_dom [of ?\<mu>] B.hseqI' by fastforce
ultimately show ?thesis
using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char B.hseqI' by auto
qed
also have "... = ((trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.inv (B.\<ll> f)) \<cdot>\<^sub>B B.\<ll> f"
using B.comp_assoc by simp
also have "... = (B.inv (B.\<ll> f') \<cdot>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.\<ll> f"
using \<mu> \<mu>_eq B.\<ll>'.naturality [of ?\<mu>] by auto
also have "... = (B.inv (B.\<ll> f') \<cdot>\<^sub>B B.\<ll> f') \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B (B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f)"
using \<mu> \<mu>_eq arr_char arrI comp_simp B.comp_assoc by metis
also have "... = \<nu>"
using f f' \<nu> 2 B.comp_arr_dom B.comp_cod_arr ide_char
B.\<ll>.components_are_iso B.\<ll>_ide_simp B.comp_inv_arr'
by auto
finally show ?thesis by blast
qed
thus ?thesis
using \<mu> by auto
qed
qed
interpretation R: faithful_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> R
proof
fix f f'
assume par: "par f f'"
assume eq: "R f = R f'"
have "B.par f f'"
using par inclusion arr_char by fastforce
moreover have "B.R f = B.R f'"
proof -
have "\<forall>a. Arr a \<longrightarrow> B.arr a"
by (simp add: inclusion)
moreover have 1: "\<forall>a. arr a \<longrightarrow> (if arr a then hseq a (src a) else arr null)"
using R.preserves_arr by presburger
moreover have "Arr f \<and> Arr (src f) \<and> trg\<^sub>B (src f) = src\<^sub>B f"
by (meson 1 hcomp_def hseq_char' par)
ultimately show ?thesis
by (metis (no_types) eq hcomp_def hseq_char' par src_def)
qed
ultimately show "f = f'"
using B.R.is_faithful by blast
qed
interpretation R: full_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> R
proof
fix f f' \<nu>
assume f: "ide f" and f': "ide f'" and \<nu>: "\<guillemotleft>\<nu> : R f \<Rightarrow> R f'\<guillemotright>"
have 1: "R f = f \<star>\<^sub>B src\<^sub>B f \<and> R f' = f' \<star>\<^sub>B src\<^sub>B f'"
using f f' hcomp_def src_def arr_char ide_char src_closed by simp
have 2: "\<guillemotleft>\<nu> : f \<star>\<^sub>B src\<^sub>B f \<Rightarrow>\<^sub>B f' \<star>\<^sub>B src\<^sub>B f'\<guillemotright>"
using 1 f f' \<nu> hcomp_def trg_def src_def inclusion
dom_char cod_char hseq_char' arr_char ide_char trg_closed null_char
by (simp add: arr_char in_hom_char)
show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> R \<mu> = \<nu>"
proof -
let ?\<mu> = "B.\<rr> f' \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B B.inv (B.\<rr> f)"
have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
proof -
have "\<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
using f f' \<nu> 2 B.\<rr>_ide_simp runit'_closed runit_closed' ide_char by auto
thus ?thesis
using f f' \<nu> in_hom_char [of ?\<mu> f f'] arr_char comp_closed ide_char
runit'_closed runit_closed
apply auto
by fastforce
qed
have \<mu>_eq: "?\<mu> = B.\<rr> f' \<cdot> \<nu> \<cdot> B.inv (B.\<rr> f)"
proof -
have "?\<mu> = B.\<rr> f' \<cdot> \<nu> \<cdot>\<^sub>B B.inv (B.\<rr> f)"
using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
runit'_closed runit_closed
by (metis (no_types, lifting) B.seqE in_homE)
also have "... = B.\<rr> f' \<cdot> \<nu> \<cdot> B.inv (B.\<rr> f)"
using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
runit'_closed runit_closed
by (metis (no_types, lifting) B.arrI B.comp_in_homE in_hom_char)
finally show ?thesis by simp
qed
have "R ?\<mu> = \<nu>"
proof -
have "R ?\<mu> = ?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>"
using \<mu> \<mu>_eq hcomp_def src_def inclusion arr_char src_closed by auto
also have "... = (?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) \<cdot>\<^sub>B (B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f)"
proof -
have "B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f = f \<star>\<^sub>B src\<^sub>B f"
using f ide_char B.comp_inv_arr B.inv_is_inverse by auto
moreover have "B.dom (?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) = f \<star>\<^sub>B src\<^sub>B f"
using f \<mu> \<mu>_eq ide_char arr_char B.src_dom [of ?\<mu>] B.hseqI' by fastforce
ultimately show ?thesis
using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char B.hseqI' by auto
qed
also have "... = ((?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.inv (B.\<rr> f)) \<cdot>\<^sub>B B.\<rr> f"
using B.comp_assoc by simp
also have "... = (B.inv (B.\<rr> f') \<cdot>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.\<rr> f"
using \<mu> \<mu>_eq B.\<rr>'.naturality [of ?\<mu>] by auto
also have "... = (B.inv (B.\<rr> f') \<cdot>\<^sub>B B.\<rr> f') \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B (B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f)"
using \<mu> \<mu>_eq arr_char arrI comp_simp B.comp_assoc by metis
also have "... = \<nu>"
using f f' \<nu> 2 B.comp_arr_dom B.comp_cod_arr ide_char
B.\<ll>.components_are_iso B.\<ll>_ide_simp B.comp_inv_arr'
by auto
finally show ?thesis by blast
qed
thus ?thesis
using \<mu> by blast
qed
qed
interpretation bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
proof
show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i> a : a \<star> a \<rightarrow> a\<guillemotright>"
proof -
fix a
assume a: "obj a"
have 1: "trg\<^sub>B a = src\<^sub>B a"
using a obj_def src_def trg_def B.obj_def arr_char
by (metis horizontal_homs.objE horizontal_homs_axioms)
have 2: "Arr (\<i> a)"
using a 1 obj_def src_def trg_def in_hom_char B.unit_in_hom
arr_char hcomp_def B.obj_def ide_char objE hcomp_closed
by (metis (no_types, lifting) B.\<ll>_ide_simp B.unitor_coincidence(1) inclusion lunit_closed)
show "\<guillemotleft>\<i> a : a \<star> a \<rightarrow> a\<guillemotright>"
using a 1 2 obj_def src_def trg_def in_hom_char B.unit_in_hom
arr_char hcomp_def B.obj_def ide_char hcomp_closed
apply (elim objE) by auto
qed
show "\<And>a. obj a \<Longrightarrow> iso (\<i> a)"
proof -
fix a
assume a: "obj a"
have 1: "trg\<^sub>B a = src\<^sub>B a"
using a obj_def src_def trg_def B.obj_def arr_char
by (metis horizontal_homs.objE horizontal_homs_axioms)
have 2: "Arr (\<i> a)"
using a 1 obj_def src_def trg_def in_hom_char B.unit_in_hom
arr_char hcomp_def B.obj_def ide_char objE hcomp_closed
by (metis (no_types, lifting) B.\<ll>_ide_simp B.unitor_coincidence(1) inclusion lunit_closed)
have "iso (B.\<ll> a)"
using a 2 obj_def B.iso_unit iso_char arr_char lunit_closed lunit'_closed B.iso_lunit
apply simp
by (metis (no_types, lifting) B.\<ll>.components_are_iso B.ide_src inclusion src_def)
thus "iso (\<i> a)"
using a 2 obj_def B.iso_unit iso_char arr_char B.unitor_coincidence
apply simp
by (metis (no_types, lifting) B.\<ll>_ide_simp B.ide_src B.obj_src inclusion src_def)
qed
show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k;
src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
(f \<star> \<a> g h k) \<cdot> \<a> f (g \<star> h) k \<cdot> (\<a> f g h \<star> k) =
\<a> f g (h \<star> k) \<cdot> \<a> (f \<star> g) h k"
using B.pentagon VVV.arr_char VV.arr_char hcomp_def assoc_closed arr_char comp_char
hcomp_closed comp_closed ide_char inclusion src_def trg_def
by simp
qed
proposition is_bicategory:
shows "bicategory (\<cdot>) (\<star>) \<a> \<i> src trg"
..
lemma obj_char:
shows "obj a \<longleftrightarrow> Arr a \<and> B.obj a"
using obj_def src_def arr_char
by (simp add: B.obj_def inclusion)
end
sublocale subbicategory \<subseteq> bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
using is_bicategory by auto
subsection "The Sub-bicategory of Endo-arrows of an Object"
text \<open>
We now consider the sub-bicategory consisting of all arrows having the same
object \<open>a\<close> both as their source and their target and we show that the resulting structure
is a monoidal category. We actually prove a slightly more general result,
in which the unit of the monoidal category is taken to be an arbitrary isomorphism
\<open>\<guillemotleft>\<omega> : w \<star>\<^sub>B w \<Rightarrow> w\<guillemotright>\<close> with \<open>w\<close> isomorphic to \<open>a\<close>, rather than the particular choice
\<open>\<guillemotleft>\<i>[a] : a \<star>\<^sub>B a \<Rightarrow> a\<guillemotright>\<close> made by the ambient bicategory.
\<close>
locale subbicategory_at_object =
B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
subbicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B \<open>\<lambda>\<mu>. B.arr \<mu> \<and> src\<^sub>B \<mu> = a \<and> trg\<^sub>B \<mu> = a\<close>
for V :: "'a comp" (infixr "\<cdot>\<^sub>B" 55)
and H :: "'a comp" (infixr "\<star>\<^sub>B" 55)
and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src\<^sub>B :: "'a \<Rightarrow> 'a"
and trg\<^sub>B :: "'a \<Rightarrow> 'a"
and a :: "'a"
and w :: "'a"
and \<omega> :: "'a" +
assumes obj_a: "B.obj a"
and isomorphic_a_w: "B.isomorphic a w"
and \<omega>_in_vhom: "\<guillemotleft>\<omega> : w \<star>\<^sub>B w \<Rightarrow> w\<guillemotright>"
and \<omega>_is_iso: "B.iso \<omega>"
begin
notation hcomp (infixr "\<star>" 53)
lemma arr_simps:
assumes "arr \<mu>"
shows "src \<mu> = a" and "trg \<mu> = a"
apply (metis (no_types, lifting) arrE assms src_def)
by (metis (no_types, lifting) arrE assms trg_def)
lemma \<omega>_simps [simp]:
shows "arr \<omega>"
and "src \<omega> = a" and "trg \<omega> = a"
and "dom \<omega> = w \<star>\<^sub>B w" and "cod \<omega> = w"
using isomorphic_a_w \<omega>_in_vhom in_hom_char arr_simps by auto
lemma ide_w:
shows "B.ide w"
using isomorphic_a_w B.isomorphic_def by auto
lemma w_simps [simp]:
shows "ide w" and "B.ide w"
and "src w = a" and "trg w = a" and "src\<^sub>B w = a" and "trg\<^sub>B w = a"
and "dom w = w" and "cod w = w"
proof -
show w: "ide w"
using \<omega>_in_vhom ide_cod by blast
show "B.ide w"
using w ide_char by simp
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : a \<Rightarrow>\<^sub>B w\<guillemotright> \<and> B.iso \<phi>"
using isomorphic_a_w B.isomorphic_def by auto
show "src\<^sub>B w = a"
using obj_a w \<phi> B.src_cod by force
show "trg\<^sub>B w = a"
using obj_a w \<phi> B.src_cod by force
show "src w = a"
using `src\<^sub>B w = a` ide_w src_def
by (simp add: \<open>trg\<^sub>B w = a\<close>)
show "trg w = a"
using `src\<^sub>B w = a` ide_w trg_def
by (simp add: \<open>trg\<^sub>B w = a\<close>)
show "dom w = w"
using w by simp
show "cod w = w"
using w by simp
qed
lemma VxV_arr_eq_VV_arr:
shows "VxV.arr f \<longleftrightarrow> VV.arr f"
using inclusion VxV.arr_char VV.arr_char arr_char src_def trg_def
by auto
lemma VxV_comp_eq_VV_comp:
shows "VxV.comp = VV.comp"
proof -
have "\<And>f g. VxV.comp f g = VV.comp f g"
proof -
fix f g
show "VxV.comp f g = VV.comp f g"
unfolding VV.comp_def
using VxV.comp_char arr_simps(1) arr_simps(2)
apply (cases "seq (fst f) (fst g)", cases "seq (snd f) (snd g)")
apply (elim seqE)
by auto
qed
thus ?thesis by blast
qed
lemma VxVxV_arr_eq_VVV_arr:
shows "VxVxV.arr f \<longleftrightarrow> VVV.arr f"
using VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
by auto
lemma VxVxV_comp_eq_VVV_comp:
shows "VxVxV.comp = VVV.comp"
proof -
have "\<And>f g. VxVxV.comp f g = VVV.comp f g"
proof -
fix f g
show "VxVxV.comp f g = VVV.comp f g"
proof (cases "VxVxV.seq f g")
assume 1: "\<not> VxVxV.seq f g"
have "VxVxV.comp f g = VxVxV.null"
using 1 VxVxV.ext by blast
also have "... = (null, null, null)"
using VxVxV.null_char VxV.null_char by simp
also have "... = VVV.null"
using VVV.null_char VV.null_char by simp
also have "... = VVV.comp f g"
proof -
have "\<not> VVV.seq f g"
using 1 VVV.seq_char by blast
thus ?thesis
by (metis (no_types, lifting) VVV.ext)
qed
finally show ?thesis by simp
next
assume 1: "VxVxV.seq f g"
have 2: "B.arr (fst f) \<and> B.arr (fst (snd f)) \<and> B.arr (snd (snd f)) \<and>
src\<^sub>B (fst f) = a \<and> src\<^sub>B (fst (snd f)) = a \<and> src\<^sub>B (snd (snd f)) = a \<and>
trg\<^sub>B (fst f) = a \<and> trg\<^sub>B (fst (snd f)) = a \<and> trg\<^sub>B (snd (snd f)) = a"
using 1 VxVxV.seq_char VxV.seq_char arr_char by blast
have 3: "B.arr (fst g) \<and> B.arr (fst (snd g)) \<and> B.arr (snd (snd g)) \<and>
src\<^sub>B (fst g) = a \<and> src\<^sub>B (fst (snd g)) = a \<and> src\<^sub>B (snd (snd g)) = a \<and>
trg\<^sub>B (fst g) = a \<and> trg\<^sub>B (fst (snd g)) = a \<and> trg\<^sub>B (snd (snd g)) = a"
using 1 VxVxV.seq_char VxV.seq_char arr_char by blast
have 4: "B.seq (fst f) (fst g) \<and> B.seq (fst (snd f)) (fst (snd g)) \<and>
B.seq (snd (snd f)) (snd (snd g))"
using 1 VxVxV.seq_char VxV.seq_char seq_char by blast
have 5: "VxVxV.comp f g =
(fst f \<cdot> fst g, fst (snd f) \<cdot> fst (snd g), snd (snd f) \<cdot> snd (snd g))"
using 1 2 3 4 VxVxV.seqE VxVxV.comp_char VxV.comp_char seq_char arr_char
by (metis (no_types, lifting))
also have "... = VVV.comp f g"
- using 1 2 3 5 VVV.comp_char VV.comp_char VVV.arr_char VV.arr_char arr_char
- src_def trg_def
- by simp
+ using 1 VVV.comp_char VVV.arr_char VV.arr_char
+ apply simp
+ using 2 3 5 arrI arr_simps(1) arr_simps(2) by presburger
finally show ?thesis by blast
qed
qed
thus ?thesis by blast
qed
interpretation H: "functor" VxV.comp \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
using H.functor_axioms hcomp_def VxV_comp_eq_VV_comp by simp
interpretation H: binary_endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> ..
lemma HoHV_eq_ToTC:
shows "HoHV = H.ToTC"
using HoHV_def H.ToTC_def VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
by auto
lemma HoVH_eq_ToCT:
shows "HoVH = H.ToCT"
using HoVH_def H.ToCT_def VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
by auto
interpretation ToTC: "functor" VxVxV.comp \<open>(\<cdot>)\<close> H.ToTC
using HoHV_eq_ToTC VxVxV_comp_eq_VVV_comp HoHV.functor_axioms by simp
interpretation ToCT: "functor" VxVxV.comp \<open>(\<cdot>)\<close> H.ToCT
using HoVH_eq_ToCT VxVxV_comp_eq_VVV_comp HoVH.functor_axioms by simp
interpretation \<alpha>: natural_isomorphism VxVxV.comp \<open>(\<cdot>)\<close> H.ToTC H.ToCT \<alpha>
unfolding \<alpha>_def
using \<alpha>.natural_isomorphism_axioms HoHV_eq_ToTC HoVH_eq_ToCT \<alpha>_def
VxVxV_comp_eq_VVV_comp
by simp
interpretation L: endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close>
proof
fix f
show "\<not> arr f \<Longrightarrow> fst (w, f) \<star> snd (w, f) = null"
using arr_char hcomp_def by auto
assume f: "arr f"
show "hseq (fst (w, f)) (snd (w, f))"
using f hseq_char arr_char src_def trg_def \<omega>_in_vhom cod_char by simp
show "dom (fst (w, f) \<star> snd (w, f)) = fst (w, dom f) \<star> snd (w, dom f)"
using f arr_char hcomp_def B.hseqI' by simp
show "cod (fst (w, f) \<star> snd (w, f)) = fst (w, cod f) \<star> snd (w, cod f)"
using f arr_char hcomp_def B.hseqI' by simp
next
fix f g
assume fg: "seq g f"
show "fst (w, g \<cdot> f) \<star> snd (w, g \<cdot> f) = (fst (w, g) \<star> snd (w, g)) \<cdot> (fst (w, f) \<star> snd (w, f))"
by (simp add: fg whisker_left)
qed
interpretation L': equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close>
proof -
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi>"
using isomorphic_a_w B.isomorphic_symmetric by force
have "\<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright>"
using \<phi> in_hom_char
by (metis (no_types, lifting) B.in_homE B.src_cod B.src_src B.trg_cod B.trg_trg
\<omega>_in_vhom arr_char arr_cod cod_simp)
hence \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi> \<and> \<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
using \<phi> iso_char arr_char by auto
interpret \<l>: natural_isomorphism \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close>
\<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close> map \<open>\<lambda>f. \<ll> f \<cdot> (\<phi> \<star> dom f)\<close>
proof
fix \<mu>
show "\<not> arr \<mu> \<Longrightarrow> \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>) = null"
using \<phi> arr_char dom_char ext
apply simp
using comp_null(2) hcomp_def by fastforce
assume \<mu>: "arr \<mu>"
have 1: "hseq \<phi> (dom \<mu>)"
proof (intro hseqI)
show "in_hhom (dom \<mu>) a a"
using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
show "in_hhom \<phi> a a"
using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
qed
have 2: "hseq \<phi> (B.dom \<mu>)"
proof (intro hseqI)
show "in_hhom (B.dom \<mu>) a a"
using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
show "in_hhom \<phi> a a"
using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
qed
have 3: "seq (\<ll> \<mu>) (\<phi> \<star> dom \<mu>)"
using \<mu> \<phi> 1 2
apply (intro seqI hseqI')
apply auto
proof -
have "B.dom (\<ll> \<mu>) = a \<star> dom \<mu>"
using \<mu> 2 \<ll>.preserves_dom arr_simps(2) by auto
also have "... = B.cod (\<phi> \<star> B.dom \<mu>)"
using \<mu> \<phi> 2 hcomp_simps(4) cod_dom in_homE by auto
finally show "B.dom (\<ll> \<mu>) = B.cod (\<phi> \<star> B.dom \<mu>)"
by blast
qed
show "dom (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = fst (w, dom \<mu>) \<star> snd (w, dom \<mu>)"
proof -
have "dom (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = dom \<phi> \<star> dom \<mu>"
using \<mu> 3 hcomp_simps(3) dom_comp
by (metis (no_types, lifting) dom_dom seqE)
also have "... = fst (w, dom \<mu>) \<star> snd (w, dom \<mu>)"
using \<omega>_in_vhom \<phi>
by (metis (no_types, lifting) in_homE prod.sel(1) prod.sel(2))
finally show ?thesis by simp
qed
show "cod (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = map (cod \<mu>)"
proof -
have "seq (\<ll> \<mu>) (\<phi> \<star> dom \<mu>)"
using 3 by simp
hence "cod (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = cod (\<ll> \<mu>)"
using cod_comp by blast
also have "... = map (cod \<mu>)"
using \<mu> by blast
finally show ?thesis by blast
qed
show "map \<mu> \<cdot> \<ll> (dom \<mu>) \<cdot> (\<phi> \<star> dom (dom \<mu>)) = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
proof -
(*
* TODO: The automatic simplification of dom to B.dom prevents the application
* of dom_dom here.
*)
have "map \<mu> \<cdot> \<ll> (dom \<mu>) \<cdot> (\<phi> \<star> dom (dom \<mu>)) =
(map \<mu> \<cdot> \<ll> (dom \<mu>)) \<cdot> (\<phi> \<star> dom (dom \<mu>))"
using comp_assoc by simp
also have "... = (map \<mu> \<cdot> \<ll> (dom \<mu>)) \<cdot> (\<phi> \<star> dom \<mu>)"
using \<mu> dom_dom by simp
also have "... = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
using \<mu> \<phi> \<ll>.is_natural_1 by auto
finally show ?thesis by blast
qed
show "(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> dom (cod \<mu>))) \<cdot> (fst (w, \<mu>) \<star> snd (w, \<mu>)) = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
proof -
have "(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> dom (cod \<mu>))) \<cdot> (fst (w, \<mu>) \<star> snd (w, \<mu>)) =
(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> B.cod \<mu>)) \<cdot> (w \<star> \<mu>)"
using \<mu> \<phi> dom_char arr_char \<omega>_in_vhom by simp
also have "... = \<ll> (cod \<mu>) \<cdot> (\<phi> \<cdot> w \<star> B.cod \<mu> \<cdot> \<mu>)"
proof -
have "seq \<phi> w"
using \<phi> \<omega>_in_vhom w_simps(1) by blast
moreover have 2: "seq (B.cod \<mu>) \<mu>"
using \<mu> seq_char by (simp add: comp_cod_arr)
moreover have "src \<phi> = trg (B.cod \<mu>)"
using \<mu> \<phi> 1 2
by (metis (no_types, lifting) hseqE trg_dom vseq_implies_hpar(2))
ultimately show ?thesis
using interchange comp_assoc by simp
qed
also have "... = \<ll> (cod \<mu>) \<cdot> (\<phi> \<star> \<mu>)"
using \<mu> \<phi> \<omega>_in_vhom comp_arr_dom comp_cod_arr cod_simp
apply (elim conjE in_homE) by auto
also have "... = (\<ll> (cod \<mu>) \<cdot> (cod \<phi> \<star> \<mu>)) \<cdot> (\<phi> \<star> dom \<mu>)"
proof -
have "seq (cod \<phi>) \<phi>"
using \<phi> arr_cod_iff_arr dom_cod iso_is_arr seqI by presburger
moreover have "seq \<mu> (dom \<mu>)"
using \<mu> by (simp add: comp_arr_dom)
moreover have "src (cod \<phi>) = trg \<mu>"
using \<mu> \<phi> arr_cod arr_simps(1-2) iso_is_arr by auto
ultimately show ?thesis
using \<mu> \<phi> interchange [of "cod \<phi>" \<phi> \<mu> "dom \<mu>"] comp_assoc
by (simp add: comp_arr_dom comp_cod_arr iso_is_arr)
qed
also have "... = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
proof -
have "L \<mu> = cod \<phi> \<star> \<mu>"
using \<mu> \<phi> arr_simps(2) in_homE by auto
hence "\<ll> (cod \<mu>) \<cdot> (cod \<phi> \<star> \<mu>) = \<ll> \<mu>"
using \<mu> \<ll>.is_natural_2 [of \<mu>] by simp
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
next
show "\<And>f. ide f \<Longrightarrow> iso (\<ll> f \<cdot> (\<phi> \<star> dom f))"
proof -
fix f
assume f: "ide f"
have "iso (\<ll> f)"
using f iso_lunit by simp
moreover have "iso (\<phi> \<star> dom f)"
using \<phi> f src_def trg_def ide_char arr_char
apply (intro iso_hcomp, simp_all)
by (metis (no_types, lifting) in_homE)
moreover have "seq (\<ll> f) (\<phi> \<star> dom f)"
proof (intro seqI')
show " \<guillemotleft>\<ll> f : a \<star> f \<Rightarrow> f\<guillemotright>"
using f lunit_in_hom(2) \<ll>_ide_simp ide_char arr_char trg_def by simp
show "\<guillemotleft>\<phi> \<star> dom f : w \<star> f \<Rightarrow> a \<star> f\<guillemotright>"
using \<phi> f ide_char arr_char hcomp_def src_def trg_def obj_a ide_in_hom
in_hom_char
by (intro hcomp_in_vhom, auto)
qed
ultimately show "iso (\<ll> f \<cdot> (\<phi> \<star> dom f))"
using isos_compose by simp
qed
qed
show "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (w, f) \<star> snd (w, f))"
using \<l>.natural_isomorphism_axioms L.isomorphic_to_identity_is_equivalence by simp
qed
interpretation L: equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f)\<close>
proof -
have "(\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f)) = (\<lambda>f. fst (w, f) \<star> snd (w, f))"
using \<omega>_in_vhom by simp
thus "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f))"
using L'.equivalence_functor_axioms by simp
qed
interpretation R: endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close>
proof
fix f
show "\<not> arr f \<Longrightarrow> fst (f, w) \<star> snd (f, w) = null"
using arr_char hcomp_def by auto
assume f: "arr f"
show "hseq (fst (f, w)) (snd (f, w))"
using f hseq_char arr_char src_def trg_def \<omega>_in_vhom cod_char isomorphic_a_w
B.isomorphic_def in_hom_char
by simp
show "dom (fst (f, w) \<star> snd (f, w)) = fst (dom f, w) \<star> snd (dom f, w)"
using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom B.hseqI' by simp
show "cod (fst (f, w) \<star> snd (f, w)) = fst (cod f, w) \<star> snd (cod f, w)"
using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom B.hseqI' by simp
next
fix f g
assume fg: "seq g f"
have 1: "a \<cdot>\<^sub>B a = a"
using obj_a by auto
show "fst (g \<cdot> f, w) \<star> snd (g \<cdot> f, w) = (fst (g, w) \<star> snd (g, w)) \<cdot> (fst (f, w) \<star> snd (f, w))"
by (simp add: fg whisker_right)
qed
interpretation R': equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close>
proof -
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi>"
using isomorphic_a_w B.isomorphic_symmetric by force
have "\<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright>"
using \<phi> in_hom_char
by (metis (no_types, lifting) B.in_homE B.src_cod B.src_src B.trg_cod B.trg_trg
\<omega>_in_vhom arr_char arr_cod cod_simp)
hence \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi> \<and> \<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
using \<phi> iso_char arr_char by auto
interpret \<r>: natural_isomorphism comp comp
\<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close> map \<open>\<lambda>f. \<rr> f \<cdot> (dom f \<star> \<phi>)\<close>
proof
fix \<mu>
show "\<not> arr \<mu> \<Longrightarrow> \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>) = null"
using \<phi> arr_char dom_char ext
apply simp
using comp_null(2) hcomp_def by fastforce
assume \<mu>: "arr \<mu>"
have 1: "hseq \<phi> (dom \<mu>)"
proof (intro hseqI)
show "in_hhom (dom \<mu>) a a"
using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
show "in_hhom \<phi> a a"
using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
qed
have 2: "hseq (B.dom \<mu>) \<phi>"
using \<mu> \<phi> 1 src_dom [of \<mu>]
apply (intro hseqI')
by (auto simp add: arr_simps(1) vconn_implies_hpar(2))
have 3: "seq (\<rr> \<mu>) (dom \<mu> \<star> \<phi>)"
using \<mu> \<phi> 1 2
apply (intro seqI hseqI')
apply auto
proof -
have "B.dom (\<rr> \<mu>) = dom \<mu> \<star> a"
using \<mu> 2 \<rr>.preserves_dom arr_simps(1) by auto
also have "... = B.cod (B.dom \<mu> \<star> \<phi>)"
using \<mu> \<phi> 2 hcomp_simps(4) cod_dom in_homE by auto
finally show "B.dom (\<rr> \<mu>) = B.cod (B.dom \<mu> \<star> \<phi>)"
by blast
qed
show "dom (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = fst (dom \<mu>, w) \<star> snd (dom \<mu>, w)"
proof -
have "dom (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = dom \<mu> \<star> dom \<phi>"
using \<mu> 3 hcomp_simps(3) dom_comp
by (metis (no_types, lifting) dom_dom seqE)
also have "... = fst (dom \<mu>, w) \<star> snd (dom \<mu>, w)"
using \<omega>_in_vhom \<phi>
by (metis (no_types, lifting) in_homE prod.sel(1) prod.sel(2))
finally show ?thesis by simp
qed
show "cod (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = map (cod \<mu>)"
proof -
have "seq (\<rr> \<mu>) (dom \<mu> \<star> \<phi>)"
using 3 by simp
hence "cod (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = cod (\<rr> \<mu>)"
using cod_comp by blast
also have "... = map (cod \<mu>)"
using \<mu> by blast
finally show ?thesis by blast
qed
show "map \<mu> \<cdot> \<rr> (dom \<mu>) \<cdot> (dom (dom \<mu>) \<star> \<phi>) = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
proof -
have "map \<mu> \<cdot> \<rr> (dom \<mu>) \<cdot> (dom (dom \<mu>) \<star> \<phi>) =
(map \<mu> \<cdot> \<rr> (dom \<mu>)) \<cdot> (dom (dom \<mu>) \<star> \<phi>)"
using comp_assoc by simp
also have "... = (map \<mu> \<cdot> \<rr> (dom \<mu>)) \<cdot> (dom \<mu> \<star> \<phi>)"
using \<mu> dom_dom by simp
also have "... = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
using \<mu> \<phi> \<rr>.is_natural_1 by auto
finally show ?thesis by blast
qed
show "(\<rr> (cod \<mu>) \<cdot> (dom (cod \<mu>) \<star> \<phi>)) \<cdot> (fst (\<mu>, w) \<star> snd (\<mu>, w)) = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
proof -
have "(\<rr> (cod \<mu>) \<cdot> (dom (cod \<mu>) \<star> \<phi>)) \<cdot> (fst (\<mu>, w) \<star> snd (\<mu>, w)) =
(\<rr> (cod \<mu>) \<cdot> (B.cod \<mu> \<star> \<phi>)) \<cdot> (\<mu> \<star> w)"
using \<mu> \<phi> dom_char arr_char \<omega>_in_vhom by simp
also have "... = \<rr> (cod \<mu>) \<cdot> (B.cod \<mu> \<cdot> \<mu> \<star> \<phi> \<cdot> w)"
proof -
have 2: "seq \<phi> w"
using \<phi> \<omega>_in_vhom w_simps(1) by blast
moreover have "seq (B.cod \<mu>) \<mu>"
using \<mu> seq_char by (simp add: comp_cod_arr)
moreover have "src (B.cod \<mu>) = trg \<phi>"
using \<mu> \<phi> 2
by (metis (no_types, lifting) arrE cod_closed src_def vseq_implies_hpar(2)
w_simps(4))
ultimately show ?thesis
using interchange comp_assoc by simp
qed
also have "... = \<rr> (cod \<mu>) \<cdot> (\<mu> \<star> \<phi>)"
using \<mu> \<phi> \<omega>_in_vhom comp_arr_dom comp_cod_arr cod_simp
apply (elim conjE in_homE) by auto
also have "... = (\<rr> (cod \<mu>) \<cdot> (\<mu> \<star> cod \<phi>)) \<cdot> (dom \<mu> \<star> \<phi>)"
proof -
have "(\<mu> \<star> cod \<phi>) \<cdot> (dom \<mu> \<star> \<phi>) = \<mu> \<star> \<phi>"
proof -
have "seq \<mu> (dom \<mu>)"
using \<mu> by (simp add: comp_arr_dom)
moreover have "seq (cod \<phi>) \<phi>"
using \<phi> iso_is_arr arr_cod dom_cod by auto
moreover have "src \<mu> = trg (cod \<phi>)"
using \<mu> \<phi> 2
by (metis (no_types, lifting) arr_simps(1) arr_simps(2) calculation(2) seqE)
ultimately show ?thesis
using \<mu> \<phi> iso_is_arr comp_arr_dom comp_cod_arr
interchange [of \<mu> "dom \<mu>" "cod \<phi>" \<phi>]
by simp
qed
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
proof -
have "\<mu> \<star> cod \<phi> = R \<mu>"
using \<mu> \<phi> arr_simps(1) in_homE by auto
hence "\<rr> (cod \<mu>) \<cdot> (\<mu> \<star> cod \<phi>) = \<rr> \<mu>"
using \<mu> \<phi> \<rr>.is_natural_2 by simp
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
next
show "\<And>f. ide f \<Longrightarrow> iso (\<rr> f \<cdot> (dom f \<star> \<phi>))"
proof -
fix f
assume f: "ide f"
have 1: "iso (\<rr> f)"
using f iso_lunit by simp
moreover have 2: "iso (dom f \<star> \<phi>)"
using \<phi> f src_def trg_def ide_char arr_char
apply (intro iso_hcomp, simp_all)
by (metis (no_types, lifting) in_homE)
moreover have "seq (\<rr> f) (dom f \<star> \<phi>)"
proof (intro seqI')
show "\<guillemotleft>\<rr> f : f \<star> a \<Rightarrow> f\<guillemotright>"
using f runit_in_hom(2) \<rr>_ide_simp ide_char arr_char src_def by simp
show "\<guillemotleft>dom f \<star> \<phi> : f \<star> w \<Rightarrow> f \<star> a\<guillemotright>"
using \<phi> f ide_char arr_char hcomp_def src_def trg_def obj_a ide_in_hom
in_hom_char
by (intro hcomp_in_vhom, auto)
qed
ultimately show "iso (\<rr> f \<cdot> (dom f \<star> \<phi>))"
using isos_compose by simp
qed
qed
show "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (f, w) \<star> snd (f, w))"
using \<r>.natural_isomorphism_axioms R.isomorphic_to_identity_is_equivalence by simp
qed
interpretation R: equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>)\<close>
proof -
have "(\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>)) = (\<lambda>f. fst (f, w) \<star> snd (f, w))"
using \<omega>_in_vhom by simp
thus "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>))"
using R'.equivalence_functor_axioms by simp
qed
interpretation M: monoidal_category \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> \<alpha> \<omega>
proof
show "\<guillemotleft>\<omega> : fst (cod \<omega>, cod \<omega>) \<star> snd (cod \<omega>, cod \<omega>) \<Rightarrow> cod \<omega>\<guillemotright>"
using \<omega>_in_vhom hcomp_def arr_char by auto
show "iso \<omega>"
using \<omega>_is_iso iso_char arr_char inv_char \<omega>_in_vhom by auto
show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k \<rbrakk> \<Longrightarrow>
(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
\<alpha> (f, hcomp (fst (g, h)) (snd (g, h)), k) \<cdot>
(fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
\<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
proof -
fix f g h k
assume f: "ide f" and g: "ide g" and h: "ide h" and k: "ide k"
have 1: "VVV.arr (f, g, h) \<and> VVV.arr (g, h, k)"
using f g h k VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
by simp
have 2: "VVV.arr (f, g \<star> h, k)"
using f g h k 1 HoHV_def VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp hseqI'
by auto
have 3: "VVV.arr (f, g, h \<star> k)"
using f g h k 1 VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp hseqI' H.preserves_reflects_arr
by auto
have 4: "VVV.arr (f \<star> g, h, k)"
using f g h k VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char hseq_char
VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp
by force
have "(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
\<alpha> (f, fst (g, h) \<star> snd (g, h), k) \<cdot>
(fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
(f \<star> \<a>\<^sub>B[g, h, k]) \<cdot> \<a>\<^sub>B[f, g \<star> h, k] \<cdot> (\<a>\<^sub>B[f, g, h] \<star> k)"
unfolding \<alpha>_def by (simp add: 1 2)
also have "... = (f \<star>\<^sub>B \<a>\<^sub>B g h k) \<cdot> \<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot> (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
unfolding hcomp_def
using f g h k src_def trg_def arr_char
using assoc_closed ide_char by auto
also have "... = (f \<star>\<^sub>B \<a>\<^sub>B g h k) \<cdot>\<^sub>B \<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
proof -
have "arr (f \<star>\<^sub>B \<a>\<^sub>B g h k)"
using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
moreover have "arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k)"
using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
moreover have "arr (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
moreover have "arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B (\<a>\<^sub>B f g h \<star>\<^sub>B k))"
unfolding arr_char
apply (intro conjI)
using ide_char arr_char assoc_closed f g h hcomp_closed k B.HoHV_def B.HoVH_def
apply (intro B.seqI)
apply simp_all
proof -
have 1: "B.arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k)"
using f g h k ide_char arr_char B.hseqI' B.HoHV_def B.HoVH_def
apply (intro B.seqI)
by auto
show "src\<^sub>B (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k) = a"
using 1 f g h k arr_char B.src_vcomp B.vseq_implies_hpar(1) by fastforce
show "trg\<^sub>B (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k) = a"
using "1" arr_char calculation(2-3) by auto
qed
ultimately show ?thesis
using B.ext comp_char by (metis (no_types, lifting))
qed
also have "... = \<a>\<^sub>B f g (h \<star>\<^sub>B k) \<cdot>\<^sub>B \<a>\<^sub>B (f \<star>\<^sub>B g) h k"
using f g h k src_def trg_def arr_char ide_char B.pentagon
using "4" \<alpha>_def hcomp_def by auto
also have "... = \<a>\<^sub>B f g (h \<star>\<^sub>B k) \<cdot> \<a>\<^sub>B (f \<star>\<^sub>B g) h k"
proof -
have "arr (\<a>\<^sub>B (f \<star>\<^sub>B g) h k)"
using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
moreover have "arr (\<a>\<^sub>B f g (h \<star>\<^sub>B k))"
using ide_char arr_char assoc_closed f g h hcomp_closed k by fastforce
ultimately show ?thesis
using B.ext comp_char by auto
qed
also have "... = \<a>\<^sub>B[f, g, fst (h, k) \<star> snd (h, k)] \<cdot> \<a>\<^sub>B[fst (f, g) \<star> snd (f, g), h, k]"
unfolding hcomp_def
using f g h k src_def trg_def arr_char ide_char by simp
also have "... = \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
unfolding \<alpha>_def using 1 2 3 4 by simp
finally show "(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
\<alpha> (f, fst (g, h) \<star> snd (g, h), k) \<cdot>
(fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
\<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
by simp
qed
qed
proposition is_monoidal_category:
shows "monoidal_category (\<cdot>) (\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>) \<alpha> \<omega>"
..
end
text \<open>
In a bicategory, the ``objects'' are essentially arbitrarily chosen representatives
of their isomorphism classes. Choosing any other representatives results in an
equivalent structure. Each object \<open>a\<close> is additionally equipped with an arbitrarily chosen
unit isomorphism \<open>\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>\<close>. For any \<open>(a, \<iota>)\<close> and \<open>(a', \<iota>')\<close>,
where \<open>a\<close> and \<open>a'\<close> are isomorphic to the same object, there exists a unique isomorphism
\<open>\<guillemotleft>\<psi>: a \<Rightarrow> a'\<guillemotright>\<close> that is compatible with the chosen unit isomorphisms \<open>\<iota>\<close> and \<open>\<iota>'\<close>.
We have already proved this property for monoidal categories, which are bicategories
with just one ``object''. Here we use that already-proven property to establish its
generalization to arbitary bicategories, by exploiting the fact that if \<open>a\<close> is an object
in a bicategory, then the sub-bicategory consisting of all \<open>\<mu>\<close> such that
\<open>src \<mu> = a = trg \<mu>\<close>, is a monoidal category.
At some point it would potentially be nicer to transfer the proof for monoidal
categories to obtain a direct, ``native'' proof of this fact for bicategories.
\<close>
lemma (in bicategory) unit_unique_upto_unique_iso:
assumes "obj a"
and "isomorphic a w"
and "\<guillemotleft>\<omega> : w \<star> w \<Rightarrow> w\<guillemotright>"
and "iso \<omega>"
shows "\<exists>!\<psi>. \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright> \<and> iso \<psi> \<and> \<psi> \<cdot> \<i>[a] = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
proof -
have \<omega>_in_hhom: "\<guillemotleft>\<omega> : a \<rightarrow> a\<guillemotright>"
using assms
apply (intro in_hhomI)
apply auto
apply (metis src_cod in_homE isomorphic_implies_hpar(3) objE)
by (metis trg_cod in_homE isomorphic_implies_hpar(4) objE)
interpret S: subbicategory V H \<a> \<i> src trg \<open>\<lambda>\<mu>. arr \<mu> \<and> src \<mu> = a \<and> trg \<mu> = a\<close>
using assms iso_unit in_homE isoE isomorphicE VVV.arr_char VV.arr_char hseqI'
apply unfold_locales
apply auto[7]
proof
fix f g h
assume f: "(arr f \<and> src f = a \<and> trg f = a) \<and> ide f"
and g: "(arr g \<and> src g = a \<and> trg g = a) \<and> ide g"
and h: "(arr h \<and> src h = a \<and> trg h = a) \<and> ide h"
and fg: "src f = trg g" and gh: "src g = trg h"
show "arr (\<a>[f, g, h])"
using assms f g h fg gh by auto
show "src (\<a>[f, g, h]) = a \<and> trg (\<a>[f, g, h]) = a"
using assms f g h fg gh by auto
show "arr (inv (\<a>[f, g, h])) \<and> src (inv (\<a>[f, g, h])) = a \<and> trg (inv (\<a>[f, g, h])) = a"
using assms f g h fg gh \<alpha>.preserves_hom src_dom trg_dom by simp
next
fix f
assume f: "arr f \<and> src f = a \<and> trg f = a"
assume ide_left: "ide f"
show "arr (\<ll> f) \<and> src (\<ll> f) = a \<and> trg (\<ll> f) = a"
using f assms(1) \<ll>.preserves_hom src_cod [of "\<ll> f"] trg_cod [of "\<ll> f"] by simp
show "arr (inv (\<ll> f)) \<and> src (inv (\<ll> f)) = a \<and> trg (inv (\<ll> f)) = a"
using f ide_left assms(1) \<ll>'.preserves_hom src_dom [of "\<ll>'.map f"] trg_dom [of "\<ll>'.map f"]
by simp
show "arr (\<rr> f) \<and> src (\<rr> f) = a \<and> trg (\<rr> f) = a"
using f assms(1) \<rr>.preserves_hom src_cod [of "\<rr> f"] trg_cod [of "\<rr> f"] by simp
show "arr (inv (\<rr> f)) \<and> src (inv (\<rr> f)) = a \<and> trg (inv (\<rr> f)) = a"
using f ide_left assms(1) \<rr>'.preserves_hom src_dom [of "\<rr>'.map f"] trg_dom [of "\<rr>'.map f"]
by simp
qed
interpret S: subbicategory_at_object V H \<a> \<i> src trg a a \<open>\<i>[a]\<close>
proof
show "obj a" by fact
show "isomorphic a a"
using assms(1) isomorphic_reflexive by blast
show "S.in_hom \<i>[a] (a \<star> a) a"
by (metis (no_types, lifting) S.hcomp_def S.obj_char S.unit_in_vhom assms(1)
obj_def obj_self_composable(1) seq_if_composable)
show "iso \<i>[a]"
using assms iso_unit by simp
qed
interpret S\<^sub>\<omega>: subbicategory_at_object V H \<a> \<i> src trg a w \<omega>
proof
show "obj a" by fact
show "iso \<omega>" by fact
show "isomorphic a w"
using assms by simp
show "S.in_hom \<omega> (w \<star> w) w"
using assms S.arr_char S.dom_char S.cod_char \<omega>_in_hhom
by (intro S.in_homI, auto)
qed
interpret M: monoidal_category S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<open>\<i>[a]\<close>
using S.is_monoidal_category by simp
interpret M\<^sub>\<omega>: monoidal_category S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<omega>
using S\<^sub>\<omega>.is_monoidal_category by simp
interpret M: monoidal_category_with_alternate_unit
S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<open>\<i>[a]\<close> \<omega> ..
have 1: "M\<^sub>\<omega>.unity = w"
using assms M\<^sub>\<omega>.unity_def S.cod_char S.arr_char
by (metis (no_types, lifting) S.in_homE S\<^sub>\<omega>.\<omega>_in_vhom)
have 2: "M.unity = a"
using assms M.unity_def S.cod_char S.arr_char by simp
have "\<exists>!\<psi>. S.in_hom \<psi> a w \<and> S.iso \<psi> \<and> S.comp \<psi> \<i>[a] = S.comp \<omega> (M.tensor \<psi> \<psi>)"
using assms 1 2 M.unit_unique_upto_unique_iso M.unity_def M\<^sub>\<omega>.unity_def S.cod_char
by simp
show "\<exists>!\<psi>. \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright> \<and> iso \<psi> \<and> \<psi> \<cdot> \<i>[a] = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
proof -
have 1: "\<And>\<psi>. S.in_hom \<psi> a w \<longleftrightarrow> \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright>"
using assms S.in_hom_char S.arr_char
by (metis (no_types, lifting) S.ideD(1) S.w_simps(1) S\<^sub>\<omega>.w_simps(1) in_homE
src_dom trg_dom)
moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.iso \<psi> \<longleftrightarrow> iso \<psi>"
using assms S.in_hom_char S.arr_char S.iso_char by auto
moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> M.tensor \<psi> \<psi> = \<psi> \<star> \<psi>"
using assms S.in_hom_char S.arr_char S.hcomp_def by simp
moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.comp \<psi> \<i>[a] = \<psi> \<cdot> \<i>[a]"
using assms S.in_hom_char S.comp_char by auto
moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.comp \<omega> (M.tensor \<psi> \<psi>) = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
using assms S.in_hom_char S.arr_char S.hcomp_def S.comp_char S.dom_char S.cod_char
by (metis (no_types, lifting) M\<^sub>\<omega>.arr_tensor S\<^sub>\<omega>.\<omega>_simps(1) calculation(3) ext)
ultimately show ?thesis
by (metis (no_types, lifting) M.unit_unique_upto_unique_iso M.unity_def M\<^sub>\<omega>.unity_def
S.\<omega>_in_vhom S.in_homE S\<^sub>\<omega>.\<omega>_in_vhom)
qed
qed
end
diff --git a/thys/Bicategory/Tabulation.thy b/thys/Bicategory/Tabulation.thy
--- a/thys/Bicategory/Tabulation.thy
+++ b/thys/Bicategory/Tabulation.thy
@@ -1,6178 +1,6178 @@
(* Title: Tabulation
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Tabulations"
theory Tabulation
-imports CanonicalIsos InternalAdjunction ConcreteCategory
+imports CanonicalIsos InternalAdjunction
begin
text \<open>
A ``tabulation'' is a kind of bicategorical limit that associates with a 1-cell \<open>r\<close>
a triple \<open>(f, \<rho>, g)\<close>, where \<open>f\<close> and \<open>g\<close> are 1-cells having a common source,
and \<open>\<rho>\<close> is a $2$-cell from \<open>g\<close> to \<open>r \<cdot> f\<close>, such that a certain biuniversal property
is satisfied.
The notion was introduced in a study of bicategories of spans and relations by
Carboni, Kasangian, and Street \cite{carboni-et-al} (hereinafter, ``CKS''),
who named it after a related,
but different notion previously used by Freyd in his study of the algebra of relations.
One can find motivation for the concept of tabulation by considering the problem of
trying to find some kind of universal way of factoring a 1-cell \<open>r\<close>, up to isomorphism,
as the composition \<open>g \<cdot> f\<^sup>*\<close> of a map \<open>g\<close> and the right adjoint \<open>f\<^sup>*\<close> of a map \<open>f\<close>.
In order to be able to express this as a bicategorical limit, CKS consider,
instead of an isomorphism \<open>\<guillemotleft>\<phi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close>, its transpose
\<open>\<rho> : g \<Rightarrow> r \<star> f\<close> under the adjunction \<open>f \<stileturn> f\<^sup>*\<close>.
\<close>
subsection "Definition of Tabulation"
text \<open>
The following locale sets forth the ``signature'' of the data involved in a tabulation,
and establishes some basic facts.
$$\xymatrix{
& \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
\ar[ddl] _{g}
\ar[ddr] ^{f}
\\
\\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
\\
&
}$$
\<close>
locale tabulation_data =
bicategory +
fixes r :: 'a
and \<rho> :: 'a
and f :: 'a
and g :: 'a
assumes ide_base: "ide r"
and ide_leg0: "ide f"
and tab_in_vhom': "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
begin
lemma base_in_hom [intro]:
shows "\<guillemotleft>r : src r \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>"
using ide_base by auto
lemma base_simps [simp]:
shows "ide r" and "arr r"
and "dom r = r" and "cod r = r"
using ide_base by auto
lemma tab_in_hom [intro]:
shows "\<guillemotleft>\<rho> : src f \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
using tab_in_vhom' src_dom [of \<rho>] trg_dom [of \<rho>] base_in_hom apply auto
by (metis arr_cod comp_cod_arr hcomp_simps(1-2) in_hhom_def in_homE src_cod
vseq_implies_hpar(2))
lemma ide_leg1:
shows "ide g"
using tab_in_hom by auto
lemma leg1_in_hom [intro]:
shows "\<guillemotleft>g : src f \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>g : g \<Rightarrow> g\<guillemotright>"
using ide_leg1 apply auto
using tab_in_hom ide_dom [of \<rho>]
apply (elim conjE in_homE) by auto
lemma leg1_simps [simp]:
shows "ide g" and "arr g"
and "src g = src f" and "trg g = trg r"
and "dom g = g"and "cod g = g"
using ide_leg1 leg1_in_hom by auto
lemma tab_simps [simp]:
shows "arr \<rho>" and "src \<rho> = src f" and "trg \<rho> = trg r"
and "dom \<rho> = g" and "cod \<rho> = r \<star> f"
using tab_in_hom by auto
lemma leg0_in_hom [intro]:
shows "\<guillemotleft>f : src f \<rightarrow> src r\<guillemotright>" and "\<guillemotleft>f : f \<Rightarrow> f\<guillemotright>"
using ide_leg0 apply auto
using tab_in_hom ide_cod [of \<rho>] hseq_char [of r f]
apply (elim conjE in_homE) by auto
lemma leg0_simps [simp]:
shows "ide f" and "arr f"
and "trg f = src r"
and "dom f = f" and "cod f = f"
using ide_leg0 leg0_in_hom by auto
text \<open>
The following function, which composes \<open>\<rho>\<close> with a 2-cell \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>\<close> to obtain
a 2-cell \<open>\<guillemotleft>(r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"\<close>,
occurs frequently in the sequel.
\<close>
abbreviation (input) composite_cell
where "composite_cell w \<theta> \<equiv> (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w)"
lemma composite_cell_in_hom:
assumes "ide w" and "\<guillemotleft>w : src u \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
shows "\<guillemotleft>composite_cell w \<theta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
proof (intro comp_in_homI)
show "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
using assms tab_in_hom
apply (elim conjE in_hhomE in_homE)
by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
using assms ide_base ide_leg0 tab_in_hom by fastforce
show "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
using assms ide_base ide_leg0 tab_in_hom hseqI'
apply (elim conjE in_hhomE in_homE)
by (intro hcomp_in_vhom, auto)
qed
text \<open>
We define some abbreviations for various combinations of conditions that occur in the
hypotheses and conclusions of the tabulation axioms.
\<close>
abbreviation (input) uw\<theta>\<omega>
where "uw\<theta>\<omega> u w \<theta> \<omega> \<equiv> ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
abbreviation (input) uw\<theta>\<omega>\<nu>
where "uw\<theta>\<omega>\<nu> u w \<theta> \<omega> \<nu> \<equiv>
ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
(r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> = \<omega>"
abbreviation (input) uw\<theta>w'\<theta>'\<beta>
where "uw\<theta>w'\<theta>'\<beta> u w \<theta> w' \<theta>' \<beta> \<equiv>
ide u \<and> ide w \<and> ide w' \<and>
\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright> \<and>
(r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) = (r \<star> \<theta>') \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
end
text \<open>
CKS define two notions of tabulation.
The first, which they call simply ``tabulation'', is restricted to triples \<open>(f, \<rho>, g)\<close>
where the ``input leg'' \<open>f\<close> is a map, and assumes only a weak form of the biuniversal
property that only applies to \<open>(u, \<omega>, v)\<close> for which u is a map.
The second notion, which they call ``wide tabulation'', concerns arbitrary \<open>(f, \<rho>, g)\<close>,
and assumes a strong form of the biuniversal property that applies to all \<open>(u, \<omega>, v)\<close>.
On its face, neither notion implies the other: ``tabulation'' has the stronger assumption
that \<open>f\<close> is a map, but requires a weaker biuniversal property, and ``wide tabulation''
omits the assumption on \<open>f\<close>, but requires a stronger biuniversal property.
CKS Proposition 1(c) states that if \<open>(f, \<rho>, g)\<close> is a wide tabulation,
then \<open>f\<close> is automatically a map. This is in fact true, but it took me a long time to
reconstruct the details of the proof.
CKS' definition of ``bicategory of spans'' uses their notion ``tabulation'',
presumably because it is only applied in situations where maps are involved and it is more
desirable to have axioms that involve a weaker biuniversal property rather than a stronger one.
However I am more interested in ``wide tabulation'', as it is in some sense the nicer notion,
and since I have had to establish various kinds of preservation results that I don't want
to repeat for both tabulation and wide tabulation, I am using wide tabulation everywhere,
calling it simply ``tabulation''. The fact that the ``input leg'' of a tabulation must
be a map is an essential ingredient throughout.
I have attempted to follow CKS variable naming conventions as much as possible in this
development to avoid confusion when comparing with their paper, even though these are
sometimes at odds with what I have been using elsewhere in this document.
\<close>
locale tabulation =
tabulation_data +
assumes T1: "\<And>u \<omega>.
\<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
and T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
\<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
text \<open>
$$
\textbf{T1:}\qquad\qquad
\xy/u67pt/
\xymatrix{
& {\scriptstyle{{\rm src}~\omega}}
\xlowertwocell[ddddl]{}_{{\rm dom}~\omega\hspace{20pt}}{^\nu}
\xuppertwocell[ddddr]{}^{u}{^\theta}
\ar@ {.>}[dd]^{w}
\\
\\
& \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
\ar[ddl] _{g}
\ar[ddr] ^{f}
\\
\\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
\\
&
}
\endxy
\;\;=\;\;
\xy/u33pt/
\xymatrix{
& \scriptstyle{{\rm src}~\omega} \xtwocell[ddd]{}\omit{^\omega}
\ar[ddl] _{{\rm dom}~\omega}
\ar[ddr] ^{u}
\\
\\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
\\
&
}
\endxy
$$
\<close>
text \<open>
The following definition includes the additional axiom \<open>T0\<close>, which states that
the ``input leg'' \<open>f\<close> is a map.
\<close>
locale tabulation_data_with_T0 =
tabulation_data +
T0: map_in_bicategory V H \<a> \<i> src trg f
begin
abbreviation \<eta> where "\<eta> \<equiv> T0.\<eta>"
abbreviation \<epsilon> where "\<epsilon> \<equiv> T0.\<epsilon>"
text \<open>
If \<open>\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>\<close> is a 2-cell and \<open>f\<close> is a map, then \<open>\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close>,
where \<open>T0.trnr\<^sub>\<epsilon> r \<rho>\<close> is the adjoint transpose of \<open>\<rho>\<close>.
We will show (CKS Proposition 1(d)) that if \<open>\<rho>\<close> is a tabulation,
then \<open>\<psi> = T0.trnr\<^sub>\<epsilon> r \<rho>\<close> is an isomorphism. However, regardless of whether \<open>\<rho>\<close> is a
tabulation, the mapping \<open>\<rho> \<mapsto> \<psi>\<close> is injective, and we can recover \<open>\<rho>\<close> by the formula:
\<open>\<rho> = (\<psi> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)\<close>. The proof requires only \<open>T0\<close> and the ``syntactic''
properties of the tabulation data, and in particular does not require the tabulation
conditions \<open>T1\<close> and \<open>T2\<close>. In case \<open>\<rho>\<close> is in fact a tabulation, then this formula can
be interpreted as expressing that \<open>\<rho>\<close> is obtained by transposing the identity
\<open>\<guillemotleft>g \<star> f\<^sup>* : g \<star> f\<^sup>* \<Rightarrow> g \<star> f\<^sup>*\<guillemotright>\<close> to obtain a 2-cell \<open>\<guillemotleft>T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*) : g \<Rightarrow> (g \<star> f\<^sup>*) \<star> f\<guillemotright>\<close>
(which may be regarded as the canonical tabulation of \<open>g \<star> f\<^sup>*\<close>), and then composing
with the isomorphism \<open>\<guillemotleft>\<psi> \<star> f : (g \<star> f\<^sup>*) \<star> f \<Rightarrow> r \<star> f\<guillemotright>\<close> to obtain a tabulation of \<open>r\<close>.
This fact will end up being very important in establishing the characterization of
bicategories of spans. Strangely, CKS doesn't make any explicit mention of it.
\<close>
lemma rep_in_hom [intro]:
shows "\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>"
proof (unfold T0.trnr\<^sub>\<epsilon>_def, intro comp_in_homI)
show "\<guillemotleft>\<rho> \<star> f\<^sup>* : g \<star> f\<^sup>* \<Rightarrow> (r \<star> f) \<star> f\<^sup>*\<guillemotright>"
using tab_in_hom T0.antipar(1) hseqI' by auto
show "\<guillemotleft>\<a>[r, f, f\<^sup>*] : (r \<star> f) \<star> f\<^sup>* \<Rightarrow> r \<star> f \<star> f\<^sup>*\<guillemotright>"
using T0.antipar(1) T0.antipar(2) by auto
show "\<guillemotleft>r \<star> \<epsilon> : r \<star> f \<star> f\<^sup>* \<Rightarrow> r \<star> src r\<guillemotright>"
using T0.antipar by (intro hcomp_in_vhom, auto)
show "\<guillemotleft>\<r>[r] : r \<star> src r \<Rightarrow> r\<guillemotright>"
by auto
qed
lemma \<rho>_in_terms_of_rep:
shows "\<rho> = (T0.trnr\<^sub>\<epsilon> r \<rho> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
proof -
have "(T0.trnr\<^sub>\<epsilon> r \<rho> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*) =
(\<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon> \<star> f) \<cdot> ((g \<star> f\<^sup>*) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
unfolding T0.trnr\<^sub>\<epsilon>_def T0.trnr\<^sub>\<eta>_def by simp
text \<open>
$$
\xy/u67pt/
\xymatrix{
& \scriptstyle{{\rm src}~g \;=\;{\rm src}~f}
\ar[ddl]_{g} \ar[ddr]^{f} \xtwocell[ddd]{}\omit{^\rho}
&
\\
\\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll]^{r}
\\
& &
}
\endxy
\;\;=\;\;
\xy/u133pt/
\xymatrix{
& & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \ar[dd]
\xtwocell[dddddddl]{}\omit{^\rho}
\xlowertwocell[ddddll]{}_{g}{^{\hspace{20pt}{\rm r}^{-1}[g]}}
\xuppertwocell[ddddrr]{}^{f}{\omit} & &
\xtwocell[dddddddlll]{}\omit{^\epsilon}
\xtwocell[ddddll]{}\omit{^\eta}
\\
& \\
& & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \ar[dd]^{f} \ar[ddll]_{g}
& \\
& & & \\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll]^{r}
& &
\scriptstyle{{\rm src}~r} \ar[ll] \ar[uull]_{f^\ast}
\xuppertwocell[llll]{}^{r}<20>{^{\hspace{20pt}{\rm r}[r]}}
\\
& & \\
& & \\
& & & & \\
}
\endxy
$$
\<close>
also have "... = (\<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
proof -
have "((g \<star> f\<^sup>*) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] = \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f]"
using comp_cod_arr T0.antipar by simp
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> (composite_cell f\<^sup>* \<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
using comp_assoc T0.antipar whisker_right [of "f" "\<r>[r]" "composite_cell f\<^sup>* \<epsilon>"]
by fastforce
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<star> f) \<cdot> ((\<rho> \<star> f\<^sup>*) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot>
(g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
using T0.antipar whisker_right [of "f" "(r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*]" "\<rho> \<star> f\<^sup>*"] comp_assoc
by fastforce
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sup>*] \<star> f) \<cdot>
((\<rho> \<star> f\<^sup>*) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
using T0.antipar whisker_right [of "f" "r \<star> \<epsilon>" "\<a>[r, f, f\<^sup>*]"] comp_assoc by fastforce
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sup>*] \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] \<cdot> (\<rho> \<star> f\<^sup>* \<star> f) \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
proof -
have "((\<rho> \<star> f\<^sup>*) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] = \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] \<cdot> (\<rho> \<star> f\<^sup>* \<star> f)"
using assoc'_naturality [of \<rho> "f\<^sup>*" "f"] T0.antipar by simp
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
(\<a>[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] \<cdot>
((r \<star> f) \<star> \<eta>) \<cdot> (\<rho> \<star> src (f)) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
proof -
have "(\<rho> \<star> f\<^sup>* \<star> f) \<cdot> (g \<star> \<eta>) = ((r \<star> f) \<star> \<eta>) \<cdot> (\<rho> \<star> src (f))"
using comp_arr_dom comp_cod_arr T0.antipar interchange [of \<rho> "g" "f\<^sup>* \<star> f" \<eta>]
interchange [of "r \<star> f" \<rho> \<eta> "src (f)"]
by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] \<cdot>
((r \<star> f) \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
using runit'_naturality [of \<rho>] by simp
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f] \<cdot>
((r \<star> f) \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
proof -
have "(\<a>[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] =
\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
proof -
have "\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] =
(\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
using pentagon' [of r "f" "f\<^sup>*" "f"] T0.antipar iso_inv_iso iso_assoc comp_assoc
invert_side_of_triangle(2)
[of "((\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f])"
"\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f]" "\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>* \<star> f]"]
by fastforce
hence "(\<a>[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] =
((\<a>[r, f, f\<^sup>*] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>*] \<star> f)) \<cdot>
\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
using comp_assoc by simp
also have "... = \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
proof -
have "(\<a>[r, f, f\<^sup>*] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>*] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] =
((r \<star> f \<star> f\<^sup>*) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f]"
using comp_cod_arr comp_assoc iso_assoc comp_arr_inv T0.antipar
whisker_right [of "f" "\<a>[r, f, f\<^sup>*]" "\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>*]"] comp_assoc_assoc'
by simp
also have "... = \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f]"
using comp_cod_arr T0.antipar by auto
finally show ?thesis
using comp_assoc by metis
qed
finally show ?thesis by blast
qed
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> (r \<star> f \<star> \<eta>) \<cdot> \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
proof -
have "((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] = \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f)"
using assoc'_naturality [of r \<epsilon> "f"] by auto
moreover have "\<a>[r, f, f\<^sup>* \<star> f] \<cdot> ((r \<star> f) \<star> \<eta>) = (r \<star> f \<star> \<eta>) \<cdot> \<a>[r, f, src (f)]"
using assoc_naturality [of r "f" \<eta>] T0.antipar by auto
ultimately show ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> (\<epsilon> \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
proof -
have "seq \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] (f \<star> \<eta>)"
using T0.antipar by force
moreover have "seq (\<epsilon> \<star> f) (\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>))"
using T0.antipar by fastforce
ultimately have "(r \<star> \<epsilon> \<star> f) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> (r \<star> f \<star> \<eta>) =
r \<star> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>)"
using T0.antipar whisker_left [of r "\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]" "f \<star> \<eta>"]
whisker_left [of r "\<epsilon> \<star> f" "\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>)"]
by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot>
\<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
using T0.triangle_left by simp
also have "... = ((\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot>
((r \<star> \<r>[f]) \<cdot> \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f]) \<cdot> \<rho>"
using whisker_left [of r "\<l>\<^sup>-\<^sup>1[f]" "\<r>[f]"] comp_assoc by simp
also have "... = ((r \<star> \<l>[f]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot> (\<r>[r \<star> f] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f]) \<cdot> \<rho>"
using triangle' [of r "f"] runit_hcomp [of r "f"] comp_assoc by simp
also have "... = \<rho>"
proof -
have "(r \<star> \<l>[f]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f]) = r \<star> f"
using iso_lunit comp_arr_inv' whisker_left [of r "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] by simp
moreover have "(\<r>[r \<star> f] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f]) = r \<star> f"
using iso_runit inv_is_inverse comp_arr_inv' by auto
ultimately show ?thesis
using comp_cod_arr by simp
qed
finally show ?thesis by simp
qed
end
text \<open>
The following corresponds to what CKS call ``tabulation''; it supposes axiom \<open>T0\<close>,
but involves weaker versions of \<open>T1\<close> and \<open>T2\<close>. I am calling it ``narrow tabulation''.
\<close>
locale narrow_tabulation =
tabulation_data_with_T0 +
assumes T1: "\<And>u \<omega>.
\<lbrakk> is_left_adjoint u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
and T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
\<lbrakk> is_left_adjoint u; ide w; ide w';
\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
text \<open>
The next few locales are used to bundle up some routine consequences of
the situations described by the hypotheses and conclusions of the tabulation axioms,
so we don't have to keep deriving them over and over again in each context,
and also so as to keep the simplification rules oriented consistently with each other.
\<close>
locale uw\<theta> =
tabulation_data +
fixes u :: 'a
and w :: 'a
and \<theta> :: 'a
assumes uw\<theta>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
begin
lemma ide_u:
shows "ide u"
using uw\<theta> by force
lemma u_in_hom [intro]:
shows "\<guillemotleft>u : src u \<rightarrow> src r\<guillemotright>"
using uw\<theta> ide_u ide_cod [of \<theta>] hseq_char [of f w]
apply (intro in_hhomI, simp_all)
by (metis arr_dom leg0_simps(3) in_homE trg_cod trg_dom hcomp_simps(2))
lemma u_simps [simp]:
shows "ide u" and "arr u"
and "trg u = src r"
and "dom u = u" and "cod u = u"
using ide_u u_in_hom by auto
lemma ide_w:
shows "ide w"
using uw\<theta> by auto
lemma w_in_hom [intro]:
shows "\<guillemotleft>w : src u \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>w : w \<Rightarrow> w\<guillemotright>"
proof -
show "\<guillemotleft>w : w \<Rightarrow> w\<guillemotright>"
using ide_w by auto
show "\<guillemotleft>w : src u \<rightarrow> src f\<guillemotright>"
proof
show "arr w" using ide_w by simp
show "src w = src u"
using uw\<theta> ide_dom [of \<theta>] hseq_char [of f w]
by (metis arr_dom in_homE src_cod src_dom hcomp_simps(1))
show "trg w = src f"
using uw\<theta> ide_dom [of \<theta>] hseq_char [of f w]
by (metis arr_dom in_homE)
qed
qed
lemma w_simps [simp]:
shows "ide w" and "arr w"
and "src w = src u" and "trg w = src f"
and "dom w = w" and "cod w = w"
using ide_w w_in_hom by auto
lemma \<theta>_in_hom [intro]:
shows "\<guillemotleft>\<theta> : src u \<rightarrow> src r\<guillemotright>" and "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
proof -
show "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
using uw\<theta> by simp
show "\<guillemotleft>\<theta> : src u \<rightarrow> src r\<guillemotright>"
using uw\<theta> src_dom trg_dom hcomp_simps(1-2) by fastforce
qed
lemma \<theta>_simps [simp]:
shows "arr \<theta>" and "src \<theta> = src u" and "trg \<theta> = src r"
and "dom \<theta> = f \<star> w" and "cod \<theta> = u"
using \<theta>_in_hom by auto
end
locale uw\<theta>\<omega> =
uw\<theta> +
fixes \<omega> :: 'a
assumes uw\<theta>\<omega>: "uw\<theta>\<omega> u w \<theta> \<omega>"
begin
lemma \<omega>_in_hom [intro]:
shows "\<guillemotleft>\<omega> : src w \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
proof -
show "\<guillemotleft>\<omega> : src w \<rightarrow> trg r\<guillemotright>"
using uw\<theta>\<omega> src_cod [of \<omega>] trg_cod [of \<omega>]
apply (elim conjE in_homE)
by simp
show "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
using uw\<theta>\<omega> by auto
qed
lemma \<omega>_simps [simp]:
shows "arr \<omega>" and "src \<omega> = src w" and "trg \<omega> = trg r"
and "cod \<omega> = r \<star> u"
using \<omega>_in_hom by auto
end
locale uw\<theta>\<omega>\<nu> =
uw\<theta> +
fixes \<omega> :: 'a
and \<nu> :: 'a
assumes uw\<theta>\<omega>\<nu>: "uw\<theta>\<omega>\<nu> u w \<theta> \<omega> \<nu>"
begin
lemma \<nu>_in_hom [intro]:
shows "\<guillemotleft>\<nu> : src u \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
proof -
show "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
using uw\<theta>\<omega>\<nu> by auto
show "\<guillemotleft>\<nu> : src u \<rightarrow> trg r\<guillemotright>"
proof
show 1: "arr \<nu>"
using uw\<theta>\<omega>\<nu> by auto
show "src \<nu> = src u"
proof -
have "src \<nu> = src (cod \<nu>)"
using 1 uw\<theta>\<omega>\<nu> src_cod [of \<nu>] by simp
also have "... = src u"
using uw\<theta>\<omega>\<nu> by auto
finally show ?thesis by simp
qed
show "trg \<nu> = trg r"
proof -
have "trg \<nu> = trg (cod \<nu>)"
using 1 uw\<theta>\<omega>\<nu> src_cod [of \<nu>] by simp
also have "... = trg r"
using uw\<theta>\<omega>\<nu> by auto
finally show ?thesis by simp
qed
qed
qed
lemma \<nu>_simps [simp]:
shows "iso \<nu>" and "arr \<nu>" and "src \<nu> = src u" and "trg \<nu> = trg r"
and "cod \<nu> = g \<star> w"
using uw\<theta>\<omega>\<nu> \<nu>_in_hom by auto
sublocale uw\<theta>\<omega>
proof (unfold_locales, intro conjI)
show "ide w"
using uw\<theta>\<omega>\<nu> by simp
show "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
using uw\<theta>\<omega>\<nu> by simp
have "\<guillemotleft>(r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> : dom \<nu> \<Rightarrow> r \<star> u\<guillemotright>"
using ide_base ide_leg0 ide_w by fastforce
thus "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
using uw\<theta>\<omega>\<nu> by auto
qed
end
locale uw\<theta>w'\<theta>' =
tabulation_data V H \<a> \<iota> src trg r \<rho> f g +
uw\<theta>: uw\<theta> V H \<a> \<iota> src trg r \<rho> f g u w \<theta> +
uw'\<theta>': uw\<theta> V H \<a> \<iota> src trg r \<rho> f g u w' \<theta>'
for V :: "'a comp" (infixr "\<cdot>" 55)
and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
and \<iota> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
and src :: "'a \<Rightarrow> 'a"
and trg :: "'a \<Rightarrow> 'a"
and r :: 'a
and \<rho> :: 'a
and f :: 'a
and g :: 'a
and u :: 'a
and w :: 'a
and \<theta> :: 'a
and w' :: 'a
and \<theta>' :: 'a
locale uw\<theta>w'\<theta>'\<gamma> =
uw\<theta>w'\<theta>' +
fixes \<gamma> :: 'a
assumes \<gamma>_in_vhom: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
and "\<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
begin
lemma \<gamma>_in_hom [intro]:
shows "\<guillemotleft>\<gamma> : src u \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
proof -
show "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
using \<gamma>_in_vhom by simp
show "\<guillemotleft>\<gamma> : src u \<rightarrow> src f\<guillemotright>"
proof
show "arr \<gamma>"
using \<gamma>_in_vhom by auto
show "src \<gamma> = src u"
using \<gamma>_in_vhom src_dom [of \<gamma>]
apply (elim in_homE) by simp
show "trg \<gamma> = src f"
using \<gamma>_in_vhom trg_dom [of \<gamma>]
apply (elim in_homE) by simp
qed
qed
lemma \<gamma>_simps [simp]:
shows "arr \<gamma>"
and "src \<gamma> = src u" and "trg \<gamma> = src f"
and "dom \<gamma> = w" and "cod \<gamma> = w'"
using \<gamma>_in_hom by auto
end
locale uw\<theta>w'\<theta>'\<beta> =
uw\<theta>w'\<theta>' +
fixes \<beta> :: 'a
assumes uw\<theta>w'\<theta>'\<beta>: "uw\<theta>w'\<theta>'\<beta> u w \<theta> w' \<theta>' \<beta>"
begin
lemma \<beta>_in_hom [intro]:
shows "\<guillemotleft>\<beta> : src u \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
proof -
show "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
using uw\<theta>w'\<theta>'\<beta> by auto
show "\<guillemotleft>\<beta> : src u \<rightarrow> trg r\<guillemotright>"
using uw\<theta>w'\<theta>'\<beta> src_dom [of \<beta>] trg_dom [of \<beta>] hseq_char [of g w]
apply (elim conjE in_homE) by auto
qed
lemma \<beta>_simps [simp]:
shows "arr \<beta>" and "src \<beta> = src u" and "trg \<beta> = trg r"
and "dom \<beta> = g \<star> w" and "cod \<beta> = g \<star> w'"
using \<beta>_in_hom by auto
end
subsection "Tabulations yield Factorizations"
text \<open>
If \<open>(f, \<rho>, g)\<close> is a (wide) tabulation, then \<open>f\<close> is automatically a map;
this is CKS Proposition 1(c).
The proof sketch provided by CKS is only three lines long, and for a long time I
was only able to prove one of the two triangle identities.
Finally, after gaining a lot of experience with the definitions I saw how to prove
the other.
CKS say nothing about the extra step that seems to be required.
\<close>
context tabulation
begin
text \<open>
The following is used in order to allow us to apply the coherence theorem
to shortcut proofs of equations between canonical arrows.
\<close>
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
lemma satisfies_T0:
shows "is_left_adjoint f"
proof -
text \<open>
The difficulty is filling in details left out by CKS, and accounting for the
fact that they have suppressed unitors and associators everywhere.
In addition, their typography generally uses only parentheses, with no explicit
operation symbols to distinguish between horizontal and vertical composition.
In some cases, for example the statement of T2 in the definition of tabulation,
this makes it difficult for someone not very experienced with the definitions to
reconstruct the correct formulas.
\<close>
text \<open>
CKS say to first apply \<open>T1\<close> with \<open>u = src r\<close>, \<open>v = r\<close>, and \<open>\<rho>' = r\<close>.
However, \<open>\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>\<close>, not \<open>\<guillemotleft>r : r \<Rightarrow> r \<star> src r\<guillemotright>\<close>, so we have to take \<open>\<rho>' = \<r>\<^sup>-\<^sup>1[r]\<close>.
\<close>
obtain f\<^sub>a \<epsilon> \<nu>
where f\<^sub>a: "ide f\<^sub>a \<and> \<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> src r\<guillemotright> \<and> \<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright> \<and> iso \<nu> \<and>
composite_cell f\<^sub>a \<epsilon> \<cdot> \<nu> = \<r>\<^sup>-\<^sup>1[r]"
using T1 [of "src r" "\<r>\<^sup>-\<^sup>1[r]"] runit'_in_hom [of r] ide_base comp_assoc by auto
have f\<^sub>a': "composite_cell f\<^sub>a \<epsilon> \<cdot> \<nu> = \<r>\<^sup>-\<^sup>1[r]"
using f\<^sub>a by simp
have f\<^sub>a: "ide f\<^sub>a \<and> \<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> src r\<guillemotright> \<and> \<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright> \<and> iso \<nu>"
using f\<^sub>a by simp
have 1: "src f\<^sub>a = trg f"
using f\<^sub>a f\<^sub>a' comp_assoc
by (metis arr_inv leg0_simps(3) ide_base in_homE iso_runit seqE src_dom
hcomp_simps(1) vseq_implies_hpar(1))
have 2: "trg f\<^sub>a = src g"
using f\<^sub>a by force
have \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> trg f\<guillemotright> \<and> \<guillemotleft>\<epsilon> : trg f \<rightarrow> trg f\<guillemotright> \<and>
arr \<epsilon> \<and> src \<epsilon> = trg f \<and> trg \<epsilon> = trg f \<and> dom \<epsilon> = f \<star> f\<^sub>a \<and> cod \<epsilon> = trg f"
using f\<^sub>a src_cod [of \<epsilon>] trg_cod [of \<epsilon>] 1 2 by fastforce
have \<nu>: "\<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright> \<and> \<guillemotleft>\<nu> : trg f \<rightarrow> trg g\<guillemotright> \<and>
arr \<nu> \<and> src \<nu> = trg f \<and> trg \<nu> = trg g \<and> dom \<nu> = r \<and> cod \<nu> = g \<star> f\<^sub>a"
using f\<^sub>a by force
text \<open>
Next, CKS say to apply \<open>T2\<close> with \<open>w = trg f\<^sub>a = src f\<close>, \<open>w' = f\<^sub>a \<star> f\<close>, \<open>u = f\<close>,
to obtain the unit and the adjunction conditions, but they don't say explicitly
what to use for \<open>\<theta>\<close>, \<open>\<theta>'\<close>, and \<open>\<beta>\<close>.
We need \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>\<close>;
\emph{i.e.}~\<open>\<guillemotleft>\<theta> : f \<star> trg f\<^sub>a \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : f \<star> f\<^sub>a \<star> f \<Rightarrow> f\<guillemotright>\<close>.
Evidently, we may take \<open>\<theta> = \<rho>[f]\<close> and \<open>\<theta>' = \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]\<close>.
What should be taken for \<open>\<beta>\<close>? Reconstructing this is a little bit more difficult.
\<open>T2\<close> requires \<open>\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>\<close>, hence \<open>\<guillemotleft>\<beta> : g \<star> trg f\<^sub>a \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright>\<close>.
We have the isomorphism \<open>\<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright>\<close> from \<open>T1\<close>. Also \<open>\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>\<close>.
So \<open>\<guillemotleft>\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g] : g \<star> trg f\<^sub>a \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright>\<close>,
suggesting that we take \<open>\<beta> = \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]\<close>.
Now, to apply \<open>T2\<close> we need to satisfy the equation:
\[
\<open>(r \<star> \<theta>) \<cdot> \<a>[r, f, trg f\<^sub>a] \<cdot> (\<rho> \<star> trg f\<^sub>a ) =
(r \<star> \<theta>') \<cdot> \<a>[r, f, f\<^sub>a \<star> f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<beta>\<close>;
\]
that is, with our choice of \<open>\<theta>\<close>, \<open>\<theta>'\<close>, and \<open>\<beta>\<close>:
\<open>(r \<star> \<r>[f]) \<cdot> \<a>[r, f, trg f\<^sub>a] \<cdot> (\<rho> \<star> trg f\<^sub>a ) =
(r \<star> \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f] \<cdot> (\<rho> \<cdot> (f\<^sub>a \<star> f)) \<cdot>
\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]\<close>.
It is not too difficult to get the idea of showing that the left-hand side
is equal to \<open>\<rho> \<cdot> \<r>[g]\<close> (note that \<open>trg f\<^sub>a = src f = src g]\<close> and \<open>trg f = src r\<close>),
so we should also try to prove that the right-hand side is equal to this as well.
What we have to work with is the equation:
\[
\<open>\<r>\<^sup>-\<^sup>1[r] = (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a ) \<cdot> \<nu>\<close>.
\]
After some pondering, I realized that to apply this to the right-hand side of the
equation to be shown requires that we re-associate everything to the left,
so that f stands alone on the right.
\<close>
let ?\<beta> = "\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]"
let ?\<theta> = "\<r>[f]"
let ?\<theta>' = "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]"
have \<beta>: "\<guillemotleft>?\<beta> : g \<star> src g \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright> \<and> \<guillemotleft>?\<beta> : src f \<rightarrow> trg g\<guillemotright> \<and>
src ?\<beta> = src g \<and> trg ?\<beta> = trg g \<and> dom ?\<beta> = g \<star> src g \<and> cod ?\<beta> = g \<star> f\<^sub>a \<star> f"
proof -
have 3: "\<guillemotleft>?\<beta> : g \<star> src g \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright>"
using f\<^sub>a 1 2 by fastforce
moreover have "\<guillemotleft>?\<beta> : src f \<rightarrow> trg g\<guillemotright>"
using 1 2 3 f\<^sub>a by auto
ultimately show ?thesis
by (auto simp add: in_hhom_def)
qed
have \<theta>': "\<guillemotleft>?\<theta>' : f \<star> f\<^sub>a \<star> f \<Rightarrow> f\<guillemotright>"
using f\<^sub>a 1 2 \<epsilon> by fastforce
have A: "composite_cell (trg f\<^sub>a) \<r>[f] = composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> ?\<beta>"
proof -
have "composite_cell (trg f\<^sub>a) \<r>[f] = \<rho> \<cdot> \<r>[g]"
using 2 runit_hcomp runit_naturality [of \<rho>] comp_assoc by simp
also have "... = composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> ?\<beta>"
proof -
have "composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> ?\<beta> =
(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]"
using comp_assoc by simp
also have "... = \<rho> \<cdot> \<r>[g]"
proof -
have "(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) = r \<star> f"
proof -
have "(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) =
\<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu> \<star> f"
proof -
have "(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) =
(r \<star> \<l>[f]) \<cdot> (r \<star> \<epsilon> \<star> f) \<cdot>
composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f))"
using f\<^sub>a 1 2 \<epsilon> hseqI' whisker_left comp_assoc by auto
also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f) \<cdot>
composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f))"
using f\<^sub>a 1 2 comp_assoc by (simp add: triangle')
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot>
composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f))"
proof -
have "\<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f) = ((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f]"
using f\<^sub>a \<epsilon> assoc'_naturality [of r \<epsilon> f] by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
(\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) \<cdot>
\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
proof -
have "(\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot>
composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)) =
(\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
(\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f]) \<cdot>
(\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
by (simp add: comp_assoc)
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
((\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f]) \<cdot>
(\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
proof -
have "\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f] =
(\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f]"
proof -
(* No need to calculate manually, apply the coherence theorem. *)
have "\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f] =
\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
using f\<^sub>a 1 2 \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by auto
also have "... = \<lbrace>(\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
using f\<^sub>a 1 2 by (intro E.eval_eqI, auto)
also have "... = (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f]"
using f\<^sub>a 1 2 \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by auto
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot>
\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
by (simp add: comp_assoc)
finally show ?thesis by blast
qed
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
(\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> ((\<rho> \<star> f\<^sub>a) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sub>a, f] \<cdot>
\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
proof -
have "\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) = ((\<rho> \<star> f\<^sub>a) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sub>a, f]"
using f\<^sub>a 1 2 assoc'_naturality [of \<rho> f\<^sub>a f] by auto
thus ?thesis
by (metis comp_assoc)
qed
also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot>
((\<rho> \<star> f\<^sub>a) \<star> f) \<cdot> (\<nu> \<star> f)"
proof -
have "\<a>\<^sup>-\<^sup>1[g, f\<^sub>a, f] \<cdot> \<a>[g, f\<^sub>a, f] = (g \<star> f\<^sub>a) \<star> f"
using f\<^sub>a 1 2 comp_assoc_assoc' by auto
moreover have "((g \<star> f\<^sub>a) \<star> f) \<cdot> (\<nu> \<star> f) = \<nu> \<star> f"
by (simp add: \<nu> comp_cod_arr hseqI')
ultimately show ?thesis
using comp_assoc by metis
qed
also have "... = (\<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu>) \<star> f"
proof -
have "arr (\<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu>)"
using f\<^sub>a' comp_assoc by auto
thus ?thesis
using whisker_right by fastforce
qed
finally show ?thesis by blast
qed
also have "... = (\<r>[r] \<cdot> \<r>\<^sup>-\<^sup>1[r]) \<star> f"
using f\<^sub>a' comp_assoc by simp
also have "... = r \<star> f"
using ide_base by (simp add: comp_arr_inv')
finally show ?thesis by blast
qed
thus ?thesis
using ide_leg0 ide_leg1 tab_in_hom comp_cod_arr comp_assoc tab_simps(5) arrI
by metis
qed
finally show ?thesis by argo
qed
finally show ?thesis by argo
qed
obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : trg f\<^sub>a \<Rightarrow> f\<^sub>a \<star> f\<guillemotright> \<and> ?\<beta> = g \<star> \<eta> \<and>
(\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> (f \<star> \<eta>) = \<r>[f]"
using \<beta> \<theta>' A 1 2 f\<^sub>a runit_in_hom ide_leg0 ide_hcomp src.preserves_ide
T2 [of "trg f\<^sub>a" "f\<^sub>a \<star> f" "\<r>[f]" f "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]" ?\<beta>] comp_assoc
leg1_simps(3)
by metis
have \<eta>': "?\<beta> = g \<star> \<eta> \<and> (\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> (f \<star> \<eta>) = \<r>[f]"
using \<eta> by simp
have \<eta>: "\<guillemotleft>\<eta> : trg f\<^sub>a \<Rightarrow> f\<^sub>a \<star> f\<guillemotright> \<and> \<guillemotleft>\<eta> : src f \<rightarrow> src f\<guillemotright> \<and>
arr \<eta> \<and> src \<eta> = src f \<and> trg \<eta> = src f \<and> dom \<eta> = trg f\<^sub>a \<and> cod \<eta> = f\<^sub>a \<star> f"
using \<eta> \<beta> 2 by force
have "adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sub>a \<eta> \<epsilon>"
proof
show "ide f" using ide_leg0 by simp
show "ide f\<^sub>a" using f\<^sub>a by blast
show \<eta>_in_hom: "\<guillemotleft>\<eta> : src f \<Rightarrow> f\<^sub>a \<star> f\<guillemotright>"
using \<eta> 2 by simp
show \<epsilon>_in_hom: "\<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> src f\<^sub>a\<guillemotright>"
using f\<^sub>a 1 by simp
show *: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
using ide_leg0 iso_lunit invert_side_of_triangle(1) \<eta>' comp_assoc by auto
text \<open>
We have proved one of the triangle identities; now we have to show the other.
This part, not mentioned by CKS, took me a while to discover.
Apply \<open>T2\<close> again, this time with the following:
\[\begin{array}{l}
\<open>w = src f \<star> f\<^sub>a\<close>,\\
\<open>\<theta> = (\<epsilon> \<star> \<epsilon>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)\<close>,\\
\<open>w' = f\<^sub>a \<star> trg\<close>,\\
\<open>\<theta>' = \<epsilon> \<star> trg f\<close>,\\
\<open>\<beta> = g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]\<close>
\end{array}\]
Then the conditions for \<open>\<gamma>\<close> are satisfied by both
\<open>\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]\<close> and \<open>(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a)\<close> so they are equal,
as required.
\<close>
show "(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a) = \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
proof -
let ?u = "trg f \<star> trg f"
let ?w = "src f \<star> f\<^sub>a"
let ?w' = "f\<^sub>a \<star> trg f"
let ?\<theta> = "(\<epsilon> \<star> \<epsilon>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
let ?\<theta>' = "(\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]"
let ?\<beta> = "g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
let ?\<gamma> = "\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
let ?\<gamma>' = "(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a)"
have \<theta>_eq': "?\<theta> = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
proof -
have "?\<theta> = (trg f \<star> \<epsilon>) \<cdot> (\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a])) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
using interchange [of "trg f" \<epsilon> \<epsilon> "f \<star> f\<^sub>a"] comp_arr_dom comp_cod_arr comp_assoc
by (simp add: \<epsilon>)
also have "... = (trg f \<star> \<epsilon>) \<cdot> (\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
(\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot>
(f \<star> \<eta> \<star> f\<^sub>a)"
proof -
have "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) =
\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]"
proof -
have "(\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> ((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a])) \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) =
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> ide_leg0 iso_inv_iso iso_assoc hseqI'
invert_side_of_triangle(1)
[of "((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a])"
"\<a>\<^sup>-\<^sup>1[f \<star> f\<^sub>a, f, f\<^sub>a]" "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"]
pentagon' comp_assoc by auto
hence "(\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> ((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a])) =
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a])"
using 1 2 \<open>ide f\<^sub>a\<close> iso_inv_iso
invert_side_of_triangle(2)
[of "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]" "\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> ((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a])"
"f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]"]
by auto
thus ?thesis
using comp_assoc by simp
qed
thus ?thesis by simp
qed
also have "... = (trg f \<star> \<epsilon>) \<cdot> ((\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot> \<a>[f \<star> f\<^sub>a, f, f\<^sub>a]) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
using comp_assoc by simp
also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot>
((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
proof -
have "((\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot> \<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a) =
(\<a>[trg f, f, f\<^sub>a] \<cdot> ((\<epsilon> \<star> f) \<star> f\<^sub>a)) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
((f \<star> \<eta>) \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using assoc_naturality [of \<epsilon> f f\<^sub>a] assoc'_naturality [of f \<eta> f\<^sub>a]
by (simp add: 2 \<epsilon> \<eta> \<open>ide f\<^sub>a\<close> comp_assoc)
also have "... = \<a>[trg f, f, f\<^sub>a] \<cdot>
(((\<epsilon> \<star> f) \<star> f\<^sub>a) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((f \<star> \<eta>) \<star> f\<^sub>a)) \<cdot>
\<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using comp_assoc by simp
also have "... = \<a>[trg f, f, f\<^sub>a] \<cdot>
((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using \<eta>' comp_assoc whisker_right \<open>ide f\<^sub>a\<close> comp_null(2) ide_leg0 ext
runit_simps(1)
by metis
finally show ?thesis
using comp_assoc by simp
qed
also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using * by simp
finally show ?thesis by simp
qed
have \<theta>_eq: "?\<theta> = (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> ?\<gamma>)"
proof -
have "?\<theta> = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using \<theta>_eq' by simp
also have "... =
(trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> f\<^sub>a) \<cdot> (\<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using \<open>ide f\<^sub>a\<close> whisker_right comp_assoc by auto
also have "... = (trg f \<star> \<epsilon>) \<cdot> ((\<a>[trg f, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[trg f, f, f\<^sub>a]) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> f\<^sub>a])) \<cdot>
(f \<star> \<l>[f\<^sub>a])"
using 2 \<open>ide f\<^sub>a\<close> lunit_hcomp [of f f\<^sub>a] invert_side_of_triangle(2) triangle'
comp_assoc
by auto
also have "... = (trg f \<star> \<epsilon>) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> f\<^sub>a] \<cdot> (f \<star> \<l>[f\<^sub>a])"
using f\<^sub>a 2 comp_cod_arr iso_assoc comp_arr_inv lunit_hcomp(2) lunit_hcomp(4)
ide_leg0 leg1_simps(3)
by metis
also have "... = \<l>\<^sup>-\<^sup>1[trg f] \<cdot> \<epsilon> \<cdot> (f \<star> \<l>[f\<^sub>a])"
using \<epsilon> lunit'_naturality comp_assoc by metis
also have "... = \<r>\<^sup>-\<^sup>1[trg f] \<cdot> \<epsilon> \<cdot> (f \<star> \<l>[f\<^sub>a])"
using unitor_coincidence by simp
also have "... = (\<epsilon> \<star> trg f) \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> f\<^sub>a] \<cdot> (f \<star> \<l>[f\<^sub>a])"
using \<epsilon> runit'_naturality comp_assoc by metis
also have "... = (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a]) \<cdot> (f \<star> \<l>[f\<^sub>a])"
using 2 \<open>ide f\<^sub>a\<close> runit_hcomp(2) comp_assoc by auto
also have "... = (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> ?\<gamma>)"
using 2 \<open>ide f\<^sub>a\<close> whisker_left by simp
finally show ?thesis by simp
qed
have \<theta>: "\<guillemotleft>?\<theta> : f \<star> ?w \<Rightarrow> ?u\<guillemotright>"
using 1 2 \<open>ide f\<^sub>a\<close> \<eta>_in_hom \<epsilon> hseqI' by fastforce
have \<theta>': "\<guillemotleft>?\<theta>' : f \<star> ?w' \<Rightarrow> ?u\<guillemotright>"
using f\<^sub>a 1 2 \<epsilon> assoc'_in_hom(2) hseqI' by auto
have ww': "ide ?w \<and> ide ?w'"
by (simp add: 1 2 \<open>ide f\<^sub>a\<close>)
have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w \<Rightarrow> ?w'\<guillemotright> \<and> ?\<beta> = g \<star> \<gamma> \<and> ?\<theta> = ?\<theta>' \<cdot> (f \<star> \<gamma>)"
proof -
have "\<guillemotleft>?\<beta> : g \<star> ?w \<Rightarrow> g \<star> ?w'\<guillemotright>"
using \<open>ide f\<^sub>a\<close> 1 2 by auto
moreover have "composite_cell ?w ?\<theta> = composite_cell ?w' ?\<theta>' \<cdot> ?\<beta>"
proof -
have "composite_cell ?w' ?\<theta>' \<cdot> ?\<beta> =
composite_cell ?w ((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]))"
proof -
have "\<a>[r, f, f\<^sub>a \<star> trg f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> trg f) \<cdot> (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) =
composite_cell ?w (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])"
proof -
have "\<a>[r, f, f\<^sub>a \<star> trg f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> trg f) \<cdot> (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) =
(\<a>[r, f, f\<^sub>a \<star> trg f] \<cdot> ((r \<star> f) \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])) \<cdot> (\<rho> \<star> src f \<star> f\<^sub>a)"
proof -
have "(\<rho> \<star> f\<^sub>a \<star> trg f) \<cdot> (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) = \<rho> \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
using interchange [of \<rho> g "f\<^sub>a \<star> trg f" "\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"]
comp_arr_dom comp_cod_arr 1 2 \<open>ide f\<^sub>a\<close>
by simp
also have "... = ((r \<star> f) \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) \<cdot> (\<rho> \<star> src f \<star> f\<^sub>a)"
proof -
have "seq (f\<^sub>a \<star> trg f) (\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])"
using f\<^sub>a 1 2 ww' by auto
thus ?thesis
using interchange comp_arr_dom comp_cod_arr 1 2 \<open>ide f\<^sub>a\<close> hseqI'
by (metis ww' comp_ide_arr dom_comp leg1_simps(3)
lunit_simps(4) tab_simps(1) tab_simps(5))
qed
finally show ?thesis
using comp_assoc by simp
qed
also have "... = composite_cell ?w (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])"
using assoc_naturality [of r f "\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"] 1 2 \<open>ide f\<^sub>a\<close> comp_assoc by simp
finally show ?thesis by simp
qed
hence "composite_cell ?w' ?\<theta>' \<cdot> ?\<beta> =
((r \<star> (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (r \<star> f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])) \<cdot>
\<a>[r, f, src f \<star> f\<^sub>a] \<cdot> (\<rho> \<star> src f \<star> f\<^sub>a)"
using comp_assoc by simp
also have
"... = composite_cell ?w (((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]))"
using whisker_left 1 2 \<open>ide f\<^sub>a\<close> ide_base
by (metis \<open>\<guillemotleft>(\<epsilon> \<star> \<epsilon>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a) :
f \<star> src f \<star> f\<^sub>a \<Rightarrow> trg f \<star> trg f\<guillemotright>\<close>
\<theta>_eq arrI comp_assoc)
finally show ?thesis
using comp_assoc by (simp add: "1")
qed
also have "... = composite_cell ?w ?\<theta>"
using \<theta>_eq by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using ww' \<theta> \<theta>' T2 [of ?w ?w' ?\<theta> ?u ?\<theta>' ?\<beta>] comp_assoc by metis
qed
moreover have "\<guillemotleft>?\<gamma> : ?w \<Rightarrow> ?w'\<guillemotright> \<and> ?\<beta> = g \<star> ?\<gamma> \<and> ?\<theta> = ?\<theta>' \<cdot> (f \<star> ?\<gamma>)"
using 1 2 \<open>ide f\<^sub>a\<close> \<theta>_eq comp_assoc by auto
moreover have "\<guillemotleft>?\<gamma>' : ?w \<Rightarrow> ?w'\<guillemotright> \<and> ?\<beta> = g \<star> ?\<gamma>' \<and> ?\<theta> = ?\<theta>' \<cdot> (f \<star> ?\<gamma>')"
proof (intro conjI)
show "\<guillemotleft>?\<gamma>' : ?w \<Rightarrow> ?w'\<guillemotright>"
using 1 2 f\<^sub>a \<eta>_in_hom \<epsilon>_in_hom by fastforce
show "?\<beta> = g \<star> ?\<gamma>'"
text \<open>
This equation is not immediate.
To show it, we have to recall the properties from the construction of \<open>\<epsilon>\<close> and \<open>\<eta>\<close>.
Use the property of \<open>\<eta>\<close> to replace \<open>g \<star> \<eta> \<star> f\<^sub>a\<close> by a 2-cell involving
\<open>\<epsilon>\<close>, \<open>\<rho>\<close>, and \<open>\<nu>\<close>.
Use the property \<open>(r \<star> \<epsilon>) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu> = \<r>[r]\<close> from the construction of \<open>\<epsilon>\<close> to
eliminate \<open>\<epsilon>\<close> and \<open>\<rho>\<close> in favor of inv \<open>\<nu>\<close> and canonical isomorphisms.
Cancelling \<open>\<nu>\<close> and inv \<open>\<nu>\<close> leaves the canonical 2-cell \<open>g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]\<close>.
\<close>
proof -
have "g \<star> ?\<gamma>' = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (g \<star> \<eta> \<star> f\<^sub>a)"
using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> \<eta> whisker_left
by (metis \<open>\<guillemotleft>?\<gamma>' : ?w \<Rightarrow> ?w'\<guillemotright>\<close> arrI ide_leg1 seqE)
also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (g \<star> \<eta> \<star> f\<^sub>a) \<cdot>
\<a>[g, src f, f\<^sub>a] \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> \<eta> comp_arr_dom hseq_char comp_assoc_assoc'
by simp
also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> ((g \<star> \<eta> \<star> f\<^sub>a) \<cdot>
\<a>[g, src f, f\<^sub>a]) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using comp_assoc by simp
also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot>
(\<a>[g, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> ((g \<star> \<eta>) \<star> f\<^sub>a)) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> \<eta> assoc_naturality [of g \<eta> f\<^sub>a] by simp
also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> \<a>[g, f\<^sub>a \<star> f, f\<^sub>a] \<cdot>
(\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using \<eta>' comp_assoc by simp
also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot>
((g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> \<a>[g, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (\<a>[g, f\<^sub>a, f] \<star> f\<^sub>a)) \<cdot>
((\<nu> \<star> f) \<star> f\<^sub>a) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
proof -
have "\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g] \<star> f\<^sub>a =
(\<a>[g, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((\<nu> \<star> f) \<star> f\<^sub>a) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a)"
using 1 2 \<open>ide f\<^sub>a\<close> \<beta> \<epsilon> \<eta> whisker_right by (metis arrI seqE)
thus ?thesis
using comp_assoc by simp
qed
also have "... = ((g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot>
\<a>[g, f\<^sub>a, f \<star> f\<^sub>a]) \<cdot> (\<a>[g \<star> f\<^sub>a, f, f\<^sub>a] \<cdot>
((\<nu> \<star> f) \<star> f\<^sub>a)) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> pentagon comp_assoc by simp
also have "... = (\<a>[g, f\<^sub>a, trg f] \<cdot> ((g \<star> f\<^sub>a) \<star> \<epsilon>)) \<cdot>
((\<nu> \<star> f \<star> f\<^sub>a) \<cdot> \<a>[r, f, f\<^sub>a]) \<cdot>
(\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> assoc_naturality [of g f\<^sub>a \<epsilon>] assoc_naturality [of \<nu> f f\<^sub>a]
by (simp add: \<epsilon> \<nu>)
also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> (((g \<star> f\<^sub>a) \<star> \<epsilon>) \<cdot> (\<nu> \<star> f \<star> f\<^sub>a)) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot>
(\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> assoc_naturality [of g f\<^sub>a \<epsilon>] assoc_naturality [of \<nu> f f\<^sub>a]
comp_assoc
by simp
also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> (\<nu> \<star> trg f) \<cdot>
composite_cell f\<^sub>a \<epsilon> \<cdot>
(\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
proof -
have "((g \<star> f\<^sub>a) \<star> \<epsilon>) \<cdot> (\<nu> \<star> f \<star> f\<^sub>a) = \<nu> \<star> \<epsilon>"
using 1 2 \<open>ide f\<^sub>a\<close> \<nu> \<epsilon> interchange [of "g \<star> f\<^sub>a" \<nu> \<epsilon> "f \<star> f\<^sub>a"]
comp_arr_dom comp_cod_arr
by simp
also have "... = (\<nu> \<star> trg f) \<cdot> (r \<star> \<epsilon>)"
using \<open>ide f\<^sub>a\<close> \<nu> \<epsilon> interchange [of \<nu> r "trg f" \<epsilon>] comp_arr_dom comp_cod_arr
by simp
finally show ?thesis
using comp_assoc by simp
qed
also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> ((((\<nu> \<star> trg f) \<cdot> \<r>\<^sup>-\<^sup>1[r]) \<cdot> inv \<nu>) \<cdot> (\<r>[g] \<star> f\<^sub>a)) \<cdot>
\<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using ide_base f\<^sub>a' comp_assoc f\<^sub>a runit'_simps(1) invert_side_of_triangle(2)
comp_assoc
by presburger
also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> \<r>\<^sup>-\<^sup>1[g \<star> f\<^sub>a] \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
proof -
have "((\<nu> \<star> trg f) \<cdot> \<r>\<^sup>-\<^sup>1[r]) \<cdot> inv \<nu> = \<r>\<^sup>-\<^sup>1[g \<star> f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> \<nu> ide_base runit'_naturality [of \<nu>] comp_arr_dom
by (metis f\<^sub>a ide_compE inv_is_inverse inverse_arrowsE comp_assoc
runit'_simps(1) runit'_simps(4))
thus ?thesis
using comp_assoc by simp
qed
also have "... = ((\<a>[g, f\<^sub>a, trg f] \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sub>a, src f\<^sub>a]) \<cdot>
(g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a])) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
using f\<^sub>a "2" runit_hcomp \<open>ide f\<^sub>a\<close> comp_assoc by simp
also have "... = (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a]) \<cdot> (g \<star> \<l>[f\<^sub>a])"
using 1 2 comp_cod_arr \<open>ide f\<^sub>a\<close> comp_assoc_assoc' hseqI' triangle' by simp
also have "... = ?\<beta>"
using 2 \<open>ide f\<^sub>a\<close> whisker_left by simp
finally show ?thesis by simp
qed
show "?\<theta> = ?\<theta>' \<cdot> (f \<star> ?\<gamma>')"
proof -
have "((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (f \<star> (f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a)) =
((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (f \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> \<eta> whisker_left
by (metis \<open>\<guillemotleft>(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a) : src f \<star> f\<^sub>a \<Rightarrow> f\<^sub>a \<star> trg f\<guillemotright>\<close>
arrI ide_leg0 seqE)
also have
"... = (\<epsilon> \<star> trg f) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f] \<cdot> (f \<star> f\<^sub>a \<star> \<epsilon>)) \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
using comp_assoc by simp
also have "... = ((\<epsilon> \<star> trg f) \<cdot> ((f \<star> f\<^sub>a) \<star> \<epsilon>)) \<cdot>
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot>
(f \<star> \<eta> \<star> f\<^sub>a)"
using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> assoc'_naturality [of f f\<^sub>a \<epsilon>] comp_assoc by simp
also have "... = (trg f \<star> \<epsilon>) \<cdot> (\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
(\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a])) \<cdot>
(f \<star> \<eta> \<star> f\<^sub>a)"
using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> interchange [of \<epsilon> "f \<star> f\<^sub>a" "trg f" \<epsilon>]
interchange [of "trg f" \<epsilon> \<epsilon> "f \<star> f\<^sub>a"] comp_arr_dom comp_cod_arr comp_assoc
by simp
also have "... = (trg f \<star> \<epsilon>) \<cdot> ((\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
(\<a>[f \<star> f\<^sub>a, f, f\<^sub>a]) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot>
(f \<star> \<eta> \<star> f\<^sub>a))"
proof -
have "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) =
\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]"
proof -
have A: "(\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) =
\<a>\<^sup>-\<^sup>1[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> pentagon' comp_assoc by fastforce
hence B: "\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot>
(f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) =
\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
using A 1 2 \<open>ide f\<^sub>a\<close> iso_inv_iso
invert_side_of_triangle(1)
[of "(\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a])"
"\<a>\<^sup>-\<^sup>1[f \<star> f\<^sub>a, f, f\<^sub>a]" "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"]
by auto
show ?thesis
proof -
have C: "iso (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a])"
using 1 2 \<open>ide f\<^sub>a\<close> iso_inv_iso by simp
moreover have "inv (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) = f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]"
using C 1 2 inv_hcomp [of f "\<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]"]
\<open>ide f\<^sub>a\<close> iso_assoc' assoc'_eq_inv_assoc
by fastforce
ultimately show ?thesis
using B 1 2 \<open>ide f\<^sub>a\<close> comp_assoc
invert_side_of_triangle(2)
[of "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
"\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]"
"f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]"]
by simp
qed
qed
thus ?thesis
using comp_assoc by simp
qed
also have "... = (trg f \<star> \<epsilon>) \<cdot> (\<a>[trg f, f, f\<^sub>a] \<cdot>
((\<epsilon> \<star> f) \<star> f\<^sub>a)) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> \<open>ide f\<close> \<eta> \<epsilon> assoc_naturality [of \<epsilon> f f\<^sub>a]
assoc'_naturality [of f \<eta> f\<^sub>a] comp_assoc
by simp
also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot>
(((\<epsilon> \<star> f) \<star> f\<^sub>a) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((f \<star> \<eta>) \<star> f\<^sub>a)) \<cdot>
\<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using comp_assoc by simp
also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot>
((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
\<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using 1 2 \<open>ide f\<^sub>a\<close> \<open>ide f\<close> \<eta> \<epsilon> whisker_right
by (metis (full_types) * \<theta> \<theta>_eq' arrI hseqE seqE)
also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
using * by simp
also have "... = ?\<theta>"
using \<theta>_eq' by simp
finally show ?thesis by simp
qed
qed
ultimately show "?\<gamma>' = ?\<gamma>" by blast
qed
qed
thus ?thesis
using adjoint_pair_def by auto
qed
sublocale tabulation_data_with_T0
using satisfies_T0 by (unfold_locales, simp)
sublocale narrow_tabulation
using adjoint_pair_antipar(1) T1 T2
by (unfold_locales, auto)
end
text \<open>
A tabulation \<open>(f, \<rho>, g)\<close> of \<open>r\<close> yields an isomorphism \<open>\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close>
via adjoint transpose.
The proof requires \<open>T0\<close>, in order to obtain \<open>\<psi>\<close> as the transpose of \<open>\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>\<close>.
However, it uses only the weaker versions of \<open>T1\<close> and \<open>T2\<close>.
\<close>
context narrow_tabulation
begin
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
text \<open>
The following is CKS Proposition 1(d), with the statement refined to incorporate
the canonical isomorphisms that they omit.
Note that we can easily show using \<open>T1\<close> that there is some 1-cell \<open>f\<^sub>a\<close> and isomorphism \<open>\<psi>\<close>
such that \<open>\<guillemotleft>\<psi> : f \<star> f\<^sub>a \<Rightarrow> r\<guillemotright>\<close> (this was already part of the proof that a tabulation
satisfies \<open>T0\<close>). The more difficult content in the present result is that we may
actually take \<open>f\<^sub>a\<close> to be the left adjoint \<open>f\<^sup>*\<close> of \<open>f\<close>.
\<close>
lemma yields_isomorphic_representation:
shows "\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso (T0.trnr\<^sub>\<epsilon> r \<rho>)"
proof -
text \<open>
As stated in CKS, the first step of the proof is:
\begin{quotation}
``Apply \<open>T1\<close> with \<open>X = A\<close>, \<open>u = 1\<^sub>A\<close>, \<open>v = r\<close>, \<open>\<omega> = 1\<^sub>R\<close>, to obtain \<open>f'\<close>, \<open>\<theta>': ff' \<Rightarrow> 1\<^sub>A\<close>,
\<open>\<nu> : r \<simeq> g f'\<close> with \<open>1\<^sub>R = (r\<theta>')(\<rho>f')\<nu>\<close>.''
\end{quotation}
In our nomenclature: \<open>X = trg f\<close>, \<open>u = trg f\<close>, \<open>v = r\<close>, but \<open>\<omega> = src f\<close>
does not make any sense, since we need \<open>\<guillemotleft>\<omega> : v \<Rightarrow> r \<star> u\<guillemotright>\<close>. We have to take \<open>\<omega> = \<r>\<^sup>-\<^sup>1[r]\<close>.
It is not clear whether this is a typo, or whether it is a consequence of CKS having
suppressed all canonical isomorphisms (unitors, in this case). The resulting equation
obtained via T1 is:
\[
\<open>\<r>\<^sup>-\<^sup>1[r] = (r \<star> \<theta>') \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>\<close>,
\]
which has \<open>\<r>\<^sup>-\<^sup>1[r]\<close> on the left-hand side, rather than \<open>1\<^sub>R\<close>, as in CKS.
Also, we have inserted the omitted associativity.
\<close>
obtain w \<theta>' \<nu> where w\<theta>'\<nu>: "ide w \<and> \<guillemotleft>\<theta>' : f \<star> w \<Rightarrow> src r\<guillemotright> \<and> \<guillemotleft>\<nu> : r \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
composite_cell w \<theta>' \<cdot> \<nu> = \<r>\<^sup>-\<^sup>1[r]"
using ide_base obj_is_self_adjoint T1 [of "src r" "\<r>\<^sup>-\<^sup>1[r]"] comp_assoc by auto
interpret uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g \<open>src r\<close> w \<theta>' \<open>\<r>\<^sup>-\<^sup>1[r]\<close> \<nu>
using ide_base tab_in_hom w\<theta>'\<nu> comp_assoc by (unfold_locales, auto)
text \<open>
CKS now say:
\begin{quotation}
``Apply \<open>T2\<close> with \<open>u = 1\<^sub>A\<close>, \<open>w = f\<^sup>*\<close>, \<open>w' = f'\<close>, \<open>\<theta> = \<epsilon>: ff\<^sup>* \<Rightarrow> 1\<close>, \<open>\<theta>': ff' \<Rightarrow> 1\<close>,
\<open>\<beta> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>*)\<close> to obtain \<open>\<gamma> : f\<^sup>* \<Rightarrow> f'\<close> with \<open>g\<gamma> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>*)\<epsilon> = \<theta>'(f\<gamma>).\<close>''
\end{quotation}
The last equation is mysterious, but upon consideration one eventually realizes
that it is definitely a typo, and what is meant is ``\<open>g\<gamma> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>*)\<close>, \<open>\<epsilon> = \<theta>'(f\<gamma>)\<close>''.
So, we take \<open>u = trg f\<close>, \<open>w = f\<^sup>*\<close>, \<open>w' = w\<close>, \<open>\<theta>'\<close> as obtained from \<open>T1\<close>, \<open>\<theta> = \<epsilon>\<close>,
and \<open>\<beta> = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot> (\<rho> \<star> f\<^sup>*)\<close>.
(CKS mention neither the unitor term \<open>\<r>[r]\<close> nor the associativity \<open>\<a>[r, f, f\<^sup>*]\<close>
which are required for the expression for \<open>\<beta>\<close> to make sense.)
\<close>
let ?\<psi> = "\<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon>"
show \<psi>_in_hom: "\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>"
using ide_base T0.trnr\<^sub>\<epsilon>_def rep_in_hom by simp
have A: "\<guillemotleft>\<nu> \<cdot> ?\<psi> : g \<star> f\<^sup>* \<Rightarrow> g \<star> w\<guillemotright>"
using ide_base T0.antipar hseq_char T0.trnr\<^sub>\<epsilon>_def rep_in_hom w\<theta>'\<nu> by auto
have B: "composite_cell f\<^sup>* \<epsilon> = composite_cell w \<theta>' \<cdot> \<nu> \<cdot> ?\<psi>"
using ide_base T0.antipar w\<theta>'\<nu> comp_assoc
by (metis A arrI invert_side_of_triangle(1) iso_runit)
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : f\<^sup>* \<Rightarrow> w\<guillemotright> \<and> \<nu> \<cdot> ?\<psi> = g \<star> \<gamma> \<and> \<epsilon> = \<theta>' \<cdot> (f \<star> \<gamma>)"
using A B T0.counit_in_hom obj_is_self_adjoint T0.antipar comp_assoc
T2 [of "trg f" "f\<^sup>*" w \<epsilon> \<theta>' "\<nu> \<cdot> \<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon>"]
by auto
have trg_\<gamma>_eq: "trg \<gamma> = trg w"
using \<gamma> by fastforce
text \<open>
CKS say:
\begin{quotation}
``The last equation implies \<open>\<gamma>: f\<^sup>* \<Rightarrow> f'\<close> is a split monic (coretraction), while
the calculation:
\begin{eqnarray*}
\<open>(g\<gamma>)(gf\<^sup>*\<theta>')(g\<eta>f')\<close> &\<open>=\<close>& \<open>\<nu>(r\<epsilon>)(\<rho>f\<^sup>*)(gf\<^sup>*\<theta>')(g\<eta>f')\<close>\\
&\<open>=\<close>& \<open>\<nu>(r\<epsilon>)(rff\<^sup>*\<theta>')(\<rho>f\<^sup>*ff')(g\<eta>f')\<close>\\
&\<open>=\<close>& \<open>\<nu>(r\<theta>')(r\<epsilon>ff')(rf\<eta>f')(\<rho>f')\<close>\\
&\<open>=\<close>& \<open>\<nu>(r\<theta>')(\<rho>f') = 1\<^sub>g\<^sub>f\<^sub>'\<close>,
\end{eqnarray*}
shows that \<open>g\<gamma>\<close> is a split epic. So \<open>g\<gamma> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>*): gf\<^sup>* \<Rightarrow> gf'\<close> is invertible.
So \<open>(r\<epsilon>)(\<rho>f\<^sup>*) = \<nu>\<^sup>-\<^sup>1(g\<gamma>)\<close> is invertible.''
\end{quotation}
We carry out the indicated calculations, inserting where required the canonical
isomorphisms omitted by CKS. It is perhaps amusing to compare the four-line sketch
given by CKS with the formalization below, but note that we have carried out the
proof in full, with no hand waving about units or associativities.
\<close>
have "section (g \<star> \<gamma>)"
proof
have "(g \<star> \<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (g \<star> \<gamma>) = g \<star> f\<^sup>*"
proof -
have "(\<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> \<gamma> = f\<^sup>*"
proof -
have "(\<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> \<gamma> =
(\<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w)) \<cdot> \<l>\<^sup>-\<^sup>1[w] \<cdot> \<gamma>"
using comp_assoc by auto
also have "... = (\<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w]) \<cdot> ((\<eta> \<star> w) \<cdot> (trg w \<star> \<gamma>)) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>*]"
using \<gamma> trg_\<gamma>_eq lunit'_naturality [of \<gamma>] comp_assoc by auto
also have "... = \<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> (\<a>[f\<^sup>*, f, w] \<cdot> ((f\<^sup>* \<star> f) \<star> \<gamma>)) \<cdot> (\<eta> \<star> f\<^sup>*) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>*]"
proof -
have "(\<eta> \<star> w) \<cdot> (trg w \<star> \<gamma>) = \<eta> \<star> \<gamma>"
using A \<gamma> interchange comp_arr_dom comp_cod_arr
by (metis T0.unit_simps(1-2) comp_ide_arr seqI' uw\<theta> w_in_hom(2) w_simps(4))
also have "... = ((f\<^sup>* \<star> f) \<star> \<gamma>) \<cdot> (\<eta> \<star> f\<^sup>*)"
using \<gamma> interchange comp_arr_dom comp_cod_arr T0.antipar T0.unit_simps(1,3)
in_homE
by metis
finally show ?thesis
using comp_assoc by simp
qed
also have "... = \<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> ((f\<^sup>* \<star> f \<star> \<gamma>) \<cdot> \<a>[f\<^sup>*, f, f\<^sup>*]) \<cdot> (\<eta> \<star> f\<^sup>*) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>*]"
using \<gamma> assoc_naturality [of "f\<^sup>*" f \<gamma>] trg_\<gamma>_eq T0.antipar by auto
also have "... = \<r>[f\<^sup>*] \<cdot> ((f\<^sup>* \<star> \<epsilon>) \<cdot> \<a>[f\<^sup>*, f, f\<^sup>*] \<cdot> (\<eta> \<star> f\<^sup>*)) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>*]"
using \<gamma> whisker_left trg_\<gamma>_eq hseqI' T0.antipar comp_assoc by auto
also have "... = \<r>[f\<^sup>*] \<cdot> (\<r>\<^sup>-\<^sup>1[f\<^sup>*] \<cdot> \<l>[f\<^sup>*]) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>*]"
using T0.triangle_right by simp
also have "... = f\<^sup>*"
using comp_assoc by (simp add: comp_arr_dom comp_arr_inv')
finally show ?thesis by blast
qed
thus ?thesis
using \<gamma> whisker_left [of g "\<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]" \<gamma>]
hseqI' T0.antipar
by simp
qed
thus "ide ((g \<star> \<r>[f\<^sup>*] \<cdot> (f\<^sup>* \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (g \<star> \<gamma>))"
using T0.antipar by simp
qed
moreover have "retraction (g \<star> \<gamma>)"
proof
have "\<guillemotleft>(g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) :
g \<star> w \<Rightarrow> g \<star> w\<guillemotright>"
using \<gamma> T0.antipar hseq_char
by (intro comp_in_hom_simp, auto)
hence **: "arr ((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]))"
by auto
show "ide ((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]))"
proof -
have "((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])) =
g \<star> w"
proof -
have "((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])) =
\<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<a>[src f\<^sup>*, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
(\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
proof -
have "(g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) =
(\<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot> (\<rho> \<star> f\<^sup>*)) \<cdot>
(g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
using \<gamma> by auto
also have "... =
\<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot>
((\<rho> \<star> f\<^sup>*) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>')) \<cdot>
(g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
using comp_assoc by simp
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot>
(((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>') \<cdot> (\<rho> \<star> f\<^sup>* \<star> f \<star> w)) \<cdot>
(g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
proof -
have "(\<rho> \<star> f\<^sup>*) \<cdot> (g \<star> \<r>[f\<^sup>*]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') =
((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> (\<rho> \<star> f\<^sup>* \<star> src f\<^sup>*) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>')"
proof -
have "(\<rho> \<star> f\<^sup>*) \<cdot> (g \<star> \<r>[f\<^sup>*]) = ((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> (\<rho> \<star> f\<^sup>* \<star> src f\<^sup>*)"
using tab_in_hom comp_arr_dom comp_cod_arr T0.antipar(1) interchange
by (metis T0.ide_right in_homE runit_simps(1,4-5))
thus ?thesis
by (metis comp_assoc)
qed
also have "... = ((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> (\<rho> \<star> f\<^sup>* \<star> \<theta>')"
using comp_arr_dom comp_cod_arr hseqI' T0.antipar
interchange [of \<rho> g "f\<^sup>* \<star> src f\<^sup>*" "f\<^sup>* \<star> \<theta>'"]
by simp
also have "... = ((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>') \<cdot> (\<rho> \<star> f\<^sup>* \<star> f \<star> w)"
using comp_arr_dom comp_cod_arr hseqI' T0.antipar
interchange [of "r \<star> f" \<rho> "f\<^sup>* \<star> \<theta>'" "f\<^sup>* \<star> f \<star> w"]
by simp
finally show ?thesis by simp
qed
also have "... =
\<nu> \<cdot> \<r>[r] \<cdot>
((r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>')) \<cdot>
((\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w)) \<cdot>
(g \<star> \<l>\<^sup>-\<^sup>1[w])"
using comp_assoc by simp
also have "... = \<nu> \<cdot> \<r>[r] \<cdot>
((r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]) \<cdot>
(((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)) \<cdot>
(g \<star> \<l>\<^sup>-\<^sup>1[w])"
proof -
have 1: "(r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>') =
(r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
proof -
have "(r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>*]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>') =
(r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>*]) \<cdot> \<a>[r, f, f\<^sup>* \<star> src f\<^sup>*] \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>')"
proof -
have "\<a>[r, f, f\<^sup>*] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>*]) = (r \<star> f \<star> \<r>[f\<^sup>*]) \<cdot> \<a>[r, f, f\<^sup>* \<star> src f\<^sup>*]"
using assoc_naturality [of r f "\<r>[f\<^sup>*]"] T0.antipar by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>*]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>') \<cdot>
\<a>[r, f, f\<^sup>* \<star> f \<star> w]"
using assoc_naturality [of r f "f\<^sup>* \<star> \<theta>'"] T0.antipar by force
also have "... = (r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*]) \<cdot>
(r \<star> f \<star> f\<^sup>* \<star> \<theta>') \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
proof -
have "(r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>*]) =
(r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*])"
proof -
have "(r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>*]) = r \<star> (\<epsilon> \<cdot> (f \<star> \<r>[f\<^sup>*]))"
using whisker_left hseqI' T0.antipar by simp
also have "... =
(r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*])"
proof -
have "\<epsilon> \<cdot> (f \<star> \<r>[f\<^sup>*]) = \<r>[src f\<^sup>*] \<cdot> (\<epsilon> \<star> src f\<^sup>*) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*]"
using ide_leg0 T0.antipar runit_hcomp invert_side_of_triangle(2)
hseqI' runit_naturality comp_assoc
by (metis (no_types, lifting) T0.counit_simps(1-4) T0.ide_right)
thus ?thesis
using whisker_left hseqI' T0.antipar by simp
qed
finally show ?thesis by simp
qed
thus ?thesis using comp_assoc by metis
qed
also have "... =
(r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot>
((r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>')) \<cdot>
\<a>[r, f, f\<^sup>* \<star> f \<star> w]"
using comp_assoc by simp
also have "... = (r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot>
((r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w])) \<cdot>
\<a>[r, f, f\<^sup>* \<star> f \<star> w]"
proof -
have "(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>') =
(r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w])"
proof -
have "(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>') =
r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, src f\<^sup>*] \<cdot> (f \<star> f\<^sup>* \<star> \<theta>')"
using whisker_left hseqI' T0.antipar by simp
also have "... = r \<star> ((f \<star> f\<^sup>*) \<star> \<theta>') \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]"
using assoc'_naturality [of f "f\<^sup>*" \<theta>'] T0.antipar by auto
also have "... = (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w])"
using whisker_left hseqI' T0.antipar by auto
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = (r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
using comp_assoc by simp
also have "... =
(r \<star> \<r>[src f\<^sup>*]) \<cdot> ((r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>')) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
using comp_assoc by simp
also have "... = (r \<star> \<r>[src f\<^sup>*]) \<cdot> ((r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
proof -
have "(r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') =
(r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)"
proof -
have "(r \<star> \<epsilon> \<star> src f\<^sup>*) \<cdot> (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') =
r \<star> (\<epsilon> \<star> src f\<^sup>*) \<cdot> ((f \<star> f\<^sup>*) \<star> \<theta>')"
using whisker_left hseqI' T0.antipar by simp
also have "... = r \<star> \<epsilon> \<star> \<theta>'"
using interchange [of \<epsilon> "f \<star> f\<^sup>*" "src f\<^sup>*" \<theta>']
T0.antipar comp_arr_dom comp_cod_arr
by auto
also have "... = r \<star> (src f\<^sup>* \<star> \<theta>') \<cdot> (\<epsilon> \<star> f \<star> w)"
using interchange [of "src f\<^sup>*" \<epsilon> \<theta>' "f \<star> w"]
T0.antipar comp_arr_dom comp_cod_arr
by auto
also have "... = (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)"
using whisker_left hseqI' T0.antipar by simp
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = (r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
using comp_assoc by simp
finally show ?thesis by simp
qed
have 2: "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) =
((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
proof -
have "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) =
((\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w])) \<cdot> (g \<star> \<eta> \<star> w)"
using comp_assoc by simp
also have "... = (((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (\<rho> \<star> (f\<^sup>* \<star> f) \<star> w)) \<cdot> (g \<star> \<eta> \<star> w)"
proof -
have "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) =
((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (\<rho> \<star> (f\<^sup>* \<star> f) \<star> w)"
proof -
have "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) =
\<rho> \<cdot> g \<star> (f\<^sup>* \<star> f \<star> w) \<cdot> \<a>[f\<^sup>*, f, w]"
using interchange T0.antipar by auto
also have "... = \<rho> \<star> \<a>[f\<^sup>*, f, w]"
using comp_arr_dom comp_cod_arr T0.antipar by auto
also have "... = (r \<star> f) \<cdot> \<rho> \<star> \<a>[f\<^sup>*, f, w] \<cdot> ((f\<^sup>* \<star> f) \<star> w)"
using comp_arr_dom comp_cod_arr T0.antipar by auto
also have "... = ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (\<rho> \<star> (f\<^sup>* \<star> f) \<star> w)"
using interchange T0.antipar by auto
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (\<rho> \<star> (f\<^sup>* \<star> f) \<star> w) \<cdot> (g \<star> \<eta> \<star> w)"
using comp_assoc by simp
also have "... = ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
proof -
have "(\<rho> \<star> (f\<^sup>* \<star> f) \<star> w) \<cdot> (g \<star> \<eta> \<star> w) = ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
proof -
have "(\<rho> \<star> (f\<^sup>* \<star> f) \<star> w) \<cdot> (g \<star> \<eta> \<star> w) = \<rho> \<cdot> g \<star> (f\<^sup>* \<star> f) \<cdot> \<eta> \<star> w \<cdot> w"
proof -
have "\<guillemotleft>g \<star> \<eta> \<star> w : g \<star> trg w \<star> w \<Rightarrow> g \<star> (f\<^sup>* \<star> f) \<star> w\<guillemotright>"
by (intro hcomp_in_vhom, auto)
thus ?thesis
using interchange whisker_right T0.antipar by auto
qed
also have "... = (r \<star> f) \<cdot> \<rho> \<star> \<eta> \<cdot> trg w \<star> w \<cdot> w"
using comp_arr_dom comp_cod_arr by auto
also have "... = ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
using interchange [of "r \<star> f" \<rho> "\<eta> \<star> w" "trg w \<star> w"]
interchange [of \<eta> "trg w" w w]
comp_arr_dom comp_cod_arr T0.unit_in_hom hseqI'
by auto
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
show ?thesis
using 1 2 by simp
qed
also have "... =
\<nu> \<cdot> \<r>[r] \<cdot>
((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
((r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w])) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]) \<cdot>
(((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
(\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot>
(r \<star> (f \<star> \<eta>) \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w]) \<cdot>
(\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
proof -
have 3: "r \<star> \<epsilon> \<star> f \<star> w =
(r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w])"
proof -
have "r \<star> \<epsilon> \<star> f \<star> w =
((r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[src r, f, w])) \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)"
using T0.antipar whisker_left [of r "\<a>[src r, f, w]" "\<a>\<^sup>-\<^sup>1[src r, f, w]"]
comp_cod_arr hseqI' comp_assoc_assoc'
by simp
also have "... = (r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w])"
using assoc'_naturality [of \<epsilon> f w]
whisker_left [of r "\<a>\<^sup>-\<^sup>1[src r, f, w]" "\<epsilon> \<star> f \<star> w"]
whisker_left comp_assoc hseqI' T0.antipar
by simp
finally show ?thesis
using T0.antipar by simp
qed
have 4: "(r \<star> f) \<star> \<eta> \<star> w =
\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot>
(r \<star> (f \<star> \<eta>) \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w]"
proof -
have "(r \<star> f) \<star> \<eta> \<star> w =
(\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot>
((r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w])) \<cdot>
\<a>[r, f, (f\<^sup>* \<star> f) \<star> w]) \<cdot>
((r \<star> f) \<star> \<eta> \<star> w)"
proof -
have "ide r" by simp
moreover have "seq \<a>[f, f\<^sup>* \<star> f, w] \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]"
using T0.antipar comp_cod_arr hseqI' ide_base by simp
ultimately have "(r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]) =
r \<star> \<a>[f, f\<^sup>* \<star> f, w] \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]"
using whisker_left by metis
thus ?thesis
using T0.antipar comp_cod_arr hseqI' comp_assoc_assoc' by simp
qed
also have "... =
\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot>
(r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]) \<cdot>
(r \<star> f \<star> \<eta> \<star> w)) \<cdot>
\<a>[r, f, trg w \<star> w]"
using assoc_naturality [of r f "\<eta> \<star> w"] hseqI' comp_assoc by fastforce
also have "... =
\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot>
(r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> (r \<star> (f \<star> \<eta>) \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
\<a>[r, f, trg w \<star> w]"
using assoc'_naturality [of f \<eta> w] hseqI' T0.antipar comp_assoc
whisker_left [of r "\<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]" "f \<star> \<eta> \<star> w"]
whisker_left [of r "(f \<star> \<eta>) \<star> w" "\<a>\<^sup>-\<^sup>1[f, trg w, w]"]
by simp
finally show ?thesis by blast
qed
show ?thesis
using 3 4 T0.antipar by simp
qed
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
(r \<star> \<a>[src r, f, w]) \<cdot>
((r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot>
((r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot>
\<a>[r, f, f\<^sup>* \<star> f \<star> w] \<cdot> ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w])) \<cdot>
(r \<star> (f \<star> \<eta>) \<star> w)) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
(\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
using comp_assoc T0.antipar by auto
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
(r \<star> \<a>[src r, f, w]) \<cdot>
((r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w) \<cdot>
(r \<star> (f \<star> \<eta>) \<star> w)) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
(\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
proof -
have "(r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot>
\<a>[r, f, f\<^sup>* \<star> f \<star> w] \<cdot> ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) =
r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w"
proof -
text \<open>We can compress the reasoning about the associativities using coherence.\<close>
have "(r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f \<star> w]) \<cdot>
\<a>[r, f, f\<^sup>* \<star> f \<star> w] \<cdot> ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) =
\<lbrace>(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> ((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>f\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>])\<rbrace>"
using T0.antipar \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by auto
also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
using T0.antipar by (intro E.eval_eqI, auto)
also have "... = r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w"
using T0.antipar \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by simp
finally show ?thesis
by simp
qed
thus ?thesis by simp
qed
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
(r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
(\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
proof -
have "(r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w) \<cdot> (r \<star> (f \<star> \<eta>) \<star> w) =
r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w"
proof -
have "(r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w) \<cdot> (r \<star> (f \<star> \<eta>) \<star> w) =
r \<star> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>) \<star> w"
using whisker_left whisker_right hseqI' T0.antipar by simp
also have "... = r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w"
using T0.triangle_left by simp
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src f\<^sup>*]) \<cdot> (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<a>[src f\<^sup>*, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
(\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
using T0.antipar by simp
finally show ?thesis by simp
qed
also have "... = \<nu> \<cdot> \<r>[r] \<cdot>
((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>')) \<cdot>
(r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
((\<rho> \<star> trg w \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]))"
using comp_assoc T0.antipar by simp
also have "... = \<nu> \<cdot> \<r>[r] \<cdot>
((r \<star> \<theta>') \<cdot> (r \<star> \<l>[f \<star> w])) \<cdot>
(r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
(r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
(((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (\<rho> \<star> w))"
proof -
have "(r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') = (r \<star> \<theta>') \<cdot> (r \<star> \<l>[f \<star> w])"
proof -
have "(r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') = r \<star> \<r>[src r] \<cdot> (src r \<star> \<theta>')"
using whisker_left hseqI' by simp
also have "... = r \<star> \<theta>' \<cdot> \<l>[f \<star> w]"
using lunit_naturality [of \<theta>'] unitor_coincidence by simp
also have "... = (r \<star> \<theta>') \<cdot> (r \<star> \<l>[f \<star> w])"
using whisker_left by simp
finally show ?thesis by simp
qed
moreover have "(\<rho> \<star> trg w \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) = ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (\<rho> \<star> w)"
proof -
have "(\<rho> \<star> trg w \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) = \<rho> \<cdot> g \<star> (trg w \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]"
using interchange by simp
also have "... = \<rho> \<star> \<l>\<^sup>-\<^sup>1[w]"
using comp_arr_dom comp_cod_arr by simp
also have "... = (r \<star> f) \<cdot> \<rho> \<star> \<l>\<^sup>-\<^sup>1[w] \<cdot> w"
using comp_arr_dom comp_cod_arr by simp
also have "... = ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (\<rho> \<star> w)"
using interchange by simp
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<theta>') \<cdot>
((r \<star> \<l>[f \<star> w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
\<a>[r, f, trg w \<star> w] \<cdot> ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w])) \<cdot>
(\<rho> \<star> w)"
using comp_assoc by simp
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<theta>') \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w)"
proof -
have "((r \<star> \<l>[f \<star> w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
\<a>[r, f, trg w \<star> w] \<cdot> ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w])) =
\<a>[r, f, w]"
proof -
have "((r \<star> \<l>[f \<star> w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
\<a>[r, f, trg w \<star> w] \<cdot> ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w])) =
((r \<star> (\<l>[f] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
(r \<star> f \<star> \<l>\<^sup>-\<^sup>1[w])) \<cdot> \<a>[r, f, w]"
using comp_assoc assoc_naturality [of r f "\<l>\<^sup>-\<^sup>1[w]"] lunit_hcomp by simp
also have "... = \<a>[r, f, w]"
proof -
have "(r \<star> (\<l>[f] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
(r \<star> f \<star> \<l>\<^sup>-\<^sup>1[w]) =
r \<star> f \<star> w"
proof -
text \<open>Again, get a little more mileage out of coherence.\<close>
have "(r \<star> (\<l>[f] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
(r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
(r \<star> f \<star> \<l>\<^sup>-\<^sup>1[w]) =
\<lbrace>(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<l>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[E.Trg \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[E.Src \<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, E.Trg \<^bold>\<langle>w\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>w\<^bold>\<rangle>\<^bold>])\<rbrace>"
using \<ll>_ide_simp \<rr>_ide_simp \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by simp
also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
by (intro E.eval_eqI, auto)
also have "... = r \<star> f \<star> w"
by simp
finally show ?thesis by blast
qed
thus ?thesis
using comp_cod_arr by auto
qed
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = \<nu> \<cdot> \<r>[r] \<cdot> \<r>\<^sup>-\<^sup>1[r] \<cdot> inv \<nu>"
proof -
have "\<r>\<^sup>-\<^sup>1[r] \<cdot> inv \<nu> = (r \<star> \<theta>') \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w)"
using ** w\<theta>'\<nu> ide_base ide_leg0 tab_in_hom invert_side_of_triangle(2) comp_arr_dom
T0.antipar comp_assoc runit'_simps(1)
by metis
thus ?thesis by simp
qed
also have "... = g \<star> w"
using ** w\<theta>'\<nu> ide_base comp_arr_inv'
by (metis calculation in_homE invert_side_of_triangle(1) iso_runit iso_runit')
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
qed
ultimately have 1: "iso (g \<star> \<gamma>)"
using iso_iff_section_and_retraction by simp
have "iso (inv (\<nu> \<cdot> \<r>[r]) \<cdot> (g \<star> \<gamma>))"
proof -
have "iso (inv (\<nu> \<cdot> \<r>[r]))"
using w\<theta>'\<nu> \<gamma> iso_runit
by (elim conjE in_homE, intro iso_inv_iso isos_compose, auto)
thus ?thesis
using 1 w\<theta>'\<nu> \<gamma> trg_\<gamma>_eq isos_compose iso_inv_iso hseqI'
by (elim conjE in_homE, auto)
qed
moreover have "inv (\<nu> \<cdot> \<r>[r]) \<cdot> (g \<star> \<gamma>) = composite_cell f\<^sup>* \<epsilon>"
proof -
have "inv (\<nu> \<cdot> \<r>[r]) \<cdot> (g \<star> \<gamma>) = inv (\<nu> \<cdot> \<r>[r]) \<cdot> \<nu> \<cdot> \<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon>"
using \<gamma> by auto
also have "... = ((inv (\<nu> \<cdot> \<r>[r]) \<cdot> (\<nu> \<cdot> \<r>[r])) \<cdot> (r \<star> \<epsilon>)) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot> (\<rho> \<star> f\<^sup>*)"
using w\<theta>'\<nu> iso_inv_iso comp_assoc by auto
also have "... = composite_cell f\<^sup>* \<epsilon>"
proof -
have "dom \<nu> = r"
using w\<theta>'\<nu> by auto
thus ?thesis
using iso_runit w\<theta>'\<nu> isos_compose comp_cod_arr whisker_left [of r "src r" \<epsilon>]
iso_inv_iso comp_inv_arr inv_is_inverse
by auto
qed
finally show ?thesis by blast
qed
ultimately have "iso (composite_cell f\<^sup>* \<epsilon>)" by simp
thus "iso (T0.trnr\<^sub>\<epsilon> r \<rho>)"
using T0.trnr\<^sub>\<epsilon>_def ide_base runit_in_hom iso_runit isos_compose
by (metis A arrI seqE)
qed
text \<open>
It is convenient to have a simpler version of the previous result for when we do
not care about the details of the isomorphism.
\<close>
lemma yields_isomorphic_representation':
obtains \<psi> where "\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso \<psi>"
using yields_isomorphic_representation adjoint_pair_def by simp
end
text \<open>
It is natural to ask whether if \<open>\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close> is an isomorphism
then \<open>\<rho> = (\<psi> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)\<close> is a tabulation of \<open>r\<close>.
This is not true without additional conditions on \<open>f\<close> and \<open>g\<close>
(\emph{cf.}~the comments following CKS Proposition 6).
So only rather special isomorphisms \<open>\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close> result from tabulations of \<open>r\<close>.
\<close>
subsection "Tabulation of a Right Adjoint"
text \<open>
Here we obtain a tabulation of the right adjoint of a map. This is CKS Proposition 1(e).
It was somewhat difficult to find the correct way to insert the unitors
that CKS omit. At first I thought I could only prove this under the assumption
that the bicategory is normal, but later I saw how to do it in the general case.
\<close>
context adjunction_in_bicategory
begin
lemma tabulation_of_right_adjoint:
shows "tabulation V H \<a> \<i> src trg g \<eta> f (src f)"
proof -
interpret T: tabulation_data V H \<a> \<i> src trg g \<eta> f \<open>src f\<close>
using unit_in_hom antipar by (unfold_locales, simp_all)
show ?thesis
proof
show T1: "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> g \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> src f \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
proof -
fix u v \<omega>
assume u: "ide u"
assume \<omega>: "\<guillemotleft>\<omega> : v \<Rightarrow> g \<star> u\<guillemotright>"
have v: "ide v"
using \<omega> by auto
have 1: "src g = trg u"
using \<omega> by (metis arr_cod in_homE not_arr_null seq_if_composable)
have 2: "src f = trg v"
using \<omega> 1 u ide_right antipar(1)
by (metis horizontal_homs.trg_cod horizontal_homs.trg_dom horizontal_homs_axioms
hseqI' ideD(1) in_homE hcomp_simps(2))
text \<open>It seems clear that we need to take \<open>w = v\<close> and \<open>\<nu> = \<l>\<^sup>-\<^sup>1[v]\<close>. \<close>
let ?w = v
let ?\<nu> = "\<l>\<^sup>-\<^sup>1[v]"
have \<nu>: "\<guillemotleft>?\<nu> : v \<Rightarrow> src f \<star> ?w\<guillemotright> \<and> iso ?\<nu>"
using v 2 iso_lunit' by auto
text \<open>
We need \<open>\<theta>\<close>, defined to satisfy \<open>\<guillemotleft>\<theta> : f \<star> v \<Rightarrow> u\<guillemotright>\<close> and
\<open>\<omega> = (v \<star> \<theta>) \<cdot> \<a>[v, f, v] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[v]\<close>.
We have \<open>\<guillemotleft>\<omega> : v \<Rightarrow> g \<star> u\<guillemotright>\<close>, so we can get arrow \<open>\<guillemotleft>\<theta> : f \<star> v \<Rightarrow> u\<guillemotright>\<close> by adjoint transpose.
Note that this uses adjoint transpose on the \emph{left}, rather than on the right.
\<close>
let ?\<theta> = "trnl\<^sub>\<epsilon> u \<omega>"
have \<theta>: "\<guillemotleft>?\<theta> : f \<star> ?w \<Rightarrow> u\<guillemotright>"
using u v antipar 1 2 \<omega> adjoint_transpose_left(2) [of u v] by auto
text \<open>
Now, \<open>trnl\<^sub>\<eta> v \<theta> \<equiv> (g \<star> \<theta>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]\<close>, which suggests that
we ought to have \<open>\<omega> = trnl\<^sub>\<eta> v \<theta>\<close> and \<open>\<nu> = \<l>\<^sup>-\<^sup>1[v]\<close>;
\<close>
have "T.composite_cell ?w ?\<theta> \<cdot> ?\<nu> = \<omega>"
using u v \<omega> 1 2 adjoint_transpose_left(4) [of u v \<omega>] trnl\<^sub>\<eta>_def comp_assoc by simp
thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> src f \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
using v \<theta> \<nu> antipar comp_assoc by blast
qed
show T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
\<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>;
\<guillemotleft>\<beta> : src f \<star> w \<Rightarrow> src f \<star> w'\<guillemotright>;
T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
proof -
fix u w w' \<theta> \<theta>' \<beta>
assume w: "ide w"
assume w': "ide w'"
assume \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
assume \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
assume \<beta>: "\<guillemotleft>\<beta> : src f \<star> w \<Rightarrow> src f \<star> w'\<guillemotright>"
assume E: "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta>"
interpret T: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg g \<eta> f \<open>src f\<close> u w \<theta> w' \<theta>' \<beta>
using w w' \<theta> \<theta>' \<beta> E comp_assoc by (unfold_locales, auto)
have 2: "src f = trg \<beta>"
using antipar by simp
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
proof -
text \<open>
The requirement \<open>\<beta> = src f \<star> \<gamma>\<close> means we have to essentially invert \<open>\<lambda>\<gamma>. src f \<star> \<gamma>\<close>
to obtain \<open>\<gamma>\<close>. CKS say only: ``the strong form of \<open>T2\<close> is clear since \<open>g = 1\<close>"
(here by ``\<open>g\<close>'' they are referring to \<open>dom \<eta>\<close>, the ``output leg'' of the span in
the tabulation). This would mean that we would have to take \<open>\<gamma> = \<beta>\<close>, which doesn't
work for a general bicategory (we don't necessarily have \<open>src f \<star> \<gamma> = \<gamma>\<close>).
For a general bicategory, we have to take \<open>\<gamma> = \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w]\<close>.
\<close>
let ?\<gamma> = "\<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w]"
have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright>"
using \<beta> by simp
have 3: "\<beta> = src f \<star> ?\<gamma>"
proof -
have "\<beta> = \<l>\<^sup>-\<^sup>1[w'] \<cdot> ?\<gamma> \<cdot> \<l>[w]"
using \<beta> iso_lunit
by (simp add: comp_arr_dom invert_side_of_triangle(1) comp_assoc)
also have "... = \<l>\<^sup>-\<^sup>1[w'] \<cdot> \<l>[w'] \<cdot> (src f \<star> ?\<gamma>)"
using \<gamma> lunit_naturality
by (metis T.uw\<theta>.w_simps(4) in_homE trg_dom)
also have "... = (\<l>\<^sup>-\<^sup>1[w'] \<cdot> \<l>[w']) \<cdot> (src f \<star> ?\<gamma>)"
using comp_assoc by simp
also have "... = src f \<star> ?\<gamma>"
using \<gamma> iso_lunit comp_inv_arr comp_cod_arr
by (metis T.\<beta>_simps(1) calculation comp_ide_arr inv_is_inverse inverse_arrowsE w')
finally show ?thesis by simp
qed
have "\<theta> = \<theta>' \<cdot> (f \<star> ?\<gamma>)"
proof -
have "\<theta> = trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> w \<theta>)"
using \<theta> adjoint_transpose_left(3) [of u w \<theta>] by simp
also have "... = trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
proof -
have "trnl\<^sub>\<eta> w \<theta> = trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w]"
proof -
have "trnl\<^sub>\<eta> w \<theta> \<cdot> \<l>[w] = (T.composite_cell w \<theta> \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> \<l>[w]"
unfolding trnl\<^sub>\<eta>_def using comp_assoc by simp
also have "... = T.composite_cell w \<theta> \<cdot> (\<l>\<^sup>-\<^sup>1[w] \<cdot> \<l>[w])"
using comp_assoc by simp
also have 4: "... = T.composite_cell w \<theta>"
using comp_arr_dom by (simp add: comp_inv_arr' hseqI')
also have "... = T.composite_cell w' \<theta>' \<cdot> \<beta>"
using E by simp
also have "... = (T.composite_cell w' \<theta>' \<cdot> \<l>\<^sup>-\<^sup>1[w']) \<cdot> \<l>[w'] \<cdot> \<beta>"
proof -
have "(\<l>\<^sup>-\<^sup>1[w'] \<cdot> \<l>[w']) \<cdot> \<beta> = \<beta>"
using iso_lunit \<beta> comp_cod_arr comp_assoc comp_inv_arr' by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta>"
unfolding trnl\<^sub>\<eta>_def using comp_assoc by simp
finally have "trnl\<^sub>\<eta> w \<theta> \<cdot> \<l>[w] = trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta>"
by simp
thus ?thesis
using \<beta> 4 invert_side_of_triangle(2) adjoint_transpose_left iso_lunit
trnl\<^sub>\<eta>_def comp_assoc
by metis
qed
thus ?thesis by simp
qed
also have "... = \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
using trnl\<^sub>\<epsilon>_def by simp
also have
"... = \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> trnl\<^sub>\<eta> w' \<theta>') \<cdot> (f \<star> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
using ide_left ide_right w w' 2 \<beta> \<theta> antipar trnl\<^sub>\<epsilon>_def adjoint_transpose_left
whisker_left
by (metis T.uw\<theta>.\<theta>_simps(1) calculation hseqE seqE)
also have
"... = (\<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> trnl\<^sub>\<eta> w' \<theta>')) \<cdot> (f \<star> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
using comp_assoc by simp
also have "... = trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> w' \<theta>') \<cdot> (f \<star> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
unfolding trnl\<^sub>\<epsilon>_def by simp
also have "... = \<theta>' \<cdot> (f \<star> ?\<gamma>)"
using \<theta>' adjoint_transpose_left(3) by auto
finally show ?thesis by simp
qed
hence "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
using \<gamma> 3 hcomp_obj_arr by auto
moreover have "\<And>\<gamma> \<gamma>'. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>) \<and>
\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>') \<Longrightarrow> \<gamma> = \<gamma>'"
proof -
fix \<gamma> \<gamma>'
assume \<gamma>\<gamma>': "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>) \<and>
\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>')"
show "\<gamma> = \<gamma>'"
using \<gamma>\<gamma>' vconn_implies_hpar(2) L.is_faithful [of \<gamma> \<gamma>'] by force
qed
ultimately show ?thesis by blast
qed
qed
qed
qed
end
subsection "Preservation by Isomorphisms"
text \<open>
Next, we show that tabulations are preserved under composition on all three sides by
isomorphisms. This is something that we would expect to hold if ``tabulation'' is a
properly bicategorical notion.
\<close>
context tabulation
begin
text \<open>
Tabulations are preserved under composition of an isomorphism with the ``input leg''.
\<close>
lemma preserved_by_input_iso:
assumes "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
shows "tabulation V H \<a> \<i> src trg r ((r \<star> \<phi>) \<cdot> \<rho>) f' g"
proof -
interpret T': tabulation_data V H \<a> \<i> src trg r \<open>(r \<star> \<phi>) \<cdot> \<rho>\<close> f'
using assms(1) tab_in_hom
apply unfold_locales
apply auto
by force
show ?thesis
proof
show "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and>
iso \<nu> \<and> T'.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
proof -
fix u \<omega>
assume u: "ide u" and \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and>
iso \<nu> \<and> composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
using u \<omega> T1 by blast
interpret T1: uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g u w \<theta> \<omega> \<nu>
using w\<theta>\<nu> comp_assoc by (unfold_locales, auto)
have 1: "\<guillemotleft>inv \<phi> \<star> w : f' \<star> w \<Rightarrow> f \<star> w\<guillemotright>"
using assms by (intro hcomp_in_vhom, auto)
have "ide w \<and> \<guillemotleft>\<theta> \<cdot> (inv \<phi> \<star> w) : f' \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T'.composite_cell w (\<theta> \<cdot> (inv \<phi> \<star> w)) \<cdot> \<nu> = \<omega>"
using w\<theta>\<nu> 1
apply (intro conjI)
apply auto[4]
proof -
show "T'.composite_cell w (\<theta> \<cdot> (inv \<phi> \<star> w)) \<cdot> \<nu> = \<omega>"
proof -
have "T'.composite_cell w (\<theta> \<cdot> (inv \<phi> \<star> w)) \<cdot> \<nu> =
(r \<star> \<theta>) \<cdot> ((r \<star> inv \<phi> \<star> w) \<cdot> \<a>[r, f', w]) \<cdot> ((r \<star> \<phi>) \<cdot> \<rho> \<star> w) \<cdot> \<nu>"
using assms(1) 1 whisker_left [of r \<theta> "inv \<phi> \<star> w"] comp_assoc by auto
also have "... = (r \<star> \<theta>) \<cdot> (\<a>[r, f, w] \<cdot> ((r \<star> inv \<phi>) \<star> w)) \<cdot> ((r \<star> \<phi>) \<cdot> \<rho> \<star> w) \<cdot> \<nu>"
using assms assoc_naturality [of r "inv \<phi>" w]
by (metis 1 T'.tab_simps(1) base_simps(3) base_simps(4) T1.w_simps(5-6)
cod_inv dom_inv hseqE in_homE seqE trg_inv)
also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> ((((r \<star> inv \<phi>) \<star> w) \<cdot> ((r \<star> \<phi>) \<star> w)) \<cdot> (\<rho> \<star> w)) \<cdot> \<nu>"
using whisker_right [of w "r \<star> \<phi>" \<rho>] comp_assoc T1.ide_w vseq_implies_hpar(1)
by auto
also have "... = composite_cell w \<theta> \<cdot> \<nu>"
proof -
have "(((r \<star> inv \<phi>) \<star> w) \<cdot> ((r \<star> \<phi>) \<star> w)) \<cdot> (\<rho> \<star> w) = \<rho> \<star> w"
proof -
have "\<guillemotleft>r \<star> \<phi> : r \<star> f \<Rightarrow> r \<star> f'\<guillemotright>"
using assms(1) by (intro hcomp_in_vhom, auto)
moreover have "\<guillemotleft>r \<star> inv \<phi> : r \<star> f' \<Rightarrow> r \<star> f\<guillemotright>"
using assms by (intro hcomp_in_vhom, auto)
ultimately show ?thesis
using comp_cod_arr
by (metis T1.w_in_hom(2) tab_simps(1) tab_simps(5) assms(1-2) comp_inv_arr'
in_homE leg0_simps(2) interchange base_in_hom(2) seqI')
qed
thus ?thesis
using comp_assoc by simp
qed
also have "... = \<omega>"
using w\<theta>\<nu> by simp
finally show ?thesis by simp
qed
qed
thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T'.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
by blast
qed
show "\<And>u w w' \<theta> \<theta>' \<beta>. \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f' \<star> w' \<Rightarrow> u\<guillemotright>;
\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
proof -
fix u w w' \<theta> \<theta>' \<beta>
assume w: "ide w" and w': "ide w'"
and \<theta>: "\<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright>" and \<theta>': "\<guillemotleft>\<theta>' : f' \<star> w' \<Rightarrow> u\<guillemotright>"
and \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
and eq: "T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot> \<beta>"
interpret uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg r \<open>(r \<star> \<phi>) \<cdot> \<rho>\<close> f' g u w \<theta> w' \<theta>' \<beta>
using w w' \<theta> \<theta>' \<beta> eq comp_assoc by (unfold_locales, auto)
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
proof -
have \<phi>_w: "\<guillemotleft>\<phi> \<star> w : f \<star> w \<Rightarrow> f' \<star> w\<guillemotright>"
using assms(1) by (intro hcomp_in_vhom, auto)
have \<phi>_w': "\<guillemotleft>\<phi> \<star> w' : f \<star> w' \<Rightarrow> f' \<star> w'\<guillemotright>"
using assms(1) by (intro hcomp_in_vhom, auto)
have "\<guillemotleft>\<theta> \<cdot> (\<phi> \<star> w) : f \<star> w \<Rightarrow> u\<guillemotright>"
using \<theta> assms(1) by fastforce
moreover have "\<guillemotleft>\<theta>' \<cdot> (\<phi> \<star> w') : f \<star> w' \<Rightarrow> u\<guillemotright>"
using \<theta>' assms(1) by fastforce
moreover have "composite_cell w (\<theta> \<cdot> (\<phi> \<star> w)) = composite_cell w' (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> \<beta>"
proof -
have "composite_cell w (\<theta> \<cdot> (\<phi> \<star> w)) =
(r \<star> \<theta>) \<cdot> ((r \<star> \<phi> \<star> w) \<cdot> \<a>[r, f, w]) \<cdot> (\<rho> \<star> w)"
using assms(2) \<phi>_w \<theta> whisker_left comp_assoc by auto
also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> ((r \<star> \<phi>) \<star> w) \<cdot> (\<rho> \<star> w)"
using assms(1) assoc_naturality [of r \<phi> w] comp_assoc
by (metis \<phi>_w T'.tab_simps(1) base_simps(3) base_simps(4) hseq_char
in_homE seqE uw\<theta>.w_simps(5) uw\<theta>.w_simps(6))
also have "... = T'.composite_cell w \<theta>"
using assms(2) w whisker_right [of w] by simp
also have "... = T'.composite_cell w' \<theta>' \<cdot> \<beta>"
using eq by simp
also have "... = (r \<star> \<theta>') \<cdot> (\<a>[r, f', w'] \<cdot> ((r \<star> \<phi>) \<star> w')) \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
using assms(2) w' whisker_right [of w'] comp_assoc by simp
also have "... = ((r \<star> \<theta>') \<cdot> (r \<star> \<phi> \<star> w')) \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
using assms(1) assoc_naturality [of r \<phi> w'] comp_assoc
by (metis \<phi>_w' T'.tab_simps(1) base_simps(3) base_simps(4) hseqE in_homE seqE
uw'\<theta>'.w_simps(5) uw'\<theta>'.w_simps(6))
also have "... = composite_cell w' (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> \<beta>"
using assms(2) whisker_left [of r] \<open>\<guillemotleft>\<theta>' \<cdot> (\<phi> \<star> w') : f \<star> w' \<Rightarrow> u\<guillemotright>\<close> comp_assoc
by auto
finally show ?thesis by simp
qed
ultimately have *: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and>
\<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)"
using w w' \<beta> T2 by auto
show ?thesis
proof -
have **: "\<And>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<Longrightarrow> \<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = \<theta>' \<cdot> (f' \<star> \<gamma>)"
proof -
fix \<gamma>
assume \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
have "\<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = \<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<cdot> inv \<phi> \<star> \<gamma> \<cdot> w)"
using \<gamma> assms(1-2) interchange
by (metis arr_inv cod_inv in_homE leg0_simps(2) leg0_simps(4) uw\<theta>.w_in_hom(2)
seqI)
also have "... = \<theta>' \<cdot> (\<phi> \<cdot> f \<cdot> inv \<phi> \<star> w' \<cdot> \<gamma> \<cdot> w)"
using assms(1-2) interchange
by (metis \<gamma> arr_inv cod_inv comp_arr_dom comp_cod_arr in_homE seqI)
also have "... = \<theta>' \<cdot> (f' \<star> \<gamma>)"
proof -
have "\<phi> \<cdot> f \<cdot> inv \<phi> = f'"
using assms(1-2) comp_cod_arr comp_arr_inv' by auto
moreover have "w' \<cdot> \<gamma> \<cdot> w = \<gamma>"
using \<gamma> comp_arr_dom comp_cod_arr by auto
ultimately show ?thesis by simp
qed
finally show "\<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = \<theta>' \<cdot> (f' \<star> \<gamma>)" by simp
qed
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and>
\<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)"
using * by blast
have "\<theta> = \<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w)"
proof -
have "seq (\<theta>' \<cdot> (\<phi> \<star> w')) (f \<star> \<gamma>)"
using assms(2) \<phi>_w \<phi>_w' \<gamma> \<beta> \<theta>
apply (intro seqI hseqI')
apply auto
by (metis seqE seqI')
thus ?thesis
using assms \<phi>_w \<gamma> comp_assoc invert_side_of_triangle(2) iso_hcomp
by (metis hcomp_in_vhomE ide_is_iso inv_hcomp inv_ide w)
qed
hence "\<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
using \<gamma> ** by simp
hence "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
using \<gamma> by auto
moreover have "\<And>\<gamma> \<gamma>'. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>) \<and>
\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>')
\<Longrightarrow> \<gamma> = \<gamma>'"
proof -
fix \<gamma> \<gamma>'
assume A: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>) \<and>
\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>')"
have "\<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)"
proof -
have "\<theta> = ((\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)) \<cdot> (inv \<phi> \<star> w)"
using A ** comp_assoc by simp
thus ?thesis
using assms(1-2) A iso_inv_iso
by (metis comp_arr_dom comp_cod_arr in_homE comp_assoc interchange)
qed
moreover have "\<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>')"
proof -
have "\<theta> = ((\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>')) \<cdot> (inv \<phi> \<star> w)"
using A ** comp_assoc by auto
thus ?thesis
using assms(1-2) A iso_inv_iso
by (metis comp_arr_dom comp_cod_arr in_homE comp_assoc interchange)
qed
ultimately show "\<gamma> = \<gamma>'"
using A * by blast
qed
ultimately show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
by metis
qed
qed
qed
qed
qed
text \<open>
Similarly, tabulations are preserved under composition of an isomorphism with
the ``output leg''.
\<close>
lemma preserved_by_output_iso:
assumes "\<guillemotleft>\<phi> : g' \<Rightarrow> g\<guillemotright>" and "iso \<phi>"
shows "tabulation V H \<a> \<i> src trg r (\<rho> \<cdot> \<phi>) f g'"
proof -
have \<tau>\<phi>: "\<guillemotleft>\<rho> \<cdot> \<phi> : g' \<Rightarrow> r \<star> f\<guillemotright>"
using assms by auto
interpret T': tabulation_data V H \<a> \<i> src trg r \<open>\<rho> \<cdot> \<phi>\<close> f g'
using assms(2) \<tau>\<phi> by (unfold_locales, auto)
have \<phi>_in_hhom: "\<guillemotleft>\<phi> : src f \<rightarrow> trg r\<guillemotright>"
using assms src_cod [of \<phi>] trg_cod [of \<phi>]
by (elim in_homE, simp)
show ?thesis
proof
fix u \<omega>
assume u: "ide u" and \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
show "\<exists>w \<theta> \<nu>'. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu>' : dom \<omega> \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu>' \<and>
T'.composite_cell w \<theta> \<cdot> \<nu>' = \<omega>"
proof -
obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and>
iso \<nu> \<and> composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
using u \<omega> T1 [of u \<omega>] by auto
interpret uw\<theta>\<omega>\<nu>: uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g u w \<theta> \<omega> \<nu>
using w\<theta>\<nu> comp_assoc by (unfold_locales, auto)
let ?\<nu>' = "(inv \<phi> \<star> w) \<cdot> \<nu>"
have \<nu>': "\<guillemotleft>?\<nu>' : dom \<omega> \<Rightarrow> g' \<star> w\<guillemotright>"
using assms \<phi>_in_hhom uw\<theta>\<omega>\<nu>.\<nu>_in_hom
by (intro comp_in_homI, auto)
moreover have "iso ?\<nu>'"
using assms \<nu>' w\<theta>\<nu> \<phi>_in_hhom iso_inv_iso
by (intro iso_hcomp isos_compose, auto)
moreover have "T'.composite_cell w \<theta> \<cdot> ?\<nu>' = \<omega>"
proof -
have "composite_cell w \<theta> \<cdot> ((\<phi> \<star> w) \<cdot> ?\<nu>') = \<omega>"
proof -
have "(\<phi> \<star> w) \<cdot> ?\<nu>' = \<nu>"
using assms \<nu>' \<phi>_in_hhom whisker_right comp_cod_arr comp_assoc
by (metis comp_arr_inv' in_homE leg1_simps(2) uw\<theta>\<omega>\<nu>.uw\<theta>\<omega>\<nu>)
thus ?thesis
using w\<theta>\<nu> by simp
qed
moreover have "(\<rho> \<cdot> \<phi> \<star> w) \<cdot> ?\<nu>' = (\<rho> \<star> w) \<cdot> ((\<phi> \<star> w) \<cdot> ?\<nu>')"
using assms \<phi>_in_hhom whisker_right comp_assoc by simp
ultimately show ?thesis
using comp_assoc by simp
qed
ultimately show ?thesis
using w\<theta>\<nu> by blast
qed
next
fix u w w' \<theta> \<theta>' \<beta>'
assume w: "ide w" and w': "ide w'"
and \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>" and \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
and \<beta>': "\<guillemotleft>\<beta>' : g' \<star> w \<Rightarrow> g' \<star> w'\<guillemotright>"
and eq': "T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot> \<beta>'"
interpret uw\<theta>w'\<theta>'\<beta>: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg r \<open>\<rho> \<cdot> \<phi>\<close> f g' u w \<theta> w' \<theta>' \<beta>'
using assms w w' \<theta> \<theta>' \<beta>' eq' comp_assoc by (unfold_locales, auto)
let ?\<beta> = "(\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w)"
have \<beta>: "\<guillemotleft>?\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
using assms \<phi>_in_hhom \<beta>'
by (intro comp_in_homI hcomp_in_vhom, auto)
have eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> ((\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w))"
proof -
have "composite_cell w \<theta> = (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> ((\<rho> \<star> w) \<cdot> (\<phi> \<star> w)) \<cdot> (inv \<phi> \<star> w)"
proof -
have "\<rho> \<star> w = (\<rho> \<star> w) \<cdot> (\<phi> \<star> w) \<cdot> (inv \<phi> \<star> w)"
using assms w \<phi>_in_hhom whisker_right comp_arr_dom comp_arr_inv'
by (metis tab_simps(1) tab_simps(4) in_homE leg1_simps(2))
thus ?thesis
using comp_assoc by simp
qed
also have "... = T'.composite_cell w \<theta> \<cdot> (inv \<phi> \<star> w)"
using assms \<phi>_in_hhom whisker_right comp_assoc by simp
also have "... = T'.composite_cell w' \<theta>' \<cdot> (\<beta>' \<cdot> (inv \<phi> \<star> w))"
using eq' comp_assoc by simp
also have "... = composite_cell w' \<theta>' \<cdot> ((\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w))"
using assms \<phi>_in_hhom whisker_right comp_assoc by simp
finally show ?thesis by simp
qed
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
proof -
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> ?\<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
using assms w w' \<theta> \<theta>' \<beta> eq \<phi>_in_hhom T2 [of w w' \<theta> u \<theta>' ?\<beta>] by auto
have "\<beta>' = g' \<star> \<gamma>"
proof -
have "g \<star> \<gamma> = (\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w)"
using \<gamma> by simp
hence "(inv \<phi> \<star> w') \<cdot> (g \<star> \<gamma>) = \<beta>' \<cdot> (inv \<phi> \<star> w)"
using assms w' \<beta> \<phi>_in_hhom invert_side_of_triangle arrI iso_hcomp
hseqE ide_is_iso inv_hcomp inv_ide seqE
by metis
hence "\<beta>' = (inv \<phi> \<star> w') \<cdot> (g \<star> \<gamma>) \<cdot> (\<phi> \<star> w)"
using assms w \<beta> \<phi>_in_hhom invert_side_of_triangle comp_assoc seqE
by (metis comp_arr_dom in_homE local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(4) whisker_right)
also have "... = (inv \<phi> \<star> w') \<cdot> (\<phi> \<star> \<gamma>)"
using assms \<phi>_in_hhom \<gamma> interchange comp_arr_dom comp_cod_arr
by (metis in_homE)
also have "... = g' \<star> \<gamma>"
using assms \<phi>_in_hhom \<gamma> interchange comp_inv_arr inv_is_inverse comp_cod_arr
by (metis arr_dom calculation in_homE)
finally show ?thesis by simp
qed
hence "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
using \<beta> \<gamma> by auto
moreover have "\<And>\<gamma> \<gamma>'. \<lbrakk> \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>);
\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>') \<rbrakk> \<Longrightarrow> \<gamma> = \<gamma>'"
proof -
have *: "\<And>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<Longrightarrow> (\<phi> \<star> w') \<cdot> (g' \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = g \<star> \<gamma>"
proof -
fix \<gamma>
assume \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
have "(\<phi> \<star> w') \<cdot> (g' \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = (\<phi> \<star> w') \<cdot> (inv \<phi> \<star> \<gamma>)"
using assms \<phi>_in_hhom \<gamma> interchange comp_arr_dom comp_cod_arr
by (metis arr_dom comp_inv_arr' in_homE invert_side_of_triangle(2))
also have "... = g \<star> \<gamma>"
using assms \<phi>_in_hhom interchange comp_arr_inv inv_is_inverse comp_cod_arr
by (metis \<gamma> comp_arr_inv' in_homE leg1_simps(2))
finally show "(\<phi> \<star> w') \<cdot> (g' \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = g \<star> \<gamma>" by blast
qed
fix \<gamma> \<gamma>'
assume \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
and \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>')"
show "\<gamma> = \<gamma>'"
using w w' \<theta> \<theta>' \<beta> \<gamma> \<gamma>' eq * T2 by metis
qed
ultimately show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)" by blast
qed
qed
qed
text \<open>
Finally, tabulations are preserved by composition with an isomorphism on the ``base''.
\<close>
lemma is_preserved_by_base_iso:
assumes "\<guillemotleft>\<phi> : r \<Rightarrow> r'\<guillemotright>" and "iso \<phi>"
shows "tabulation V H \<a> \<i> src trg r' ((\<phi> \<star> f) \<cdot> \<rho>) f g"
proof -
have \<phi>f: "\<guillemotleft>\<phi> \<star> f : r \<star> f \<Rightarrow> r' \<star> f\<guillemotright>"
using assms ide_leg0 by auto
interpret T: tabulation_data V H \<a> \<i> src trg r' \<open>(\<phi> \<star> f) \<cdot> \<rho>\<close> f
proof
show ide_r': "ide r'" using assms by auto
show "ide f" using ide_leg0 by auto
show "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<rho> : g \<Rightarrow> r' \<star> f\<guillemotright>"
using tab_in_hom \<phi>f by force
qed
show ?thesis
proof
have *: "\<And>u v w \<theta> \<nu>. \<lbrakk> ide u; ide v; ide w; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<rbrakk> \<Longrightarrow>
((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> =
T.composite_cell w \<theta> \<cdot> \<nu>"
proof -
fix u v w \<theta> \<nu>
assume u: "ide u" and v: "ide v" and w: "ide w"
and \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>" and \<nu>: "\<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright>"
have fw: "hseq f w"
using \<theta> ide_dom [of \<theta>] by fastforce
have r\<theta>: "hseq r \<theta>"
using \<theta> ide_base ide_dom [of \<theta>] trg_dom [of \<theta>] by fastforce
have "((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> =
((r' \<star> \<theta>) \<cdot> (\<phi> \<star> f \<star> w)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>"
using assms u w ide_base ide_leg0 \<theta> interchange comp_arr_dom comp_cod_arr
by (metis r\<theta> hseq_char in_homE)
also have "... = (r' \<star> \<theta>) \<cdot> ((\<phi> \<star> f \<star> w) \<cdot> \<a>[r, f, w]) \<cdot> (\<rho> \<star> w) \<cdot> \<nu>"
using comp_assoc by simp
also have "... = (r' \<star> \<theta>) \<cdot> \<a>[r', f, w] \<cdot> (((\<phi> \<star> f) \<star> w) \<cdot> (\<rho> \<star> w)) \<cdot> \<nu>"
proof -
have "(\<phi> \<star> f \<star> w) \<cdot> \<a>[r, f, w] = \<a>[r', f, w] \<cdot> ((\<phi> \<star> f) \<star> w)"
using assms ide_leg0 w assoc_naturality [of \<phi> f w] fw by fastforce
thus ?thesis
using comp_assoc by simp
qed
also have "... = T.composite_cell w \<theta> \<cdot> \<nu>"
using assms ide_leg0 whisker_right fw T.tab_in_hom arrI w comp_assoc by auto
finally show "((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> = T.composite_cell w \<theta> \<cdot> \<nu>"
by simp
qed
show "\<And>u \<omega>'. \<lbrakk> ide u; \<guillemotleft>\<omega>' : dom \<omega>' \<Rightarrow> r' \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega>' \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>'"
proof -
fix u v \<omega>'
assume u: "ide u" and \<omega>': "\<guillemotleft>\<omega>' : v \<Rightarrow> r' \<star> u\<guillemotright>"
have \<omega>: "\<guillemotleft>(inv \<phi> \<star> u) \<cdot> \<omega>' : v \<Rightarrow> r \<star> u\<guillemotright>"
proof
show "\<guillemotleft>\<omega>' : v \<Rightarrow> r' \<star> u\<guillemotright>" by fact
show "\<guillemotleft>inv \<phi> \<star> u : r' \<star> u \<Rightarrow> r \<star> u\<guillemotright>"
proof -
have "ide (r' \<star> u)"
using \<omega>' ide_cod by fastforce
hence "hseq r' u" by simp
thus ?thesis
using assms u by auto
qed
qed
have \<phi>u: "hseq \<phi> u"
using assms \<omega> hseqI
by (metis arrI ide_is_iso iso_hcomp iso_is_arr seqE seq_if_composable
src_inv u)
obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
composite_cell w \<theta> \<cdot> \<nu> = (inv \<phi> \<star> u) \<cdot> \<omega>'"
using u \<omega> T1 [of u "(inv \<phi> \<star> u) \<cdot> \<omega>'"] \<phi>f in_homE seqI' by auto
interpret uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g u w \<theta> \<open>(inv \<phi> \<star> u) \<cdot> \<omega>'\<close> \<nu>
using w\<theta>\<nu> \<omega> comp_assoc by (unfold_locales, auto)
have "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>'"
proof -
have "\<omega>' = ((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>"
proof -
have "seq (r \<star> \<theta>) (\<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>)" by fastforce
moreover have "iso (inv \<phi> \<star> u)"
using assms u iso_hcomp iso_inv_iso \<phi>u by auto
moreover have "inv (inv \<phi> \<star> u) = \<phi> \<star> u"
using assms u iso_hcomp iso_inv_iso \<phi>u by auto
ultimately show ?thesis
using invert_side_of_triangle(1) w\<theta>\<nu> comp_assoc by metis
qed
also have "... = T.composite_cell w \<theta> \<cdot> \<nu>"
using u w\<theta>\<nu> * [of u v w \<theta> \<nu>] by force
finally have "\<omega>' = T.composite_cell w \<theta> \<cdot> \<nu>" by simp
thus ?thesis
using w\<theta>\<nu> by simp
qed
thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>'"
by blast
qed
show "\<And>u w w' \<theta> \<theta>' \<beta>. \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>;
\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
proof -
fix u w w' \<theta> \<theta>' \<beta>
assume w: "ide w" and w': "ide w'"
and \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>" and \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
and \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
and eq': "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta>"
interpret T: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg r' \<open>(\<phi> \<star> f) \<cdot> \<rho>\<close> f g u w \<theta> w' \<theta>' \<beta>
using w w' \<theta> \<theta>' \<beta> eq' comp_assoc
by (unfold_locales, auto)
have eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
proof -
have "(\<phi> \<star> u) \<cdot> composite_cell w \<theta> = (\<phi> \<star> u) \<cdot> composite_cell w' \<theta>' \<cdot> \<beta>"
proof -
have "(\<phi> \<star> u) \<cdot> composite_cell w \<theta> =
((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> (g \<star> w)"
proof -
have "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
using w by auto
thus ?thesis
using comp_arr_dom comp_assoc by auto
qed
also have "... = T.composite_cell w \<theta> \<cdot> (g \<star> w)"
using * [of u "g \<star> w" w \<theta> "g \<star> w"] by fastforce
also have "... = T.composite_cell w \<theta>"
proof -
have "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<rho> \<star> w : g \<star> w \<Rightarrow> (r' \<star> f) \<star> w\<guillemotright>"
using assms by fastforce
thus ?thesis
using comp_arr_dom comp_assoc by auto
qed
also have "... = T.composite_cell w' \<theta>' \<cdot> \<beta>"
using eq' by simp
also have "... = ((\<phi> \<star> u) \<cdot> (r \<star> \<theta>')) \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
using * [of u "g \<star> w" w' \<theta>' \<beta>] by fastforce
finally show ?thesis
using comp_assoc by simp
qed
moreover have "iso (\<phi> \<star> u)"
using assms by auto
moreover have "seq (\<phi> \<star> u) ((r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w))"
proof -
have "\<guillemotleft>\<phi> \<star> u : r \<star> u \<Rightarrow> r' \<star> u\<guillemotright>"
using assms by (intro hcomp_in_vhom, auto)
thus ?thesis
using composite_cell_in_hom [of w u \<theta>] by auto
qed
moreover have "seq (\<phi> \<star> u) (composite_cell w' \<theta>' \<cdot> \<beta>)"
using assms ide_leg0 w w' \<theta> \<theta>' \<beta> calculation(1) calculation(3) by auto
ultimately show ?thesis
using monoE section_is_mono iso_is_section by metis
qed
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
using w w' \<theta> \<theta>' \<beta> eq T2 by simp
qed
qed
qed
end
subsection "Canonical Tabulations"
text \<open>
If the 1-cell \<open>g \<star> f\<^sup>*\<close> has any tabulation \<open>(f, \<rho>, g)\<close>, then it has the canonical
tabulation obtained as the adjoint transpose of (the identity on) \<open>g \<star> f\<^sup>*\<close>.
\<close>
context map_in_bicategory
begin
lemma canonical_tabulation:
assumes "ide g" and "src f = src g"
and "\<exists>\<rho>. tabulation V H \<a> \<i> src trg (g \<star> f\<^sup>*) \<rho> f g"
shows "tabulation V H \<a> \<i> src trg (g \<star> f\<^sup>*) (trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)) f g"
proof -
have 1: "ide (g \<star> f\<^sup>*)"
using assms(1-2) ide_right antipar by simp
obtain \<rho> where \<rho>: "tabulation V H \<a> \<i> src trg (g \<star> f\<^sup>*) \<rho> f g"
using assms(3) by auto
interpret \<rho>: tabulation V H \<a> \<i> src trg \<open>g \<star> f\<^sup>*\<close> \<rho> f g
using \<rho> by auto
let ?\<psi> = "trnr\<^sub>\<epsilon> (g \<star> f\<^sup>*) \<rho>"
have 3: "\<guillemotleft>?\<psi> : g \<star> f\<^sup>* \<Rightarrow> g \<star> f\<^sup>*\<guillemotright> \<and> iso ?\<psi>"
using \<rho>.yields_isomorphic_representation by blast
hence "tabulation (\<cdot>) (\<star>) \<a> \<i> src trg (g \<star> f\<^sup>*) ((inv ?\<psi> \<star> f) \<cdot> \<rho>) f g"
using \<rho>.is_preserved_by_base_iso [of "inv ?\<psi>" "g \<star> f\<^sup>*"] iso_inv_iso by simp
moreover have "(inv ?\<psi> \<star> f) \<cdot> \<rho> = trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
proof -
have "(inv ?\<psi> \<star> f) \<cdot> \<rho> = ((inv ?\<psi> \<star> f) \<cdot> (?\<psi> \<star> f)) \<cdot> trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
using \<rho>.\<rho>_in_terms_of_rep comp_assoc by simp
also have "... = ((g \<star> f\<^sup>*) \<star> f) \<cdot> trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
proof -
have "src (inv ?\<psi>) = trg f"
using 3 antipar
by (metis \<rho>.leg0_simps(3) \<rho>.base_in_hom(2) seqI' src_inv vseq_implies_hpar(1))
hence "(inv ?\<psi> \<star> f) \<cdot> (?\<psi> \<star> f) = (g \<star> f\<^sup>*) \<star> f"
using 3 whisker_right [of f "inv ?\<psi>" ?\<psi>] inv_is_inverse comp_inv_arr by auto
thus ?thesis
using comp_cod_arr by simp
qed
also have "... = trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
proof -
have "src (g \<star> f\<^sup>*) = trg f" by simp
moreover have "ide g" by simp
ultimately have "\<guillemotleft>trnr\<^sub>\<eta> g (g \<star> f\<^sup>*) : g \<Rightarrow> (g \<star> f\<^sup>*) \<star> f\<guillemotright>"
using 1 adjoint_transpose_right(1) ide_in_hom antipar by blast
thus ?thesis
using comp_cod_arr by blast
qed
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
end
subsection "Uniqueness of Tabulations"
text \<open>
We now intend to show that a tabulation of \<open>r\<close> is ``unique up to equivalence'',
which is a property that any proper bicategorical limit should have.
What do we mean by this, exactly?
If we have two tabulations \<open>(f, \<rho>)\<close> and \<open>(f', \<rho>')\<close> of the same 1-cell \<open>r\<close>, then this
induces \<open>\<guillemotleft>w : src f' \<rightarrow> src f\<guillemotright>\<close>, \<open>\<guillemotleft>w' : src f \<rightarrow> src f'\<guillemotright>\<close>, \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> f'\<guillemotright>\<close>, and
\<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> f'\<guillemotright>\<close>, such that \<open>\<rho>'\<close> is recovered up to isomorphism \<open>\<guillemotleft>\<nu> : g' \<Rightarrow> g \<star> w\<guillemotright>\<close>
from \<open>(w, \<theta>)\<close> by composition with \<open>\<rho>\<close> and \<open>\<rho>\<close> is recovered up to isomorphism
\<open>\<guillemotleft>\<nu>' : g \<Rightarrow> g' \<star> w'\<guillemotright>\<close> from \<open>(w', \<theta>')\<close> by composition with \<open>\<rho>'\<close>.
This means that we obtain isomorphisms \<open>\<guillemotleft>(\<nu>' \<star> w') \<cdot> \<nu> : g' \<Rightarrow> g' \<star> w' \<star> w\<guillemotright>\<close> and
\<open>\<guillemotleft>(\<nu> \<star> w') \<cdot> \<nu>' : g \<Rightarrow> g \<star> w \<star> w'\<guillemotright>\<close>.
These isomorphisms then induce, via \<open>T2\<close>, unique 2-cells from \<open>src f'\<close> to \<open>w' \<star> w\<close>
and from \<open>src f\<close> to \<open>w \<star> w'\<close>, which must be isomorphisms, thus showing \<open>w\<close> and \<open>w'\<close> are
equivalence maps.
\<close>
context tabulation
begin
text \<open>
We will need the following technical lemma.
\<close>
lemma apex_equivalence_lemma:
assumes "\<guillemotleft>\<rho>' : g' \<Rightarrow> r \<star> f'\<guillemotright>"
and "ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> f\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu> \<and>
(r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> (\<rho>' \<star> w) \<cdot> \<nu> = \<rho>"
and "ide w' \<and> \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>\<nu>' : g' \<Rightarrow> g \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
(r \<star> \<theta>') \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<nu>' = \<rho>'"
shows "\<exists>\<phi>. \<guillemotleft>\<phi> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> iso \<phi>"
proof -
interpret T': uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g f' w' \<theta>' \<rho>' \<nu>'
using assms(1,3) apply unfold_locales by auto
interpret T: tabulation_data V H \<a> \<i> src trg r \<rho>' f' g'
using assms(1,2) apply unfold_locales by auto
interpret T: uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho>' f' g' f w \<theta> \<rho> \<nu>
using assms(1,2) apply unfold_locales by auto
(* These next simps are very important. *)
have dom_\<nu> [simp]: "dom \<nu> = dom \<rho>"
using assms(2) by auto
have dom_\<nu>' [simp]: "dom \<nu>' = dom \<rho>'"
using assms(3) by auto
let ?\<nu>'\<nu> = "\<a>[dom \<rho>, w', w] \<cdot> (\<nu>' \<star> w) \<cdot> \<nu>"
have \<nu>'\<nu>: "\<guillemotleft>?\<nu>'\<nu> : dom \<rho> \<Rightarrow> dom \<rho> \<star> w' \<star> w\<guillemotright>"
by fastforce
have "\<guillemotleft>\<nu> : src \<rho> \<rightarrow> trg r\<guillemotright>" by simp
let ?\<theta>\<theta>' = "\<theta> \<cdot> (\<theta>' \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[f, w', w]"
have \<theta>\<theta>': "\<guillemotleft>?\<theta>\<theta>' : f \<star> w' \<star> w \<Rightarrow> f\<guillemotright>"
by fastforce
have iso_\<nu>'\<nu>_r: "iso (?\<nu>'\<nu> \<cdot> \<r>[g])"
using iso_runit \<nu>'\<nu>
apply (intro isos_compose) by auto
have eq: "composite_cell (src f) \<r>[f] = composite_cell (w' \<star> w) ?\<theta>\<theta>' \<cdot> (?\<nu>'\<nu> \<cdot> \<r>[g])"
proof -
have "composite_cell (w' \<star> w) ?\<theta>\<theta>' \<cdot> (?\<nu>'\<nu> \<cdot> \<r>[g]) =
((r \<star> \<theta>) \<cdot> (r \<star> \<theta>' \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, w', w])) \<cdot>
\<a>[r, f, w' \<star> w] \<cdot> ((\<rho> \<star> w' \<star> w) \<cdot> \<a>[g, w', w]) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
using whisker_left comp_assoc
by (simp add: hseqI')
also have "... = ((r \<star> \<theta>) \<cdot> (r \<star> \<theta>' \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, w', w])) \<cdot>
\<a>[r, f, w' \<star> w] \<cdot> (\<a>[r \<star> f, w', w] \<cdot>
((\<rho> \<star> w') \<star> w)) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
using assoc_naturality [of \<rho> w' w] by simp
also have "... = (r \<star> \<theta>) \<cdot> (r \<star> \<theta>' \<star> w) \<cdot>
((r \<star> \<a>\<^sup>-\<^sup>1[f, w', w]) \<cdot> \<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w]) \<cdot>
((\<rho> \<star> w') \<star> w) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
using comp_assoc by simp
also have "... = (r \<star> \<theta>) \<cdot> ((r \<star> \<theta>' \<star> w) \<cdot> \<a>[r, f \<star> w', w]) \<cdot>
(\<a>[r, f, w'] \<star> w) \<cdot>
((\<rho> \<star> w') \<star> w) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
proof -
have "seq \<a>[r, f, w' \<star> w] \<a>[r \<star> f, w', w]" by simp
moreover have "inv (r \<star> \<a>[f, w', w]) = r \<star> \<a>\<^sup>-\<^sup>1[f, w', w]"
by simp
moreover have "(r \<star> \<a>[f, w', w]) \<cdot> \<a>[r, f \<star> w', w] \<cdot> (\<a>[r, f, w'] \<star> w) =
\<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w]"
using pentagon by simp
ultimately have "(r \<star> \<a>\<^sup>-\<^sup>1[f, w', w]) \<cdot> \<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w] =
\<a>[r, f \<star> w', w] \<cdot> (\<a>[r, f, w'] \<star> w)"
using iso_assoc [of f w' w] iso_hcomp
invert_side_of_triangle(1)
[of "\<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w]" "r \<star> \<a>[f, w', w]"
"\<a>[r, f \<star> w', w] \<cdot> (\<a>[r, f, w'] \<star> w)"]
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot>
(((r \<star> \<theta>') \<star> w) \<cdot> (\<a>[r, f, w'] \<star> w) \<cdot> ((\<rho> \<star> w') \<star> w)) \<cdot>
(\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
proof -
have "(r \<star> \<theta>' \<star> w) \<cdot> \<a>[r, f \<star> w', w] = \<a>[r, f', w] \<cdot> ((r \<star> \<theta>') \<star> w)"
using assoc_naturality [of r \<theta>' w] by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> (composite_cell w' \<theta>' \<star> w) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
using whisker_right
by (metis T'.uw\<theta>\<omega> T'.w_in_hom(1) composite_cell_in_hom T'.\<theta>_simps(2) T'.ide_w
T.ide_w arrI seqE)
also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> ((\<rho>' \<cdot> inv \<nu>' \<star> w) \<cdot> (\<nu>' \<star> w)) \<cdot> \<nu> \<cdot> \<r>[g]"
proof -
have "composite_cell w' \<theta>' = \<rho>' \<cdot> inv \<nu>'"
using assms invert_side_of_triangle(2) T.tab_simps(1) comp_assoc by presburger
thus ?thesis
using comp_assoc by simp
qed
also have "... = (T.composite_cell w \<theta> \<cdot> \<nu>) \<cdot> \<r>[g]"
using whisker_right [of w "\<rho>' \<cdot> inv \<nu>'" \<nu>'] dom_\<nu>' comp_assoc comp_inv_arr'
comp_arr_dom
by simp
also have "... = \<rho> \<cdot> \<r>[g]"
using assms(2) comp_assoc by simp
also have "... = composite_cell (src f) \<r>[f]"
using comp_assoc runit_hcomp runit_naturality [of \<rho>] by simp
finally show ?thesis by simp
qed
have eq': "(r \<star> \<r>[f]) \<cdot> \<a>[r, f, src f] \<cdot> (\<rho> \<star> src f) \<cdot> (inv (?\<nu>'\<nu> \<cdot> \<r>[g])) =
composite_cell (w' \<star> w) ?\<theta>\<theta>'"
proof -
have 1: "composite_cell (src f) \<r>[f] = (composite_cell (w' \<star> w) ?\<theta>\<theta>') \<cdot> ?\<nu>'\<nu> \<cdot> \<r>[g]"
using eq comp_assoc by simp
have "composite_cell (src f) \<r>[f] \<cdot> (inv (?\<nu>'\<nu> \<cdot> \<r>[g])) = composite_cell (w' \<star> w) ?\<theta>\<theta>'"
proof -
have "seq (r \<star> \<r>[f]) (\<a>[r, f, src f] \<cdot> (\<rho> \<star> src f))"
by fastforce
thus ?thesis
using iso_\<nu>'\<nu>_r 1 invert_side_of_triangle(2) by simp
qed
thus ?thesis
using comp_assoc by simp
qed
have \<nu>'\<nu>_r: "\<guillemotleft>?\<nu>'\<nu> \<cdot> \<r>[g] : g \<star> src f \<Rightarrow> g \<star> w' \<star> w\<guillemotright>"
by force
have inv_\<nu>'\<nu>_r: "\<guillemotleft>inv (?\<nu>'\<nu> \<cdot> \<r>[g]) : g \<star> w' \<star> w \<Rightarrow> g \<star> src f\<guillemotright>"
using \<nu>'\<nu> iso_\<nu>'\<nu>_r by simp
let ?P = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> ?\<nu>'\<nu> \<cdot> \<r>[g] = dom \<rho> \<star> \<gamma> \<and> \<r>[f] = ?\<theta>\<theta>' \<cdot> (f \<star> \<gamma>)"
let ?\<gamma> = "THE \<gamma>. ?P \<gamma>"
have "?P ?\<gamma>"
proof -
have "\<exists>!\<gamma>. ?P \<gamma>"
using \<nu>'\<nu>_r \<theta>\<theta>' eq T2 [of "src f" "w' \<star> w" "\<r>[f]" f ?\<theta>\<theta>' "?\<nu>'\<nu> \<cdot> \<r>[g]"] by simp
thus ?thesis
using the1_equality [of ?P] by blast
qed
hence \<gamma>: "\<guillemotleft>?\<gamma> : src f \<rightarrow> src f\<guillemotright> \<and> ?P ?\<gamma>"
using src_dom trg_dom by fastforce
let ?P' = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w' \<star> w \<Rightarrow> src f\<guillemotright> \<and> inv (?\<nu>'\<nu> \<cdot> \<r>[g]) = g \<star> \<gamma> \<and> ?\<theta>\<theta>' = \<r>[f] \<cdot> (f \<star> \<gamma>)"
let ?\<gamma>' = "THE \<gamma>. ?P' \<gamma>"
have "?P' ?\<gamma>'"
proof -
have "\<exists>!\<gamma>. ?P' \<gamma>"
using inv_\<nu>'\<nu>_r \<theta>\<theta>' eq' T2 comp_assoc by simp
thus ?thesis
using the1_equality [of ?P'] by blast
qed
hence \<gamma>': "\<guillemotleft>?\<gamma>' : src f \<rightarrow> src f\<guillemotright> \<and> ?P' ?\<gamma>'"
using src_dom trg_dom by fastforce
have "inverse_arrows ?\<gamma> ?\<gamma>'"
proof
let ?Q = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : src f \<Rightarrow> src f\<guillemotright> \<and> dom \<rho> \<star> src f = g \<star> \<gamma> \<and> \<r>[f] = \<r>[f] \<cdot> (f \<star> \<gamma>)"
have "\<exists>!\<gamma>. ?Q \<gamma>"
proof -
have "ide (src f)" by simp
moreover have "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>" by simp
moreover have "\<guillemotleft>dom \<rho> \<star> src f : g \<star> src f \<Rightarrow> g \<star> src f\<guillemotright>" by auto
moreover have "(\<rho> \<star> src f) \<cdot> (dom \<rho> \<star> src f) = \<rho> \<star> src f"
using comp_arr_dom hcomp_simps(3) [of \<rho> "src f"]
by (metis (full_types) R.preserves_arr tab_simps(1) tab_simps(2) dom_src)
ultimately show ?thesis
using comp_arr_dom T2 [of "src f" "src f" "\<r>[f]" f "\<r>[f]" "dom \<rho> \<star> src f"]
comp_assoc
by metis
qed
moreover have "?Q (src f)"
using comp_arr_dom by auto
moreover have "?Q (?\<gamma>' \<cdot> ?\<gamma>)"
proof (intro conjI)
show "\<guillemotleft>?\<gamma>' \<cdot> ?\<gamma> : src f \<Rightarrow> src f\<guillemotright>"
using \<gamma> \<gamma>' by auto
show "dom \<rho> \<star> src f = g \<star> ?\<gamma>' \<cdot> ?\<gamma>"
proof -
have "g \<star> ?\<gamma>' \<cdot> ?\<gamma> = (g \<star> ?\<gamma>') \<cdot> (g \<star> ?\<gamma>)"
using \<gamma> \<gamma>' whisker_left by fastforce
also have "... = inv (?\<nu>'\<nu> \<cdot> \<r>[g]) \<cdot> (?\<nu>'\<nu> \<cdot> \<r>[g])"
using \<gamma> \<gamma>' by simp
also have "... = dom \<rho> \<star> src f"
using \<nu>'\<nu> iso_\<nu>'\<nu>_r comp_inv_arr inv_is_inverse by auto
finally show ?thesis by simp
qed
show "\<r>[f] = \<r>[f] \<cdot> (f \<star> ?\<gamma>' \<cdot> ?\<gamma>)"
proof -
have "\<r>[f] \<cdot> (f \<star> ?\<gamma>' \<cdot> ?\<gamma>) = \<r>[f] \<cdot> (f \<star> ?\<gamma>') \<cdot> (f \<star> ?\<gamma>)"
using \<gamma> \<gamma>' whisker_left by fastforce
also have "... = (\<r>[f] \<cdot> (f \<star> ?\<gamma>')) \<cdot> (f \<star> ?\<gamma>)"
using comp_assoc by simp
also have "... = \<r>[f]"
using \<gamma> \<gamma>' by simp
finally show ?thesis by simp
qed
qed
ultimately have "?\<gamma>' \<cdot> ?\<gamma> = src f" by blast
thus "ide (?\<gamma>' \<cdot> ?\<gamma>)" by simp
let ?Q' = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w' \<star> w \<Rightarrow> w' \<star> w\<guillemotright> \<and> g \<star> w' \<star> w = g \<star> \<gamma> \<and> ?\<theta>\<theta>' = ?\<theta>\<theta>' \<cdot> (f \<star> \<gamma>)"
have "\<exists>!\<gamma>. ?Q' \<gamma>"
proof -
have "ide (w' \<star> w)" by simp
moreover have "\<guillemotleft>?\<theta>\<theta>' : f \<star> w' \<star> w \<Rightarrow> f\<guillemotright>"
using \<theta>\<theta>' by simp
moreover have "\<guillemotleft>g \<star> w' \<star> w : g \<star> w' \<star> w \<Rightarrow> g \<star> w' \<star> w\<guillemotright>"
by auto
moreover have
"composite_cell (w' \<star> w) ?\<theta>\<theta>' = composite_cell (w' \<star> w) ?\<theta>\<theta>' \<cdot> (g \<star> w' \<star> w)"
proof -
have "\<guillemotleft>\<rho> \<star> w' \<star> w : g \<star> w' \<star> w \<Rightarrow> (r \<star> f) \<star> w' \<star> w\<guillemotright>"
by (intro hcomp_in_vhom, auto)
hence "(\<rho> \<star> w' \<star> w) \<cdot> (g \<star> w' \<star> w) = \<rho> \<star> w' \<star> w"
using comp_arr_dom by auto
thus ?thesis
using comp_assoc by simp
qed
ultimately show ?thesis
using T2 by auto
qed
moreover have "?Q' (w' \<star> w)"
using \<theta>\<theta>' comp_arr_dom by auto
moreover have "?Q' (?\<gamma> \<cdot> ?\<gamma>')"
proof (intro conjI)
show "\<guillemotleft>?\<gamma> \<cdot> ?\<gamma>' : w' \<star> w \<Rightarrow> w' \<star> w\<guillemotright>"
using \<gamma> \<gamma>' by auto
show "g \<star> w' \<star> w = g \<star> ?\<gamma> \<cdot> ?\<gamma>'"
proof -
have "g \<star> ?\<gamma> \<cdot> ?\<gamma>' = (g \<star> ?\<gamma>) \<cdot> (g \<star> ?\<gamma>')"
using \<gamma> \<gamma>' whisker_left by fastforce
also have "... = (?\<nu>'\<nu> \<cdot> \<r>[g]) \<cdot> inv (?\<nu>'\<nu> \<cdot> \<r>[g])"
using \<gamma> \<gamma>' by simp
also have "... = g \<star> w' \<star> w"
using \<nu>'\<nu> iso_\<nu>'\<nu>_r comp_arr_inv inv_is_inverse by auto
finally show ?thesis by simp
qed
show "?\<theta>\<theta>' = ?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma> \<cdot> ?\<gamma>')"
proof -
have "?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma> \<cdot> ?\<gamma>') = ?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma>) \<cdot> (f \<star> ?\<gamma>')"
using \<gamma> \<gamma>' whisker_left by fastforce
also have "... = (?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma>)) \<cdot> (f \<star> ?\<gamma>')"
using comp_assoc by simp
also have "... = ?\<theta>\<theta>'"
using \<gamma> \<gamma>' by simp
finally show ?thesis by simp
qed
qed
ultimately have "?\<gamma> \<cdot> ?\<gamma>' = w' \<star> w" by blast
thus "ide (?\<gamma> \<cdot> ?\<gamma>')" by simp
qed
hence "\<guillemotleft>?\<gamma> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> iso ?\<gamma>"
using \<gamma> by auto
thus ?thesis by auto
qed
text \<open>
Now we can show that, given two tabulations of the same 1-cell,
there is an equivalence map between the apexes that extends to a transformation
of one tabulation into the other.
\<close>
lemma apex_unique_up_to_equivalence:
assumes "tabulation V H \<a> \<i> src trg r \<rho>' f' g'"
shows "\<exists>w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
equivalence_in_bicategory V H \<a> \<i> src trg w' w \<psi> \<phi> \<and>
\<guillemotleft>w : src f \<rightarrow> src f'\<guillemotright> \<and> \<guillemotleft>w' : src f' \<rightarrow> src f\<guillemotright> \<and>
\<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> f\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu> \<and>
\<rho> = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> (\<rho>' \<star> w) \<cdot> \<nu> \<and>
\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>\<nu>' : g' \<Rightarrow> g \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
\<rho>' = (r \<star> \<theta>') \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<nu>'"
proof -
interpret T': tabulation V H \<a> \<i> src trg r \<rho>' f' g'
using assms by auto
obtain w \<theta> \<nu>
where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> f\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu> \<and>
\<rho> = T'.composite_cell w \<theta> \<cdot> \<nu>"
using T'.T1 [of f \<rho>] ide_leg0 tab_in_hom by auto
obtain w' \<theta>' \<nu>'
where w'\<theta>'\<nu>': "ide w' \<and> \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>\<nu>' : g' \<Rightarrow> g \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
\<rho>' = composite_cell w' \<theta>' \<cdot> \<nu>'"
using T1 [of f' \<rho>'] T'.ide_leg0 T'.tab_in_hom by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> iso \<phi>"
using w\<theta>\<nu> w'\<theta>'\<nu>' apex_equivalence_lemma T'.tab_in_hom comp_assoc by metis
obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : src f' \<Rightarrow> w \<star> w'\<guillemotright> \<and> iso \<psi>"
using w\<theta>\<nu> w'\<theta>'\<nu>' T'.apex_equivalence_lemma tab_in_hom comp_assoc by metis
have 1: "src f = src w"
using \<phi> src_dom [of \<phi>] hcomp_simps(1) [of w' w]
by (metis arr_cod leg0_simps(2) in_homE src_cod src_src)
have 2: "src f' = src w'"
using \<psi> src_dom [of \<psi>] hcomp_simps(1) [of w w']
by (metis arr_cod T'.leg0_simps(2) in_homE src_cod src_src)
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg w' w \<psi> \<open>inv \<phi>\<close>
using \<phi> \<psi> 1 2 w\<theta>\<nu> w'\<theta>'\<nu>' iso_inv_iso
apply unfold_locales by auto
have "\<guillemotleft>w : src f \<rightarrow> src f'\<guillemotright>"
using \<psi> w\<theta>\<nu> 1 2 trg_cod hcomp_simps(2) E.antipar(1) by simp
moreover have "\<guillemotleft>w' : src f' \<rightarrow> src f\<guillemotright>"
using \<phi> w'\<theta>'\<nu>' 1 2 E.antipar(2) by simp
ultimately show ?thesis
using E.equivalence_in_bicategory_axioms w\<theta>\<nu> w'\<theta>'\<nu>' comp_assoc by metis
qed
end
subsection "`Tabulation' is Bicategorical"
text \<open>
In this section we show that ``tabulation'' is a truly bicategorical notion,
in the sense that tabulations are preserved and reflected by equivalence pseudofunctors.
The proofs given here is are elementary proofs from first principles.
It should also be possible to give a proof based on birepresentations,
but for this to actually save work it would first be necessary to carry out a general
development of birepresentations and bicategorical limits, and I have chosen not to
attempt this here.
\<close>
(*
* TODO: The fully_faithful_and_essentially_surjective_functor locale should have arguments in
* same order as functor, faithful_functor, etc.
* The equivalence_functor definition can reverse the arguments for consistency
* with the definition of adjoint equivalence.
*)
context equivalence_pseudofunctor
begin
lemma preserves_tabulation:
assumes "tabulation (\<cdot>\<^sub>C) (\<star>\<^sub>C) \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g"
shows "tabulation (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F r) (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>) (F f) (F g)"
proof -
let ?\<rho>' = "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>"
interpret T: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f
using assms by auto
interpret T': tabulation_data V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F r\<close> ?\<rho>' \<open>F f\<close> \<open>F g\<close>
using \<Phi>_in_hom \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char
apply unfold_locales
apply auto
by (intro D.comp_in_homI, auto)
interpret T': tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F r\<close> ?\<rho>' \<open>F f\<close> \<open>F g\<close>
text \<open>
How bad can it be to just show this directly from first principles?
It is worse than it at first seems, once you start filling in the details!
\<close>
proof
fix u' \<omega>'
assume u': "D.ide u'"
assume \<omega>': "\<guillemotleft>\<omega>' : D.dom \<omega>' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u'\<guillemotright>"
show "\<exists>w' \<theta>' \<nu>'. D.ide w' \<and> \<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u'\<guillemotright> \<and>
\<guillemotleft>\<nu>' : D.dom \<omega>' \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright> \<and> D.iso \<nu>' \<and>
T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' = \<omega>'"
proof -
text \<open>
First, obtain \<open>\<omega>\<close> in \<open>C\<close> such that \<open>F \<omega>\<close> is related to \<open>\<omega>'\<close> by an equivalence in \<open>D\<close>.
\<close>
define v' where "v' = D.dom \<omega>'"
have v': "D.ide v'"
using assms v'_def D.ide_dom \<omega>' by blast
have \<omega>': "\<guillemotleft>\<omega>' : v' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u'\<guillemotright>"
using v'_def \<omega>' by simp
define a' where "a' = src\<^sub>D \<omega>'"
have [simp]: "src\<^sub>D u' = a'"
using a'_def \<omega>'
by (metis D.arr_cod D.ide_char D.in_homE D.src.preserves_cod D.src_dom
D.src_hcomp' v')
have [simp]: "trg\<^sub>D u' = src\<^sub>D (F r)"
using \<omega>'
by (metis D.cod_trg D.in_homE D.not_arr_null D.seq_if_composable D.trg.is_extensional
D.trg.preserves_arr D.trg.preserves_cod)
have [simp]: "src\<^sub>D v' = a'"
using v'_def \<omega>' a'_def by auto
have [simp]: "trg\<^sub>D v' = trg\<^sub>D (F r)"
using v'_def
by (metis D.cod_trg D.hseqI' D.ideD(1) D.in_homE D.trg.preserves_hom D.trg_dom
D.hcomp_simps(2) T'.base_simps(2) \<omega>' \<open>trg\<^sub>D u' = src\<^sub>D (F r)\<close> u')
have [simp]: "src\<^sub>D \<omega>' = a'"
using \<omega>' a'_def by blast
have [simp]: "trg\<^sub>D \<omega>' = trg\<^sub>D (F r)"
using \<omega>' v'_def \<open>trg\<^sub>D v' = trg\<^sub>D (F r)\<close> by auto
obtain a where a: "C.obj a \<and> D.equivalent_objects (map\<^sub>0 a) a'"
using u' \<omega>' a'_def surjective_on_objects_up_to_equivalence D.obj_src by blast
obtain e' where e': "\<guillemotleft>e' : map\<^sub>0 a \<rightarrow>\<^sub>D a'\<guillemotright> \<and> D.equivalence_map e'"
using a D.equivalent_objects_def by auto
have u'_in_hhom: "\<guillemotleft>u' : a' \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C r)\<guillemotright>"
by (simp add: u')
hence 1: "\<guillemotleft>u' \<star>\<^sub>D e' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C r)\<guillemotright>"
using e' by blast
have v'_in_hhom: "\<guillemotleft>v' : a' \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C r)\<guillemotright>"
by (simp add: v')
hence 2: "\<guillemotleft>v' \<star>\<^sub>D e' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C r)\<guillemotright>"
using e' by blast
obtain d' \<eta>' \<epsilon>'
where d'\<eta>'\<epsilon>': "adjoint_equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e' d' \<eta>' \<epsilon>'"
using e' D.equivalence_map_extends_to_adjoint_equivalence by blast
interpret e': adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e' d' \<eta>' \<epsilon>'
using d'\<eta>'\<epsilon>' by auto
interpret d': adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
d' e' "D.inv \<epsilon>'" "D.inv \<eta>'"
using e'.dual_adjoint_equivalence by simp
have [simp]: "src\<^sub>D e' = map\<^sub>0 a"
using e' by auto
have [simp]: "trg\<^sub>D e' = a'"
using e' by auto
have [simp]: "src\<^sub>D d' = a'"
by (simp add: e'.antipar(2))
have [simp]: "trg\<^sub>D d' = map\<^sub>0 a"
using e'.antipar by simp
obtain u where u: "\<guillemotleft>u : a \<rightarrow>\<^sub>C src\<^sub>C r\<guillemotright> \<and> C.ide u \<and> D.isomorphic (F u) (u' \<star>\<^sub>D e')"
using a e' u' 1 u'_in_hhom locally_essentially_surjective [of a "src\<^sub>C r" "u' \<star>\<^sub>D e'"]
C.obj_src D.equivalence_map_is_ide T.base_simps(2)
by blast
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : u' \<star>\<^sub>D e' \<Rightarrow>\<^sub>D F u\<guillemotright> \<and> D.iso \<phi>"
using u D.isomorphic_symmetric by blast
obtain v where v: "\<guillemotleft>v : a \<rightarrow>\<^sub>C trg\<^sub>C r\<guillemotright> \<and> C.ide v \<and> D.isomorphic (F v) (v' \<star>\<^sub>D e')"
using a e' v' v'_in_hhom locally_essentially_surjective [of a "trg\<^sub>C r" "v' \<star>\<^sub>D e'"]
C.obj_trg D.equivalence_map_is_ide T.base_simps(2)
by blast
obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : F v \<Rightarrow>\<^sub>D v' \<star>\<^sub>D e'\<guillemotright> \<and> D.iso \<psi>"
using v by blast
have [simp]: "src\<^sub>C u = a" using u by auto
have [simp]: "trg\<^sub>C u = src\<^sub>C r" using u by auto
have [simp]: "src\<^sub>C v = a" using v by auto
have [simp]: "trg\<^sub>C v = trg\<^sub>C r" using v by auto
have [simp]: "src\<^sub>D \<phi> = map\<^sub>0 a"
using \<phi> by (metis "1" D.dom_src D.in_hhomE D.in_homE D.src.preserves_dom)
have [simp]: "trg\<^sub>D \<phi> = trg\<^sub>D u'"
using \<phi>
by (metis D.cod_trg D.hseqI D.in_homE D.isomorphic_implies_hpar(4)
D.trg.preserves_cod D.trg_hcomp' e' u u'_in_hhom)
have [simp]: "src\<^sub>D \<psi> = map\<^sub>0 a"
using \<psi>
by (metis C.in_hhomE D.in_homE D.src_dom \<open>src\<^sub>D e' = map\<^sub>0 a\<close> preserves_src v)
have [simp]: "trg\<^sub>D \<psi> = trg\<^sub>D v'"
using \<psi>
by (metis "2" D.cod_trg D.in_hhomE D.in_homE D.trg.preserves_cod T.base_simps(2)
\<open>trg\<^sub>D v' = trg\<^sub>D (F r)\<close> preserves_trg)
define F\<omega> where "F\<omega> = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi>"
have F\<omega>: "\<guillemotleft>F\<omega> : F v \<Rightarrow>\<^sub>D F (r \<star>\<^sub>C u)\<guillemotright>"
proof (unfold F\<omega>_def, intro D.comp_in_homI)
show "\<guillemotleft>\<psi> : F v \<Rightarrow>\<^sub>D v' \<star>\<^sub>D e'\<guillemotright>"
using \<psi> by simp
show "\<guillemotleft>\<omega>' \<star>\<^sub>D e' : v' \<star>\<^sub>D e' \<Rightarrow>\<^sub>D (F r \<star>\<^sub>D u') \<star>\<^sub>D e'\<guillemotright>"
using e' \<omega>' D.equivalence_map_is_ide v'_in_hhom by blast
show "\<guillemotleft>\<a>\<^sub>D[F r, u', e'] : (F r \<star>\<^sub>D u') \<star>\<^sub>D e' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u' \<star>\<^sub>D e'\<guillemotright>"
using e' u' D.equivalence_map_is_ide D.in_hhom_def u'_in_hhom by auto
show "\<guillemotleft>F r \<star>\<^sub>D \<phi> : F r \<star>\<^sub>D u' \<star>\<^sub>D e' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D F u\<guillemotright>"
using e' u' u \<phi>
by (metis C.in_hhomE D.hcomp_in_vhom D.isomorphic_implies_hpar(4)
T'.base_in_hom(2) T.base_simps(2) preserves_src preserves_trg)
show "\<guillemotleft>\<Phi> (r, u) : F r \<star>\<^sub>D F u \<Rightarrow>\<^sub>D F (r \<star>\<^sub>C u)\<guillemotright>"
using u \<Phi>_in_hom(2) [of r u] by auto
qed
obtain \<omega> where \<omega>: "\<guillemotleft>\<omega> : v \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright> \<and> F \<omega> = F\<omega>"
using u v \<omega>' \<phi> \<psi> F\<omega> locally_full [of v "r \<star>\<^sub>C u" F\<omega>]
by (metis C.ide_hcomp C.hseqI C.in_hhomE C.src_hcomp' C.trg_hcomp'
T.ide_base T.base_in_hom(1))
have [simp]: "src\<^sub>C \<omega> = src\<^sub>C u"
using \<omega>
by (metis C.hseqI C.in_homE C.src_cod C.src_hcomp' T.base_in_hom(1) u)
have [simp]: "trg\<^sub>C \<omega> = trg\<^sub>C r"
using \<omega>
by (metis C.ide_char C.ide_trg C.in_homE C.trg.preserves_hom \<open>trg\<^sub>C v = trg\<^sub>C r\<close>)
text \<open>Apply \<open>T.T1\<close> to \<open>u\<close> and \<open>\<omega>\<close> to obtain \<open>w\<close>, \<open>\<theta>\<close>, \<open>\<nu>\<close>.\<close>
obtain w \<theta> \<nu>
where w\<theta>\<nu>: "C.ide w \<and> \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu> : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<guillemotright> \<and>
C.iso \<nu> \<and> T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu> = \<omega>"
using u \<omega> T.T1 [of u \<omega>] by auto
text \<open>
Combining \<open>\<omega>\<close> and \<open>w\<theta>\<nu>\<close> yields the situation depicted in the diagram below.
In this as well as subsequent diagrams, canonical isomorphisms have been suppressed
in the interests of clarity.
$$
F (
\xy/67pt/
\xymatrix{
& {\scriptstyle{a}}
\xlowertwocell[ddddl]{}_{v}{^\nu}
\xuppertwocell[ddddr]{}^{u}{^\theta}
\ar@ {.>}[dd]^{w}
\\
\\
& \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
\ar[ddl] _{g}
\ar[ddr] ^{f}
\\
\\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
\\
&
}
\endxy
)
\qquad = \qquad
\xy/67pt/
\xymatrix{
& {\scriptstyle{{\rm src}(F a)}}
\xlowertwocell[ddddl]{}^{<2>F v}{^{\psi}}
\xuppertwocell[ddddr]{}^{<2>F u}{^{\phi}}
\ar[dd] ^{e'}
\\
\\
& \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
\ar[ddl] _{v'}
\ar[ddr] ^{u'}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
$$
\<close>
have [simp]: "src\<^sub>C w = src\<^sub>C u"
by (metis C.arrI C.seqE C.src_hcomp' C.src_vcomp C.vseq_implies_hpar(1)
\<omega> \<open>src\<^sub>C \<omega> = src\<^sub>C u\<close> w\<theta>\<nu>)
have [simp]: "trg\<^sub>C w = src\<^sub>C f"
by (metis C.arrI C.hseq_char C.seqE T.tab_simps(2) \<omega> w\<theta>\<nu>)
have [simp]: "src\<^sub>D (F u) = map\<^sub>0 a"
using e'.antipar(1) u by auto
have [simp]: "src\<^sub>D (F v) = map\<^sub>0 a"
using v e' e'.antipar by force
have [simp]: "src\<^sub>D (F w) = map\<^sub>0 a"
by (simp add: w\<theta>\<nu>)
have *: "F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) =
\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu>"
text \<open>
$$
F (
\xy/67pt/
\xymatrix{
& {\scriptstyle{a}}
\xlowertwocell[ddddl]{}_{v}{^\nu}
\xuppertwocell[ddddr]{}^{u}{^\theta}
\ar[dd] ^{w}
\\
\\
& \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
\ar[ddl] _{g}
\ar[ddr] ^{f}
\\
\\
\scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
\\
&
}
\endxy
)
\qquad = \qquad
\xy/67pt/
\xymatrix{
& {\scriptstyle{{\rm src}(F a)}}
\xlowertwocell[ddddl]{}^{<2>F v}{^{F \nu}}
\xuppertwocell[ddddr]{}^{<2>F u}{^{F \theta}}
\ar[dd] ^{Fw}
\\
\\
& \scriptstyle{{\rm src}(F g) \;=\;{\rm src}(F f)} \xtwocell[ddd]{}\omit{^{F \rho}}
\ar[ddl] _{F g}
\ar[ddr] ^{F f}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
$$
\<close>
proof -
have "F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) = F ((r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>C \<a>\<^sub>C[r, f, w] \<cdot>\<^sub>C (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>C \<nu>)"
using C.comp_assoc by simp
also have "... = F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D F \<nu>"
by (metis C.arr_dom_iff_arr C.comp_assoc C.in_homE C.seqE preserves_comp_2 w\<theta>\<nu>)
also have "... =
F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D (\<Phi> (r, f \<star>\<^sub>C w) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w))) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D F \<nu>"
using \<omega> w\<theta>\<nu> preserves_assoc [of r f w]
by (metis C.hseqE C.in_homE C.seqE T.tab_simps(2) T.ide_leg0 T.ide_base
T.leg0_simps(3))
also have "... =
((F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w))) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D F \<nu>"
using D.comp_assoc by simp
also have "... =
\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w)) \<cdot>\<^sub>D F \<nu>"
proof -
have "(F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) =
(\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)))"
proof -
have "F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w) = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>)"
using \<omega> \<Phi>.naturality [of "(r, \<theta>)"] FF_def w\<theta>\<nu> C.VV.arr_char
apply simp
by (metis (no_types, lifting) C.hseqE C.in_homE C.seqE)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
proof -
have "(F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) = F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)"
using \<omega> w\<theta>\<nu> D.whisker_right [of "F r" "F \<theta>" "\<Phi> (f, w)"]
by (metis C.hseqE C.in_homE C.seqE D.comp_ide_self D.interchange D.seqI'
T'.ide_base T'.base_in_hom(2) T.tab_simps(2) T.ide_leg0 \<Phi>_in_hom(2)
preserves_hom)
thus ?thesis by simp
qed
finally have "(F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) =
\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))) \<cdot>\<^sub>D F \<nu>"
proof -
have "(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) =
((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w)) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
proof -
have "D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) = (F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
proof -
have "src\<^sub>C (r \<star>\<^sub>C f) = trg\<^sub>C w"
using \<omega> w\<theta>\<nu>
by (metis C.arrI C.hseq_char C.seqE C.hcomp_simps(1) T.tab_simps(2)
T.leg0_simps(2) T.leg0_simps(3))
hence "D.seq (\<Phi> (r \<star>\<^sub>C f, w)) (F \<rho> \<star>\<^sub>D F w)"
using \<omega> w\<theta>\<nu> \<Phi>_in_hom(2) [of "r \<star>\<^sub>C f" w] C.VV.arr_char FF_def
apply (intro D.seqI D.hseqI')
apply auto
using \<omega> w\<theta>\<nu> T.tab_in_hom preserves_cod [of "\<rho> \<star>\<^sub>C w"] D.hseqI'
by force
moreover have "\<Phi> (r \<star>\<^sub>C f, w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w) = F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D \<Phi> (g, w)"
using \<omega> w\<theta>\<nu> \<Phi>.naturality [of "(\<rho>, w)"] \<Phi>_components_are_iso FF_def
C.VV.arr_char
by simp
moreover have "D.iso (\<Phi> (r \<star>\<^sub>C f, w))"
using w\<theta>\<nu> \<Phi>_components_are_iso
by (metis C.arrI C.ide_hcomp C.hseqE C.hseqI' C.seqE C.src_hcomp'
T.tab_simps(2) T.ide_leg0 T.ide_base T.leg0_simps(2) T.leg0_simps(3) \<omega>)
moreover have "D.iso (\<Phi> (g, w))"
using w\<theta>\<nu> \<Phi>_components_are_iso
by (metis C.arrI C.hseqE C.seqE T.tab_simps(2) T.ide_leg1 T.leg1_simps(3) \<omega>)
ultimately show ?thesis
using \<omega> w\<theta>\<nu> \<Phi>.naturality \<Phi>_components_are_iso FF_def C.VV.arr_char
D.invert_opposite_sides_of_square
by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
using \<omega> w\<theta>\<nu> D.whisker_right \<Phi>_components_are_iso \<Phi>_in_hom D.comp_assoc
by auto
finally show ?thesis
using D.comp_assoc by simp
qed
finally show ?thesis
using D.comp_assoc by simp
qed
text \<open>We can now define the \<open>w'\<close>, \<open>\<theta>'\<close>, and \<open>\<nu>'\<close> that we are required to exhibit.\<close>
define \<phi>' where "\<phi>' = e'.trnr\<^sub>\<epsilon> u' (D.inv \<phi>)"
have "\<phi>' = \<r>\<^sub>D[u'] \<cdot>\<^sub>D (u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')"
unfolding \<phi>'_def e'.trnr\<^sub>\<epsilon>_def by simp
have \<phi>': "\<guillemotleft>\<phi>' : F u \<star>\<^sub>D d' \<Rightarrow>\<^sub>D u'\<guillemotright>"
using \<phi> \<phi>'_def u u' e'.adjoint_transpose_right(2) [of u' "F u"] by auto
have [simp]: "src\<^sub>D \<phi>' = src\<^sub>D u'"
using \<phi>' by fastforce
have [simp]: "trg\<^sub>D \<phi>' = trg\<^sub>D u'"
using \<phi>' by fastforce
define \<psi>' where "\<psi>' = d'.trnr\<^sub>\<eta> v' (D.inv \<psi>)"
have \<psi>'_eq: "\<psi>' = (D.inv \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
unfolding \<psi>'_def d'.trnr\<^sub>\<eta>_def by simp
have \<psi>': "\<guillemotleft>\<psi>' : v' \<Rightarrow>\<^sub>D F v \<star>\<^sub>D d'\<guillemotright>"
using \<psi> \<psi>'_def v v' d'.adjoint_transpose_right(1) [of "F v" v'] by auto
have iso_\<psi>': "D.iso \<psi>'"
unfolding \<psi>'_def d'.trnr\<^sub>\<eta>_def
using \<psi> e'.counit_is_iso
by (metis D.arrI D.iso_hcomp D.hseq_char D.ide_is_iso D.iso_assoc'
D.iso_inv_iso D.iso_runit' D.isos_compose D.seqE \<psi>'_eq
\<psi>' d'.unit_simps(5) e'.antipar(1) e'.antipar(2) e'.ide_left e'.ide_right v')
have [simp]: "src\<^sub>D \<psi>' = src\<^sub>D v'"
using \<psi>' by fastforce
have [simp]: "trg\<^sub>D \<psi>' = trg\<^sub>D v'"
using \<psi>' by fastforce
define w' where "w' = F w \<star>\<^sub>D d'"
define \<theta>' where "\<theta>' = \<phi>' \<cdot>\<^sub>D (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']"
define \<nu>' where "\<nu>' = \<a>\<^sub>D[F g, F w, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
have w': "D.ide w' \<and> \<guillemotleft>w' : src\<^sub>D u' \<rightarrow>\<^sub>D src\<^sub>D (F f)\<guillemotright>"
using w'_def \<omega> w\<theta>\<nu> by simp
have \<theta>': "\<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u'\<guillemotright>"
unfolding \<theta>'_def w'_def
using \<phi>' \<omega> w\<theta>\<nu> \<Phi>_in_hom
apply (intro D.comp_in_homI D.hcomp_in_vhom)
apply auto
by (intro D.comp_in_homI D.hcomp_in_vhom, auto)
have \<nu>': "\<guillemotleft>\<nu>' : v' \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright>"
unfolding \<nu>'_def w'_def
using \<psi>' \<omega> w\<theta>\<nu> \<Phi>_in_hom \<Phi>_components_are_iso
apply (intro D.comp_in_homI)
apply auto
by (intro D.hcomp_in_vhom D.comp_in_homI, auto)
have iso_\<nu>': "D.iso \<nu>'"
using \<nu>'_def iso_\<psi>' \<Phi>_in_hom \<Phi>.components_are_iso D.isos_compose preserves_iso
by (metis (no_types, lifting) C.ideD(1) D.arrI D.iso_hcomp D.hseqE D.ide_is_iso
D.iso_assoc D.iso_inv_iso D.seqE T.ide_leg1 T.leg1_simps(3) \<Phi>_components_are_iso
\<nu>' \<open>src\<^sub>D (F w) = map\<^sub>0 a\<close> \<open>src\<^sub>D e' = map\<^sub>0 a\<close> \<open>trg\<^sub>C w = src\<^sub>C f\<close> e'.antipar(1)
e'.ide_right preserves_ide preserves_src preserves_trg w\<theta>\<nu>)
have "T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' = \<omega>'"
text \<open>
$$
\xy/67pt/
\xymatrix{
&
\xlowertwocell[ddddddl]{\scriptstyle{a'}}<-13>^{<2>v'}{^{\psi'}}
\xuppertwocell[ddddddr]{}<13>^{<2>u'}{^{\phi'}}
\ar [dd] ^{d'}
\\
\\
& {\scriptstyle{{\rm src}(F g) \;=\;{\rm src}(F f)}}
\xlowertwocell[ddddl]{}^{<2>F v}{^{F \nu}}
\xuppertwocell[ddddr]{}^{<2>F u}{^{F \theta}}
\ar[dd] ^{Fw}
\\
\\
& \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{F \rho}}
\ar[ddl] _{F g}
\ar[ddr] ^{F f}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
\qquad = \qquad
\xy/33pt/
\xymatrix{
& \scriptstyle{\scriptstyle{a'}} \xtwocell[ddd]{}\omit{^{\omega'}}
\ar[ddl] _{v'}
\ar[ddr] ^{u'}
\\
\\
\scriptstyle{{\rm trg}~(Fr)} & & \scriptstyle{{\rm src}~(Fr)} \ar[ll] ^{Fr}
\\
&
}
\endxy
$$
\<close>
proof -
have 1: "\<guillemotleft>T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' : v' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u'\<guillemotright>"
using w' \<theta>' \<nu>' w\<theta>\<nu> T'.composite_cell_in_hom by blast
have "T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' =
(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
(F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' =
(F r \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w') \<cdot>\<^sub>D \<a>\<^sub>D[F g, F w, d'] \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using \<theta>'_def \<nu>'_def D.comp_assoc by simp
also have
"... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F w, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using \<theta>' \<theta>'_def w'_def D.comp_assoc D.whisker_left by auto
also have
"... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D (F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, F w, d']) \<cdot>\<^sub>D (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using \<theta>' \<theta>'_def D.whisker_right \<Phi>_in_hom D.comp_assoc by fastforce
also have
"... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D (F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D
\<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d'] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F g, F w, d'] =
\<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d'] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d')"
using D.assoc_naturality [of "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>" "F w" d']
\<Phi>_in_hom \<Phi>_components_are_iso
by (simp add: w\<theta>\<nu>)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d']) \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using 1 D.whisker_left D.comp_assoc
by (metis D.arrI D.hseq_char D.seqE T'.ide_base calculation)
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d']) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "D.seq \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d']"
by (metis 1 D.arrI D.seqE calculation)
moreover have "D.iso (F r \<star>\<^sub>D \<a>\<^sub>D[F f, F w, d'])"
by (simp add: w\<theta>\<nu>)
moreover have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[F f, F w, d']) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']"
using D.inv_hcomp [of "F r" "\<a>\<^sub>D[F f, F w, d']"] by (simp add: w\<theta>\<nu>)
ultimately
have "(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D
\<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d'] =
\<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d')"
using w\<theta>\<nu> D.pentagon
D.invert_side_of_triangle(1)
[of "\<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d']"
"F r \<star>\<^sub>D \<a>\<^sub>D[F f, F w, d']"
"\<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d')"]
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D ((F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F (f \<star>\<^sub>C w), d']) \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "(F r \<star>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d'] =
\<a>\<^sub>D[F r, F (f \<star>\<^sub>C w), d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d')"
using 1 w\<theta>\<nu> D.assoc_naturality [of "F r" "\<Phi> (f, w)" d'] D.hseqI'
\<open>trg\<^sub>C w = src\<^sub>C f\<close> e'.ide_right
by (metis D.arrI D.hseq_char D.ide_char D.seqE T'.base_simps(3)
T'.base_simps(4) T'.leg0_simps(3) T.ide_leg0 \<Phi>_simps(1-5) w'_def)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (((F r \<star>\<^sub>D F \<theta>) \<star>\<^sub>D d') \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d')) \<cdot>\<^sub>D \<psi>'"
proof -
have "src\<^sub>D (F r) = trg\<^sub>D (F \<theta>)"
using w\<theta>\<nu> by (metis C.arrI C.hseqE C.seqE \<omega> preserves_hseq)
moreover have "src\<^sub>D (F \<theta>) = trg\<^sub>D d'"
using w\<theta>\<nu>
by (metis C.arrI C.seqE C.hcomp_simps(1) C.src_vcomp \<omega> \<open>src\<^sub>C \<omega> = src\<^sub>C u\<close>
\<open>src\<^sub>C u = a\<close> \<open>trg\<^sub>D d' = map\<^sub>0 a\<close> preserves_src)
ultimately
have "(F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F (f \<star>\<^sub>C w), d'] =
\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F \<theta>) \<star>\<^sub>D d')"
using w\<theta>\<nu> D.assoc_naturality [of "F r" "F \<theta>" d'] by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
(((F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "((F r \<star>\<^sub>D F \<theta>) \<star>\<^sub>D d') \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
(D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') =
(F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu>
\<star>\<^sub>D d'"
proof -
have "\<guillemotleft>(F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> :
F v \<Rightarrow>\<^sub>D F r \<star>\<^sub>D F u\<guillemotright>"
using w\<theta>\<nu> \<omega> \<Phi>_in_hom
apply (intro D.comp_in_homI)
apply auto
by (intro D.hcomp_in_vhom, auto)
hence "D.arr ((F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu>)"
by auto
thus ?thesis
using D.whisker_right by fastforce
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using w\<theta>\<nu> D.whisker_left \<Phi>_in_hom
by (metis D.seqI' T'.ide_base T.ide_leg0 \<open>trg\<^sub>C w = src\<^sub>C f\<close> preserves_hom)
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<cdot>\<^sub>D
(F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) =
F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)"
proof -
have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) =
(F r \<star>\<^sub>D F u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
using u \<Phi>_components_are_iso
by (simp add: D.comp_inv_arr')
also have "... = F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)"
using u \<omega> w\<theta>\<nu> \<Phi>_in_hom \<open>trg\<^sub>C u = src\<^sub>C r\<close>
D.comp_cod_arr [of "F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)" "F r \<star>\<^sub>D F u"]
by (metis (full_types) "*" D.arrI D.cod_comp D.seqE F\<omega> T.ide_base
\<Phi>_simps(4))
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using D.comp_assoc by simp
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
(\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d' =
(D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d')"
using D.whisker_right \<Phi>_in_hom \<Phi>_components_are_iso
by (metis * D.arrI D.invert_side_of_triangle(1) F\<omega> T.ide_base \<omega>
\<open>trg\<^sub>C u = src\<^sub>C r\<close> e'.ide_right u w\<theta>\<nu>)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
(F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using D.comp_assoc * by simp
finally show ?thesis by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
(F \<omega> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using w\<theta>\<nu> by simp
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
(\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D
\<psi>'"
using \<omega> F\<omega>_def by simp
text \<open>
$$
\xy/67pt/
\xymatrix{
& {\scriptstyle{a'}}
\xlowertwocell[ddddl]{}^{<2>F v}{^{\psi'}}
\xuppertwocell[ddddr]{}^{<2>F u}{^{\phi'}}
\ar@ {.}[dd] ^{d'}
\\
\\
& \scriptstyle{{\rm src}(F a)} \xtwocell[ddd]{}\omit{^{F \omega}}
\ar[ddl] _{F v}
\ar[ddr] ^{F u}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
\qquad = \qquad
\xy/67pt/
\xymatrix{
&
\xlowertwocell[ddddddl]{\scriptstyle{a'}}<-13>^{<2>v'}{^{\psi'}}
\xuppertwocell[ddddddr]{}<13>^{<2>u'}{^{\phi'}}
\ar@ {.}[dd] ^{d'}
\\
\\
& {\scriptstyle{{\rm src}(F a)}}
\xlowertwocell[ddddl]{}^{<2>F v}{^{\psi}}
\xuppertwocell[ddddr]{}^{<2>F u}{^{\phi}}
\ar@ {.}[dd] ^{e'}
\\
\\
& \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
\ar[ddl] _{v'}
\ar[ddr] ^{u'}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
$$
\<close>
also have "... = \<omega>'"
text \<open>
$$
\xy/67pt/
\xymatrix{
&
\xlowertwocell[ddddddl]{\scriptstyle{a'}}<-13>^{<2>v'}{^{\psi'}}
\xuppertwocell[ddddddr]{}<13>^{<2>u'}{^{\phi'}}
\ar[dd] ^{d'}
\\
\\
& {\scriptstyle{{\rm src}(F a)}}
\xlowertwocell[ddddl]{}^{<2>F v}{^{\psi}}
\xuppertwocell[ddddr]{}^{<2>F u}{^{\phi}}
\ar[dd] ^{e'}
\\
\\
& \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
\ar[ddl] _{v'}
\ar[ddr] ^{u'}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
\qquad = \qquad
\xy/33pt/
\xymatrix{
& \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
\ar[ddl] _{v'}
\ar[ddr] ^{u'}
\\
\\
\scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~)(F r)} \ar[ll] ^{F r}
\\
&
}
\endxy
$$
\<close>
proof -
have "(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
(\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>' =
(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<star>\<^sub>D d')) \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using D.whisker_right \<Phi>_in_hom D.comp_assoc
by (metis D.arrI F\<omega> F\<omega>_def e'.ide_right)
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "(D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<star>\<^sub>D d') =
D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<star>\<^sub>D d'"
using \<Phi>_in_hom \<Phi>_components_are_iso D.whisker_right
by (metis C.hseqI D.comp_arr_inv' D.in_homE D.invert_opposite_sides_of_square
D.iso_inv_iso T.ide_base T.base_in_hom(1) \<open>trg\<^sub>C u = src\<^sub>C r\<close> e'.ide_right
preserves_arr u)
also have "... = (F r \<star>\<^sub>D F u) \<star>\<^sub>D d'"
using u \<Phi>_components_are_iso D.comp_inv_arr' by simp
finally have "(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<star>\<^sub>D d')) \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>' =
(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F u) \<star>\<^sub>D d') \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
by simp
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F u) \<star>\<^sub>D d')) \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using D.comp_assoc by auto
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using u D.comp_arr_dom by simp
finally show ?thesis by blast
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<phi>) \<star>\<^sub>D d')) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D
((\<omega>' \<star>\<^sub>D e') \<star>\<^sub>D d') \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have
"(F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d' =
((F r \<star>\<^sub>D \<phi>) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D ((\<omega>' \<star>\<^sub>D e') \<star>\<^sub>D d') \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d')"
using D.whisker_right \<phi> \<phi>' e' e'.antipar(1) u' u'_in_hhom
by (metis D.arrI D.seqE F\<omega> F\<omega>_def e'.ide_right)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D
((\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D ((\<omega>' \<star>\<^sub>D e') \<star>\<^sub>D d')) \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<phi>) \<star>\<^sub>D d') =
(F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d']"
using D.assoc_naturality [of "F r" \<phi> d'] \<phi> by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D
((\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D u', e', d'] \<cdot>\<^sub>D
(\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[v', e', d'])) \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
using F\<omega> F\<omega>_def \<omega>' D.comp_assoc D.hseqI' D.hcomp_reassoc(1) [of \<omega>' e' d']
by (elim D.in_homE, simp)
also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D
(\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
proof -
have "D.seq (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d'])
(\<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d'))"
using u' by (simp add: D.hseqI')
moreover have "(F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D
(\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') =
\<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D u', e', d']"
using u' D.pentagon by simp
moreover have "D.iso (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d'])"
using u' by simp
moreover have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"
using u' by simp
ultimately
have "\<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D u', e', d'] =
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']"
using u' D.comp_assoc D.hseqI'
D.invert_opposite_sides_of_square
[of "F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']"
"\<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d')"
"\<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']" "\<a>\<^sub>D[F r \<star>\<^sub>D u', e', d']"]
by simp
thus ?thesis
using D.comp_assoc by metis
qed
also have
"... = (F r \<star>\<^sub>D \<r>\<^sub>D[u'] \<cdot>\<^sub>D (u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D
(\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
unfolding \<phi>'_def \<psi>'_def e'.trnr\<^sub>\<epsilon>_def d'.trnr\<^sub>\<eta>_def by simp
also have
"... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
(F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] \<cdot>\<^sub>D
(v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "F r \<star>\<^sub>D \<r>\<^sub>D[u'] \<cdot>\<^sub>D (u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d') =
(F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
(F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d')"
proof -
have "D.ide (F r)" by simp
moreover have "D.seq \<r>\<^sub>D[u'] ((u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')) \<and>
D.seq (u' \<star>\<^sub>D \<epsilon>') (\<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')) \<and>
D.seq \<a>\<^sub>D[u', e', d'] (D.inv \<phi> \<star>\<^sub>D d')"
using \<phi>' \<phi>'_def unfolding e'.trnr\<^sub>\<epsilon>_def by blast
ultimately show ?thesis
using D.whisker_left by metis
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
(((F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D
\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D (((\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d')) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']) \<cdot>\<^sub>D
(v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
using D.comp_assoc by simp
also have
"... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D
((\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']) \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>')) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "((F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) =
F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"
proof -
have "(F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') = F r \<star>\<^sub>D D.inv \<phi> \<cdot>\<^sub>D \<phi> \<star>\<^sub>D d'"
using u u' \<phi> 1 2 D.src_dom e'.antipar D.hseqI' D.whisker_left D.whisker_right
by auto
also have "... = F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d'"
using \<phi> D.comp_inv_arr' by auto
finally have
"(F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') = F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d'"
by simp
hence
"((F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) =
(F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])"
using D.comp_assoc by simp
also have "... = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"
proof -
have "\<guillemotleft>F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'] :
F r \<star>\<^sub>D u' \<star>\<^sub>D e' \<star>\<^sub>D d' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d'\<guillemotright>"
using u' e'.antipar \<phi>' D.assoc'_in_hom
unfolding e'.trnr\<^sub>\<epsilon>_def
by (intro D.hcomp_in_vhom, auto)
thus ?thesis
using D.comp_cod_arr by blast
qed
finally show ?thesis by simp
qed
moreover have
"((\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d')) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] = \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']"
proof -
have "(\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d') = (v' \<star>\<^sub>D e') \<star>\<^sub>D d'"
using \<psi> e'.antipar D.src_cod v' e'.antipar \<psi>' d'.trnr\<^sub>\<eta>_def
D.whisker_right [of d' \<psi> "D.inv \<psi>"] D.comp_arr_inv'
by auto
moreover have "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] : v' \<star>\<^sub>D e' \<star>\<^sub>D d' \<Rightarrow>\<^sub>D (v' \<star>\<^sub>D e') \<star>\<^sub>D d'\<guillemotright>"
using v' e'.antipar \<psi>' D.assoc'_in_hom
unfolding d'.trnr\<^sub>\<eta>_def
by fastforce
ultimately show ?thesis
using D.comp_cod_arr by auto
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (((F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']) \<cdot>\<^sub>D
(\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "(\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']) \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') = v' \<star>\<^sub>D D.inv \<epsilon>'"
proof -
have 1: "D.hseq v' e'"
using v' e'.antipar \<psi>' unfolding d'.trnr\<^sub>\<eta>_def by fastforce
have "\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] = v' \<star>\<^sub>D e' \<star>\<^sub>D d'"
using v' e'.antipar 1 D.comp_assoc_assoc' by auto
moreover have "\<guillemotleft>v' \<star>\<^sub>D D.inv \<epsilon>' : v' \<star>\<^sub>D trg\<^sub>D e' \<Rightarrow>\<^sub>D v' \<star>\<^sub>D e' \<star>\<^sub>D d'\<guillemotright>"
using v' e'.antipar 1
apply (intro D.hcomp_in_vhom)
apply auto
by (metis D.ideD(1) D.trg_src \<open>trg\<^sub>D e' = a'\<close> e'.antipar(2) e'.ide_right)
ultimately show ?thesis
using D.comp_cod_arr by auto
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D ((F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']) \<cdot>\<^sub>D
(\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "((F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] =
\<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']"
using \<phi> u' e'.antipar 1 D.comp_cod_arr D.comp_assoc_assoc'
D.whisker_left [of "F r" "\<a>\<^sub>D[u', e', d']" "\<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D (((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D
(\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d')) \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "(F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] =
\<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>')"
using D.assoc_naturality [of "F r" u' \<epsilon>'] e' u' u'_in_hhom by force
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D
((v' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>')) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') = (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D (v' \<star>\<^sub>D \<epsilon>')"
proof -
have "((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') =
((F r \<star>\<^sub>D u') \<cdot>\<^sub>D \<omega>' \<star>\<^sub>D \<epsilon>' \<cdot>\<^sub>D (e' \<star>\<^sub>D d'))"
using D.interchange
by (metis D.comp_arr_dom D.hcomp_simps(3) D.hseqI D.ide_char D.in_hhomE
D.in_homE D.seqI T'.base_in_hom(1) T'.base_simps(3) T.base_simps(2)
\<omega>' e'.counit_simps(1) e'.counit_simps(2) preserves_src u' u'_in_hhom)
also have "... = \<omega>' \<cdot>\<^sub>D v' \<star>\<^sub>D trg\<^sub>D e' \<cdot>\<^sub>D \<epsilon>'"
using \<omega>' D.comp_arr_dom D.comp_cod_arr by auto
also have "... = (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D (v' \<star>\<^sub>D \<epsilon>')"
using D.interchange
by (metis D.arrI D.comp_cod_arr D.ide_char D.seqI \<omega>' \<open>trg\<^sub>D e' = a'\<close>
e'.counit_simps(1) e'.counit_simps(3) e'.counit_simps(5) v' v'_def)
finally show ?thesis by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
proof -
have "(v' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') = v' \<star>\<^sub>D trg\<^sub>D e'"
using v' D.whisker_left D.comp_arr_inv D.inv_is_inverse
by (metis D.comp_arr_inv' D.seqI' d'.unit_in_vhom e'.counit_in_hom(2)
e'.counit_is_iso e'.counit_simps(3))
moreover have "\<guillemotleft>\<r>\<^sub>D\<^sup>-\<^sup>1[v'] : v' \<Rightarrow>\<^sub>D v' \<star>\<^sub>D trg\<^sub>D e'\<guillemotright>"
using v' 1 by simp
ultimately show ?thesis
using v' D.comp_cod_arr by auto
qed
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D u']) \<cdot>\<^sub>D \<omega>'"
using u' v' \<omega>' D.runit'_naturality D.comp_assoc
by (metis D.in_hhomE D.in_homE a'_def e')
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[u']) \<cdot>\<^sub>D \<omega>'"
using 1 T'.ide_base u' D.runit_hcomp [of "F r" u'] by fastforce
also have "... = ((F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[u'])) \<cdot>\<^sub>D \<omega>'"
using D.comp_assoc by simp
also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[u']) \<cdot>\<^sub>D \<omega>'"
using 1 T'.ide_base u' D.whisker_left by simp
also have "... = (F r \<star>\<^sub>D u') \<cdot>\<^sub>D \<omega>'"
using u'
by (metis D.comp_ide_self D.ide_in_hom(2) D.ide_is_iso
D.invert_opposite_sides_of_square D.invert_side_of_triangle(1)
D.iso_runit D.runit_in_vhom D.seqI')
also have "... = \<omega>'"
using \<omega>' D.comp_cod_arr by auto
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
thus "\<exists>w' \<theta>' \<nu>'. D.ide w' \<and> \<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u'\<guillemotright> \<and>
\<guillemotleft>\<nu>' : D.dom \<omega>' \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright> \<and> D.iso \<nu>' \<and> T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' = \<omega>'"
using w' \<theta>' \<nu>' iso_\<nu>' v'_def by blast
qed
text \<open>Now we establish \<open>T'.T2\<close>.\<close>
next
fix u w w' \<theta> \<theta>' \<beta>
assume w: "D.ide w"
assume w': "D.ide w'"
assume \<theta>: "\<guillemotleft>\<theta> : F f \<star>\<^sub>D w \<Rightarrow>\<^sub>D u\<guillemotright>"
assume \<theta>': "\<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u\<guillemotright>"
assume \<beta>: "\<guillemotleft>\<beta> : F g \<star>\<^sub>D w \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright>"
assume eq: "T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta>"
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
proof -
define a where "a = src\<^sub>D w"
have a: "D.obj a"
unfolding a_def by (simp add: w)
have [simp]: "src\<^sub>D \<theta> = a"
using \<theta> a_def
by (metis D.dom_src D.in_homE D.src.preserves_dom D.src.preserves_reflects_arr
D.src_hcomp')
have [simp]: "trg\<^sub>D \<theta> = trg\<^sub>D (F f)"
using \<theta>
by (metis D.dom_trg D.hseq_char' D.ideD(1) D.ide_trg D.in_homE D.trg.is_extensional
D.trg.preserves_dom D.hcomp_simps(2))
have [simp]: "src\<^sub>D \<theta>' = a"
using \<theta>' a_def
by (metis D.horizontal_homs_axioms D.in_homE \<open>src\<^sub>D \<theta> = a\<close> \<theta> horizontal_homs.src_cod)
have [simp]: "trg\<^sub>D \<theta>' = trg\<^sub>D (F f)"
using \<theta>'
by (metis D.dom_trg D.hseq_char' D.ideD(1) D.ide_trg D.in_homE D.trg.is_extensional
D.trg.preserves_dom D.hcomp_simps(2))
have [simp]: "src\<^sub>D w = a"
using a_def by simp
have [simp]: "trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)"
by (metis D.horizontal_homs_axioms D.hseq_char D.in_homE T.tab_simps(2) T.leg0_simps(2)
\<theta> category.ideD(1) category.ide_dom horizontal_homs_def preserves_src)
have [simp]: "src\<^sub>D w' = a"
using a_def
by (metis D.dom_src D.hseq_char' D.ideD(1) D.in_homE D.src.is_extensional
D.src.preserves_dom D.src.preserves_ide \<open>src\<^sub>D \<theta>' = a\<close> \<theta>' D.hcomp_simps(1) w)
have [simp]: "trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)"
by (metis D.horizontal_homs_axioms D.hseq_char D.in_homE T.tab_simps(2) T.leg0_simps(2)
\<theta>' category.ideD(1) category.ide_dom horizontal_homs_def preserves_src)
text \<open>First, reflect the picture back to \<open>C\<close>, so that we will be able to apply \<open>T.T2\<close>.
We need to choose arrows in \<open>C\<close> carefully, so that their \<open>F\<close> images will enable the
cancellation of the various isomorphisms that appear.\<close>
obtain a\<^sub>C where a\<^sub>C: "C.obj a\<^sub>C \<and> D.equivalent_objects (map\<^sub>0 a\<^sub>C) a"
using w a_def surjective_on_objects_up_to_equivalence D.obj_src D.ideD(1)
by presburger
obtain e where e: "\<guillemotleft>e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D a\<guillemotright> \<and> D.equivalence_map e"
using a\<^sub>C D.equivalent_objects_def by auto
obtain d \<eta> \<epsilon>
where d\<eta>\<epsilon>: "adjoint_equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e d \<eta> \<epsilon>"
using e D.equivalence_map_extends_to_adjoint_equivalence by blast
interpret e: adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e d \<eta> \<epsilon>
using d\<eta>\<epsilon> by auto
interpret d: adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
d e "D.inv \<epsilon>" "D.inv \<eta>"
using e.dual_adjoint_equivalence by simp
have [simp]: "src\<^sub>D e = map\<^sub>0 a\<^sub>C"
using e by auto
have [simp]: "trg\<^sub>D e = a"
using e by auto
have [simp]: "src\<^sub>D d = a"
using e.antipar by simp
have [simp]: "trg\<^sub>D d = map\<^sub>0 a\<^sub>C"
using e.antipar by simp
have we: "\<guillemotleft>w \<star>\<^sub>D e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C \<rho>)\<guillemotright>"
using a\<^sub>C e D.ideD(1) \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close> a_def by blast
obtain w\<^sub>C where
w\<^sub>C: "C.ide w\<^sub>C \<and> \<guillemotleft>w\<^sub>C : a\<^sub>C \<rightarrow>\<^sub>C src\<^sub>C \<rho>\<guillemotright> \<and> D.isomorphic (F w\<^sub>C) (w \<star>\<^sub>D e)"
using a\<^sub>C e we locally_essentially_surjective [of a\<^sub>C "src\<^sub>C \<rho>" "w \<star>\<^sub>D e"]
C.obj_src T.tab_simps(1) e.ide_left w by blast
have w'e: "\<guillemotleft>w' \<star>\<^sub>D e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C \<rho>)\<guillemotright>"
using a\<^sub>C e D.ideD(1) \<open>trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)\<close> a_def \<open>src\<^sub>D w' = a\<close> w' by blast
obtain w\<^sub>C' where
w\<^sub>C': "C.ide w\<^sub>C' \<and> \<guillemotleft>w\<^sub>C' : a\<^sub>C \<rightarrow>\<^sub>C src\<^sub>C \<rho>\<guillemotright> \<and> D.isomorphic (F w\<^sub>C') (w' \<star>\<^sub>D e)"
using a\<^sub>C e a_def locally_essentially_surjective
by (metis C.obj_src D.ide_hcomp D.hseq_char D.in_hhomE T.tab_simps(2)
T.leg0_simps(2) e.ide_left w' w'e)
have [simp]: "src\<^sub>C w\<^sub>C = a\<^sub>C"
using w\<^sub>C by auto
have [simp]: "trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>"
using w\<^sub>C by auto
have [simp]: "src\<^sub>C w\<^sub>C' = a\<^sub>C"
using w\<^sub>C' by auto
have [simp]: "trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>"
using w\<^sub>C' by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F w\<^sub>C \<Rightarrow>\<^sub>D w \<star>\<^sub>D e\<guillemotright> \<and> D.iso \<phi>"
using w\<^sub>C D.isomorphicE by blast
obtain \<phi>' where \<phi>': "\<guillemotleft>\<phi>' : F w\<^sub>C' \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright> \<and> D.iso \<phi>'"
using w\<^sub>C' D.isomorphicE by blast
have ue: "\<guillemotleft>u \<star>\<^sub>D e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C f)\<guillemotright> \<and> D.ide (u \<star>\<^sub>D e)"
using a\<^sub>C e \<theta> e.ide_left
by (intro conjI, auto)
obtain u\<^sub>C where
u\<^sub>C: "C.ide u\<^sub>C \<and> \<guillemotleft>u\<^sub>C : a\<^sub>C \<rightarrow>\<^sub>C trg\<^sub>C f\<guillemotright> \<and> D.isomorphic (F u\<^sub>C) (u \<star>\<^sub>D e)"
using a\<^sub>C e ue locally_essentially_surjective [of a\<^sub>C "trg\<^sub>C f" "u \<star>\<^sub>D e"] by auto
have [simp]: "src\<^sub>C u\<^sub>C = a\<^sub>C"
using u\<^sub>C by auto
have [simp]: "trg\<^sub>C u\<^sub>C = trg\<^sub>C f"
using u\<^sub>C by auto
obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : u \<star>\<^sub>D e \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright> \<and> D.iso \<psi>"
using u\<^sub>C D.isomorphic_symmetric D.isomorphicE by blast
define F\<theta>\<^sub>C where
"F\<theta>\<^sub>C = \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
have 1: "\<guillemotleft>F\<theta>\<^sub>C : F (f \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
proof (unfold F\<theta>\<^sub>C_def, intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Phi> (f, w\<^sub>C)) : F (f \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F w\<^sub>C\<guillemotright>"
by (simp add: \<Phi>_in_hom(2) w\<^sub>C)
show "\<guillemotleft>F f \<star>\<^sub>D \<phi> : F f \<star>\<^sub>D F w\<^sub>C \<Rightarrow>\<^sub>D F f \<star>\<^sub>D w \<star>\<^sub>D e\<guillemotright>"
using w w\<^sub>C \<phi> by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] : F f \<star>\<^sub>D w \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F f \<star>\<^sub>D w) \<star>\<^sub>D e\<guillemotright>"
using w D.assoc'_in_hom by simp
show "\<guillemotleft>\<theta> \<star>\<^sub>D e : (F f \<star>\<^sub>D w) \<star>\<^sub>D e \<Rightarrow>\<^sub>D u \<star>\<^sub>D e\<guillemotright>"
using w \<theta> by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>\<psi> : u \<star>\<^sub>D e \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
using \<psi> by simp
qed
have 2: "\<exists>\<theta>\<^sub>C. \<guillemotleft>\<theta>\<^sub>C : f \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C = F\<theta>\<^sub>C"
using u\<^sub>C w\<^sub>C 1 e \<theta> \<phi> locally_full by simp
obtain \<theta>\<^sub>C where \<theta>\<^sub>C: "\<guillemotleft>\<theta>\<^sub>C : f \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C = F\<theta>\<^sub>C"
using 2 by auto
define F\<theta>\<^sub>C' where
"F\<theta>\<^sub>C' = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C'))"
have 1: "\<guillemotleft>F\<theta>\<^sub>C' : F (f \<star>\<^sub>C w\<^sub>C') \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
proof (unfold F\<theta>\<^sub>C'_def, intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Phi> (f, w\<^sub>C')) : F (f \<star>\<^sub>C w\<^sub>C') \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F w\<^sub>C'\<guillemotright>"
by (simp add: \<Phi>_in_hom(2) w\<^sub>C')
show "\<guillemotleft>F f \<star>\<^sub>D \<phi>' : F f \<star>\<^sub>D F w\<^sub>C' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
using w' w\<^sub>C' \<phi>' by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] : F f \<star>\<^sub>D w' \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F f \<star>\<^sub>D w') \<star>\<^sub>D e\<guillemotright>"
using w' D.assoc'_in_hom by simp
show "\<guillemotleft>\<theta>' \<star>\<^sub>D e : (F f \<star>\<^sub>D w') \<star>\<^sub>D e \<Rightarrow>\<^sub>D u \<star>\<^sub>D e\<guillemotright>"
using w' \<theta>' by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>\<psi> : u \<star>\<^sub>D e \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
using \<psi> by simp
qed
have 2: "\<exists>\<theta>\<^sub>C'. \<guillemotleft>\<theta>\<^sub>C' : f \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C' = F\<theta>\<^sub>C'"
using u\<^sub>C w\<^sub>C' 1 e \<theta> \<phi> locally_full by simp
obtain \<theta>\<^sub>C' where \<theta>\<^sub>C': "\<guillemotleft>\<theta>\<^sub>C' : f \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C' = F\<theta>\<^sub>C'"
using 2 by auto
define F\<beta>\<^sub>C where
"F\<beta>\<^sub>C = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
have F\<beta>\<^sub>C: "\<guillemotleft>F\<beta>\<^sub>C: F (g \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w\<^sub>C')\<guillemotright>"
proof (unfold F\<beta>\<^sub>C_def, intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Phi> (g, w\<^sub>C)) : F (g \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w\<^sub>C\<guillemotright>"
by (simp add: \<Phi>_in_hom(2) w\<^sub>C)
show "\<guillemotleft>F g \<star>\<^sub>D \<phi> : F g \<star>\<^sub>D F w\<^sub>C \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w \<star>\<^sub>D e\<guillemotright>"
using w\<^sub>C \<phi> apply (intro D.hcomp_in_vhom) by auto
show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] : F g \<star>\<^sub>D w \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F g \<star>\<^sub>D w) \<star>\<^sub>D e\<guillemotright>"
using w D.assoc'_in_hom by simp
show "\<guillemotleft>\<beta> \<star>\<^sub>D e : (F g \<star>\<^sub>D w) \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F g \<star>\<^sub>D w') \<star>\<^sub>D e\<guillemotright>"
using w \<beta> apply (intro D.hcomp_in_vhom) by auto
show "\<guillemotleft>\<a>\<^sub>D[F g, w', e] : (F g \<star>\<^sub>D w') \<star>\<^sub>D e \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
using w' e.antipar D.assoc_in_hom by simp
show "\<guillemotleft>F g \<star>\<^sub>D D.inv \<phi>' : F g \<star>\<^sub>D w' \<star>\<^sub>D e \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w\<^sub>C'\<guillemotright>"
using w' w\<^sub>C' \<phi>' by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>\<Phi> (g, w\<^sub>C') : F g \<star>\<^sub>D F w\<^sub>C' \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w\<^sub>C')\<guillemotright>"
using w\<^sub>C' \<Phi>_in_hom by simp
qed
have 1: "\<exists>\<beta>\<^sub>C. \<guillemotleft>\<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<^sub>C'\<guillemotright> \<and> F \<beta>\<^sub>C = F\<beta>\<^sub>C"
using w\<^sub>C w\<^sub>C' F\<beta>\<^sub>C locally_full by simp
obtain \<beta>\<^sub>C where \<beta>\<^sub>C: "\<guillemotleft>\<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<^sub>C'\<guillemotright> \<and> F \<beta>\<^sub>C = F\<beta>\<^sub>C"
using 1 by auto
text \<open>
The following is the main calculation that needs to be done, to permit us
to apply \<open>T.T2\<close>.
Once again, it started out looking simple, but once all the necessary
isomorphisms are thrown in it looks much more complicated.
\<close>
have *: "T.composite_cell w\<^sub>C \<theta>\<^sub>C = T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C"
proof -
have par: "C.par (T.composite_cell w\<^sub>C \<theta>\<^sub>C) (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C)"
proof -
have "\<guillemotleft>T.composite_cell w\<^sub>C \<theta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<^sub>C\<guillemotright>"
using w\<^sub>C \<theta>\<^sub>C T.composite_cell_in_hom by simp
moreover have "\<guillemotleft>T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<^sub>C\<guillemotright>"
proof (intro C.comp_in_homI)
show "\<guillemotleft>\<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<^sub>C'\<guillemotright>"
using \<beta>\<^sub>C by simp
show "\<guillemotleft>\<rho> \<star>\<^sub>C w\<^sub>C' : g \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C (r \<star>\<^sub>C f) \<star>\<^sub>C w\<^sub>C'\<guillemotright>"
using w\<^sub>C' by (intro C.hcomp_in_vhom, auto)
show "\<guillemotleft>\<a>\<^sub>C[r, f, w\<^sub>C'] : (r \<star>\<^sub>C f) \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C r \<star>\<^sub>C f \<star>\<^sub>C w\<^sub>C'\<guillemotright>"
using w\<^sub>C' C.assoc_in_hom by simp
show "\<guillemotleft>r \<star>\<^sub>C \<theta>\<^sub>C' : r \<star>\<^sub>C f \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<^sub>C\<guillemotright>"
using w\<^sub>C' \<theta>\<^sub>C' by (intro C.hcomp_in_vhom, auto)
qed
ultimately show ?thesis
by (metis C.in_homE)
qed
moreover have "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) = F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C)"
proof -
have "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) = F (r \<star>\<^sub>C \<theta>\<^sub>C) \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w\<^sub>C] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w\<^sub>C)"
using par by auto
also have "... = (\<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D
(\<Phi> (r, f \<star>\<^sub>C w\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C))) \<cdot>\<^sub>D
(\<Phi> (r \<star>\<^sub>C f, w\<^sub>C) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)))"
proof -
have "src\<^sub>C f = trg\<^sub>C w\<^sub>C \<and> C.hseq r \<theta>\<^sub>C \<and> C.hseq \<rho> w\<^sub>C"
using par by auto
thus ?thesis
using w\<^sub>C \<theta>\<^sub>C preserves_assoc preserves_hcomp
by (metis C.ideD(2) C.ideD(3) C.in_homE T.ide_base T.ide_leg0 T.leg0_simps(3)
T.tab_simps(4) T.tab_simps(5))
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D (((D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D
(\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D ((D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C))) \<cdot>\<^sub>D
(\<Phi> (r \<star>\<^sub>C f, w\<^sub>C)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C)) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using D.comp_assoc by simp
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D ((F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C))) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C)) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have
"(D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w\<^sub>C)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C) = F \<rho> \<star>\<^sub>D F w\<^sub>C"
using w\<^sub>C \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> D.comp_inv_arr' \<Phi>_in_hom \<Phi>_components_are_iso
D.comp_cod_arr D.hseqI'
by simp
moreover have
"((D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)) =
F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)"
using w\<^sub>C \<Phi>_in_hom \<Phi>_components_are_iso D.comp_cod_arr
D.comp_inv_arr' D.hseqI' \<Phi>_simps(1) \<Phi>_simps(4) by auto
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
(?\<rho>' \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "(F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)) = F r \<star>\<^sub>D F \<theta>\<^sub>C \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C)"
using \<theta>\<^sub>C w\<^sub>C D.whisker_left \<Phi>_in_hom
by (metis C.hseqE C.seqE D.seqI' T'.ide_base T.tab_simps(2) T.ide_leg0
par preserves_hom)
moreover have "(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C) = ?\<rho>' \<star>\<^sub>D F w\<^sub>C"
using D.whisker_right by (simp add: w\<^sub>C)
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
D.inv (\<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
(?\<rho>' \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using \<theta>\<^sub>C F\<theta>\<^sub>C_def D.comp_assoc by simp
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
((F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C]) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
D.inv (\<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C) =
F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)"
using \<Phi>_in_hom \<Phi>_components_are_iso D.comp_arr_dom
by (metis C.arrI D.cod_inv D.comp_inv_arr' D.seqE F\<theta>\<^sub>C_def T.tab_simps(2)
T.ide_leg0 \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<theta>\<^sub>C preserves_arr w\<^sub>C)
also have "... = (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>)"
using D.whisker_left
by (metis (no_types, lifting) C.in_homE D.comp_assoc D.seqE F\<theta>\<^sub>C_def T'.ide_base
\<theta>\<^sub>C preserves_arr)
finally have "F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
D.inv (\<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C) =
(F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] \<cdot>\<^sub>D (((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C)) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] =
\<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>)"
using w\<^sub>C \<phi> \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> D.assoc_naturality [of "F r" "F f" \<phi>]
by (metis (mono_tags, lifting) C.ideD(1) D.in_homE D.vconn_implies_hpar(2)
T'.base_simps(2-4) T'.leg0_simps(2-5) T.leg0_simps(2)
T.tab_simps(2) preserves_src preserves_trg)
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e]) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C) = ?\<rho>' \<star>\<^sub>D \<phi> \<cdot>\<^sub>D F w\<^sub>C"
using \<phi> D.interchange
by (metis D.comp_arr_dom D.comp_cod_arr D.in_homE T'.tab_simps(1,5))
also have "... = ?\<rho>' \<star>\<^sub>D (w \<star>\<^sub>D e) \<cdot>\<^sub>D \<phi>"
using \<phi> w\<^sub>C D.comp_arr_dom D.comp_cod_arr by auto
also have "... = (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"
using \<phi> D.interchange
by (metis D.comp_arr_dom D.hcomp_simps(3) D.ide_char D.in_hhomE D.in_homE
D.seqI T'.tab_in_hom(2) T.tab_simps(2) T.leg0_simps(2) e.ide_left
preserves_src w we)
finally have
"((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C) = (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e]) \<cdot>\<^sub>D
(\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w, e] \<cdot>\<^sub>D
(?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e)) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e]) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using w by simp
moreover have "D.seq (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e])
(\<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e))"
using w D.hseqI'
by (intro D.seqI D.hseqI, auto)
moreover have
"(F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) =
\<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, w, e]"
using w D.pentagon by simp
ultimately
have "(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] =
\<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w, e]"
using w D.comp_assoc
D.invert_opposite_sides_of_square
[of "F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e]" "\<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e)"
"\<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e]" "\<a>\<^sub>D[F r \<star>\<^sub>D F f, w, e]"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D (((F r \<star>\<^sub>D \<theta>) \<star>\<^sub>D e) \<cdot>\<^sub>D
(\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w) \<star>\<^sub>D e)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have
"(F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] = \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta>) \<star>\<^sub>D e)"
using D.assoc_naturality [of "F r" \<theta> e] \<theta> by auto
moreover have "\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w, e] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) =
((?\<rho>' \<star>\<^sub>D w) \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]"
using w we e.ide_left D.assoc'_naturality [of ?\<rho>' w e] by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
(T'.composite_cell w \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "((F r \<star>\<^sub>D \<theta>) \<star>\<^sub>D e) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w) \<star>\<^sub>D e) =
T'.composite_cell w \<theta> \<star>\<^sub>D e"
proof -
have "\<guillemotleft>T'.composite_cell w \<theta> : F g \<star>\<^sub>D w \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u\<guillemotright>"
using w we \<theta> \<open>src\<^sub>D \<theta> = a\<close> \<open>trg\<^sub>D e = a\<close> T'.composite_cell_in_hom
by (metis D.ideD(1) D.ide_in_hom(1) D.not_arr_null D.seq_if_composable
T'.leg1_simps(3) T.leg1_simps(2-3) T.tab_simps(2)
\<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close> a_def preserves_src ue)
thus ?thesis
using D.whisker_right D.arrI by auto
qed
thus ?thesis
using D.comp_assoc by simp
qed
finally have L: "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) =
\<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
(T'.composite_cell w \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
by simp
have "F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C) =
F ((r \<star>\<^sub>C \<theta>\<^sub>C') \<cdot>\<^sub>C \<a>\<^sub>C[r, f, w\<^sub>C'] \<cdot>\<^sub>C (\<rho> \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>C \<beta>\<^sub>C)"
using C.comp_assoc by simp
also have "... = F(r \<star>\<^sub>C \<theta>\<^sub>C') \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w\<^sub>C'] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>D F \<beta>\<^sub>C"
using C.comp_assoc par by fastforce
also have "... = (\<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<cdot>\<^sub>D
(\<Phi> (r, f \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C'))) \<cdot>\<^sub>D
(\<Phi> (r \<star>\<^sub>C f, w\<^sub>C') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C'))) \<cdot>\<^sub>D
\<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "C.hseq r \<theta>\<^sub>C' \<and> C.hseq \<rho> w\<^sub>C'"
using par by blast
thus ?thesis
using w\<^sub>C' \<theta>\<^sub>C' \<beta>\<^sub>C F\<beta>\<^sub>C_def preserves_assoc [of r f w\<^sub>C'] preserves_hcomp C.hseqI'
by force
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<cdot>\<^sub>D
(\<Phi> (r, f \<star>\<^sub>C w\<^sub>C')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D ((D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D
\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C')) \<cdot>\<^sub>D ((D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D
\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using D.comp_assoc by simp
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "(D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<cdot>\<^sub>D (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) =
F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')"
proof -
have "D.seq (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C')) (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<and>
D.arr (D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<and>
D.dom (D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) =
D.cod (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')))"
by (metis D.seqE calculation par preserves_arr)
thus ?thesis
using C.ide_hcomp C.ideD(1) C.trg_hcomp' D.invert_side_of_triangle(1)
T.ide_base T.ide_leg0 T.leg0_simps(3) T.tab_simps(2) \<Phi>_components_are_iso
\<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> w\<^sub>C'
by presburger
qed
moreover have
"(D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C') =
F \<rho> \<star>\<^sub>D F w\<^sub>C'"
proof -
have "D.seq (F \<rho> \<star>\<^sub>D F w\<^sub>C') (D.inv (\<Phi> (C.dom \<rho>, C.dom w\<^sub>C'))) \<and>
D.arr (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<and>
D.dom (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) =
D.cod ((F \<rho> \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (C.dom \<rho>, C.dom w\<^sub>C')))"
by (metis C.hseqI' C.ide_char D.seqE T.tab_simps(1) T.tab_simps(5)
\<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> preserves_arr preserves_hcomp w\<^sub>C')
thus ?thesis
by (metis (no_types) C.ide_hcomp C.ide_char C.hcomp_simps(1)
D.cod_comp D.comp_inv_arr' D.seqE T.ide_base T.ide_leg0 T.leg0_simps(3)
T.tab_simps(2) \<Phi>_components_are_iso D.comp_cod_arr
\<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> w\<^sub>C')
qed
moreover have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') =
F g \<star>\<^sub>D D.inv \<phi>'"
proof -
have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') =
(F g \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')"
using w\<^sub>C' \<beta>\<^sub>C F\<beta>\<^sub>C_def \<Phi>_components_are_iso D.comp_inv_arr' by simp
also have "... = F g \<star>\<^sub>D D.inv \<phi>'"
using D.comp_cod_arr [of "F g \<star>\<^sub>D D.inv \<phi>'" "F g \<star>\<^sub>D F w\<^sub>C'"]
by (metis D.hcomp_simps(4) D.cod_inv D.comp_null(2) D.hseq_char' D.in_homE
T'.leg1_simps(6) \<phi>')
finally show ?thesis by blast
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using w\<^sub>C' D.whisker_right \<Phi>_in_hom \<Phi>_components_are_iso by simp
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
D.inv (\<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using \<theta>\<^sub>C' F\<theta>\<^sub>C'_def by simp
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D (F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
(((F r \<star>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C']) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
D.inv (\<Phi> (f, w\<^sub>C')) =
(F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D
(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C')))"
using D.whisker_left \<Phi>_in_hom \<Phi>_components_are_iso
by (metis C.arrI D.src.preserves_reflects_arr D.src_vcomp D.vseq_implies_hpar(1)
F\<theta>\<^sub>C'_def T'.ide_base \<theta>\<^sub>C' preserves_arr)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C']) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "((F r \<star>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w\<^sub>C'] =
\<a>\<^sub>D[F r, F f, F w\<^sub>C']"
using \<Phi>_in_hom \<Phi>_components_are_iso D.comp_cod_arr
D.whisker_left [of "F r" "D.inv (\<Phi> (f, w\<^sub>C'))" "\<Phi> (f, w\<^sub>C')"]
by (simp add: D.comp_inv_arr' w\<^sub>C')
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D
(((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C'] =
\<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>')"
using w\<^sub>C' \<phi>' D.assoc_naturality [of "F r" "F f" \<phi>']
by (metis C.ideD(1) D.dom_trg D.in_homE D.trg.preserves_dom
T'.leg0_simps(2-5) T'.base_simps(2-4) T.tab_simps(2) T.leg0_simps(2)
\<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> preserves_src preserves_trg)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D
(?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D (((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') = (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>')"
using \<phi>' D.interchange D.comp_arr_dom D.comp_cod_arr
by (metis D.in_homE T'.tab_in_hom(2))
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
((F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e]) \<cdot>\<^sub>D
(?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] = \<a>\<^sub>D[F g, w', e]"
proof -
have "((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] =
(F g \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e]"
by (metis D.arr_inv D.cod_inv D.comp_arr_inv' D.in_homE D.seqI
D.whisker_left T'.ide_leg1 \<phi>')
also have "... = \<a>\<^sub>D[F g, w', e]"
using w' D.comp_cod_arr by simp
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e]) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w', e] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e)) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D
(\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e]) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]"
using w' by simp
moreover have "D.seq (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e])
(\<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e))"
using w' D.hseqI'
by (intro D.seqI D.hseqI, auto)
moreover have "D.iso (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e])"
using w' by simp
moreover have "D.iso \<a>\<^sub>D[F r \<star>\<^sub>D F f, w', e]"
using w' by simp
moreover have "(F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D
(\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) =
\<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, w', e]"
using w' D.pentagon by simp
ultimately
have "(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] =
\<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w', e]"
using w' D.comp_assoc
D.invert_opposite_sides_of_square
[of "F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e]" "\<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e)"
"\<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e]" "\<a>\<^sub>D[F r \<star>\<^sub>D F f, w', e]"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D (((F r \<star>\<^sub>D \<theta>') \<star>\<^sub>D e) \<cdot>\<^sub>D
(\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w') \<star>\<^sub>D e)) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "(F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] =
\<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta>') \<star>\<^sub>D e)"
using D.assoc_naturality [of "F r" \<theta>' e] \<theta>' by auto
moreover have "\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w', e] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) =
((?\<rho>' \<star>\<^sub>D w') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e]"
using w' w'e D.assoc'_naturality [of ?\<rho>' w' e] D.hseqI' by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
(T'.composite_cell w' \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "((F r \<star>\<^sub>D \<theta>') \<star>\<^sub>D e) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w') \<star>\<^sub>D e) =
T'.composite_cell w' \<theta>' \<star>\<^sub>D e"
proof -
have "\<guillemotleft>T'.composite_cell w' \<theta>' : F g \<star>\<^sub>D w' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u\<guillemotright>"
using \<theta>' w' T'.composite_cell_in_hom D.vconn_implies_hpar(3) by simp
thus ?thesis
using D.whisker_right D.arrI by auto
qed
moreover have "(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) = \<beta> \<star>\<^sub>D e"
using w' \<beta> e.ide_left \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> F\<beta>\<^sub>C F\<beta>\<^sub>C_def D.comp_cod_arr
D.comp_arr_inv'
by (metis (no_types, lifting) D.hcomp_simps(4) D.comp_assoc_assoc'(2) D.ide_char
D.in_homE D.seqE T'.ide_leg1 T'.leg1_simps(3) T.leg0_simps(2) T.tab_simps(2)
\<open>trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)\<close> preserves_src)
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
(T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
proof -
have "D.arr (T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta>)"
by (metis (full_types) D.hseq_char D.seqE L eq par preserves_arr)
thus ?thesis
using D.whisker_right by (metis D.comp_assoc e.ide_left)
qed
finally have R: "F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C) =
\<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
(T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
by simp
show "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) = F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C)"
using eq L R by simp
qed
ultimately show ?thesis
using is_faithful [of "T.composite_cell w\<^sub>C \<theta>\<^sub>C" "T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C"]
by simp
qed
have **: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> \<beta>\<^sub>C = g \<star>\<^sub>C \<gamma> \<and> \<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
using * w\<^sub>C w\<^sub>C' \<theta>\<^sub>C \<theta>\<^sub>C' \<beta>\<^sub>C T.T2 [of w\<^sub>C w\<^sub>C' \<theta>\<^sub>C u\<^sub>C \<theta>\<^sub>C' \<beta>\<^sub>C] by simp
obtain \<gamma>\<^sub>C where
\<gamma>\<^sub>C: "\<guillemotleft>\<gamma>\<^sub>C : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> \<beta>\<^sub>C = g \<star>\<^sub>C \<gamma>\<^sub>C \<and> \<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C)"
using ** by auto
have \<gamma>\<^sub>C_unique: "\<And>\<gamma>\<^sub>C'. \<guillemotleft>\<gamma>\<^sub>C' : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> \<beta>\<^sub>C = g \<star>\<^sub>C \<gamma>\<^sub>C' \<and>
\<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C') \<Longrightarrow> \<gamma>\<^sub>C' = \<gamma>\<^sub>C"
using \<gamma>\<^sub>C ** by blast
text \<open>
Now use \<open>F\<close> to map everything back to \<open>D\<close>, transport the result along the
equivalence map \<open>e\<close>, and cancel all of the isomorphisms that got introduced.
\<close>
let ?P = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright> \<and>
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] = F g \<star>\<^sub>D \<gamma> \<and>
\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
define \<gamma>e where "\<gamma>e = \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>"
have P\<gamma>e: "?P \<gamma>e"
proof -
have 1: "\<guillemotleft>F \<gamma>\<^sub>C : F w\<^sub>C \<Rightarrow>\<^sub>D F w\<^sub>C'\<guillemotright> \<and>
F \<beta>\<^sub>C = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)) \<and>
F \<theta>\<^sub>C = F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, C.cod \<gamma>\<^sub>C) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
using \<beta>\<^sub>C \<theta>\<^sub>C \<gamma>\<^sub>C preserves_hcomp [of f \<gamma>\<^sub>C] preserves_hcomp [of g \<gamma>\<^sub>C] by force
have A: "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] =
F g \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>"
proof -
have "F g \<star>\<^sub>D F \<gamma>\<^sub>C = D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D F \<beta>\<^sub>C \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C)"
proof -
have "F \<beta>\<^sub>C = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using 1 by simp
hence "D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D F \<beta>\<^sub>C = (F g \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using w\<^sub>C w\<^sub>C' \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> \<Phi>_components_are_iso
D.invert_side_of_triangle(1)
by (metis D.arrI F\<beta>\<^sub>C T.ide_leg1 T.leg1_simps(3) T.tab_simps(2) \<beta>\<^sub>C)
hence "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D F \<beta>\<^sub>C) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C) = F g \<star>\<^sub>D F \<gamma>\<^sub>C"
using \<Phi>_components_are_iso D.invert_side_of_triangle(2)
by (metis "1" D.arrI D.inv_inv D.iso_inv_iso D.seqE F\<beta>\<^sub>C T.ide_leg1
T.leg1_simps(3) T.tab_simps(2) \<beta>\<^sub>C \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> w\<^sub>C)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = ((D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C)"
using \<beta>\<^sub>C F\<beta>\<^sub>C_def D.comp_assoc by simp
also have "... = (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"
proof -
have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') = F g \<star>\<^sub>D D.inv \<phi>'"
proof -
have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') =
(F g \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')"
using w\<^sub>C' \<phi>' \<Phi>_components_are_iso D.comp_inv_arr' by simp
also have "... = F g \<star>\<^sub>D D.inv \<phi>'"
using w\<^sub>C' \<phi>' D.comp_cod_arr
by (metis D.arr_inv D.cod_inv D.in_homE D.whisker_left T'.ide_leg1)
finally show ?thesis by blast
qed
moreover have "(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C) = F g \<star>\<^sub>D \<phi>"
proof -
have "(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C) =
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (F g \<star>\<^sub>D F w\<^sub>C)"
using w\<^sub>C \<phi> \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<Phi>_components_are_iso \<Phi>_in_hom
D.comp_inv_arr'
by simp
also have "... = F g \<star>\<^sub>D \<phi>"
using w\<^sub>C \<phi> D.comp_arr_dom
by (metis D.hcomp_simps(3) D.hseqI' D.in_hhom_def D.in_homE
D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) T'.leg1_simps(2,5)
T.leg1_simps(2-3) T.tab_simps(2) preserves_src we)
finally show ?thesis by blast
qed
ultimately show ?thesis by simp
qed
finally have 2: "(F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) =
F g \<star>\<^sub>D F \<gamma>\<^sub>C"
using D.comp_assoc by simp
have 3: "(\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) =
(F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C)"
proof -
have "D.hseq (F g) (F \<gamma>\<^sub>C)"
using "1" F\<beta>\<^sub>C \<beta>\<^sub>C by auto
moreover have "D.iso (F g \<star>\<^sub>D D.inv \<phi>')"
by (metis "2" D.iso_hcomp D.hseqE D.ide_is_iso D.iso_inv_iso D.seqE
T'.ide_leg1 \<phi>' calculation)
moreover have "D.inv (F g \<star>\<^sub>D D.inv \<phi>') = F g \<star>\<^sub>D \<phi>'"
by (metis D.hseqE D.ide_is_iso D.inv_hcomp D.inv_ide D.inv_inv D.iso_inv_iso
D.iso_is_arr T'.ide_leg1 \<phi>' calculation(2))
ultimately show ?thesis
using 2 \<phi> \<phi>' D.hseqI'
D.invert_side_of_triangle(1)
[of "F g \<star>\<^sub>D F \<gamma>\<^sub>C" "F g \<star>\<^sub>D D.inv \<phi>'"
"(\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"]
by auto
qed
hence "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] =
((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C)) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>)"
proof -
have "D.seq (F g \<star>\<^sub>D \<phi>') (F g \<star>\<^sub>D F \<gamma>\<^sub>C)"
by (metis "1" "2" "3" D.arrI D.comp_null(1) D.comp_null(2) D.ext F\<beta>\<^sub>C \<beta>\<^sub>C)
moreover have "D.iso (F g \<star>\<^sub>D \<phi>)"
using D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) \<phi> we by auto
moreover have "D.inv (F g \<star>\<^sub>D \<phi>) = F g \<star>\<^sub>D D.inv \<phi>"
by (metis D.hseqE D.ide_is_iso D.inv_hcomp D.inv_ide D.iso_is_arr
T'.ide_leg1 \<phi> calculation(2))
ultimately show ?thesis
using 3 \<phi> \<phi>'
D.invert_side_of_triangle(2)
[of "(F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C)"
"\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]" "F g \<star>\<^sub>D \<phi>"]
by auto
qed
also have "... = F g \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>"
using \<phi>' D.whisker_left
by (metis "1" D.arr_inv D.cod_comp D.cod_inv D.comp_assoc D.in_homE D.seqI
T'.ide_leg1 \<phi>)
finally show ?thesis by simp
qed
have B: "\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>)"
proof -
have "F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C)) =
(\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C)) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
using \<gamma>\<^sub>C \<theta>\<^sub>C' F\<theta>\<^sub>C'_def D.comp_assoc by auto
also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
proof -
have "(D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) = F f \<star>\<^sub>D F \<gamma>\<^sub>C"
using D.comp_cod_arr
by (metis (mono_tags, lifting) C.in_homE D.cod_comp D.comp_inv_arr' D.seqE
T.tab_simps(2) T.ide_leg0 \<Phi>_components_are_iso \<gamma>\<^sub>C 1 \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close>
\<theta>\<^sub>C preserves_arr w\<^sub>C')
thus ?thesis
using D.comp_assoc by simp
qed
finally have "F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C)) =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
by simp
hence 3: "F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C)"
using \<Phi>_components_are_iso D.iso_inv_iso D.iso_is_retraction D.retraction_is_epi
D.epiE
by (metis C.in_homE D.comp_assoc T.tab_simps(2) T.ide_leg0 \<gamma>\<^sub>C 1
\<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<theta>\<^sub>C preserves_arr w\<^sub>C)
hence "(\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C)) =
(\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
(F f \<star>\<^sub>D F \<gamma>\<^sub>C)) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
using 1 \<theta>\<^sub>C F\<theta>\<^sub>C_def D.comp_assoc by (metis C.in_homE \<gamma>\<^sub>C)
hence 2: "(\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C)"
using \<gamma>\<^sub>C \<Phi>_components_are_iso D.iso_inv_iso D.iso_is_retraction D.retraction_is_epi
D.epiE
by (metis (mono_tags, lifting) 1 3 C.in_homE D.comp_assoc T.tab_simps(2)
T.ide_leg0 \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<theta>\<^sub>C preserves_arr w\<^sub>C)
hence "\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
(\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>)"
proof -
have "D.inv (F f \<star>\<^sub>D \<phi>) = F f \<star>\<^sub>D D.inv \<phi>"
using \<phi>
by (metis C.arrI D.hseq_char D.ide_is_iso D.inv_hcomp D.inv_ide D.seqE F\<theta>\<^sub>C_def
T'.ide_leg0 preserves_arr \<theta>\<^sub>C)
thus ?thesis
using \<phi> \<phi>' \<theta> \<theta>' \<gamma>\<^sub>C D.invert_side_of_triangle(2)
by (metis 2 C.arrI D.comp_assoc D.iso_hcomp D.hseqE D.ide_is_iso D.seqE
F\<theta>\<^sub>C_def T'.ide_leg0 \<theta>\<^sub>C preserves_arr)
qed
also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>)"
using D.comp_assoc by simp
also have
"... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>)"
proof -
have "D.arr (\<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>)"
using "1" \<phi> \<phi>' by blast
thus ?thesis
using D.whisker_left by auto
qed
finally show ?thesis by simp
qed
have C: "\<guillemotleft>\<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi> : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
using \<phi> \<phi>' \<gamma>\<^sub>C 1 by (meson D.comp_in_homI D.inv_in_hom)
show ?thesis
unfolding \<gamma>e_def
using A B C by simp
qed
have UN: "\<And>\<gamma>. ?P \<gamma> \<Longrightarrow> \<gamma> = \<gamma>e"
proof -
fix \<gamma>
assume \<gamma>: "?P \<gamma>"
show "\<gamma> = \<gamma>e"
proof -
let ?\<gamma>' = "D.inv \<phi>' \<cdot>\<^sub>D \<gamma> \<cdot>\<^sub>D \<phi>"
have \<gamma>': "\<guillemotleft>?\<gamma>' : F w\<^sub>C \<Rightarrow>\<^sub>D F w\<^sub>C'\<guillemotright>"
using \<gamma> \<phi> \<phi>' by auto
obtain \<gamma>\<^sub>C' where \<gamma>\<^sub>C': "\<guillemotleft>\<gamma>\<^sub>C' : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> F \<gamma>\<^sub>C' = ?\<gamma>'"
using w\<^sub>C w\<^sub>C' \<gamma> \<gamma>' locally_full by fastforce
have 1: "\<beta>\<^sub>C = g \<star>\<^sub>C \<gamma>\<^sub>C'"
proof -
have "F \<beta>\<^sub>C = F (g \<star>\<^sub>C \<gamma>\<^sub>C')"
proof -
have "F \<beta>\<^sub>C =
\<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using \<beta>\<^sub>C F\<beta>\<^sub>C_def by simp
have "F (g \<star>\<^sub>C \<gamma>\<^sub>C') =
\<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>' \<cdot>\<^sub>D \<gamma> \<cdot>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using \<gamma>\<^sub>C' preserves_hcomp
by (metis C.hseqI' C.in_homE C.trg_dom T.tab_simps(2) T.leg1_simps(2)
T.leg1_simps(3,5-6) \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close>)
also have "... = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using \<phi> \<phi>' D.whisker_left D.comp_assoc
by (metis D.arrI D.seqE F\<beta>\<^sub>C_def T'.ide_leg1 \<gamma> \<gamma>')
also have "... = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
(\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
using \<gamma> D.comp_assoc by simp
also have "... = F \<beta>\<^sub>C"
using \<beta>\<^sub>C F\<beta>\<^sub>C_def D.comp_assoc by simp
finally show ?thesis by simp
qed
thus ?thesis using is_faithful
by (metis C.hcomp_simps(3-4) C.in_homE D.arrI D.not_arr_null
F\<beta>\<^sub>C T.leg1_simps(5) T.leg1_simps(6) \<beta>\<^sub>C \<gamma>\<^sub>C' is_extensional)
qed
have 2: "\<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C')"
proof -
have "F \<theta>\<^sub>C = F (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C'))"
proof -
have "F (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C')) = F \<theta>\<^sub>C' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>\<^sub>C')"
using \<theta>\<^sub>C' \<gamma>\<^sub>C' by force
also have
"... = F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>' \<cdot>\<^sub>D \<gamma> \<cdot>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
using w\<^sub>C w\<^sub>C' \<theta>\<^sub>C' \<gamma>\<^sub>C' preserves_hcomp
by (metis C.hseqI' C.in_homE C.trg_dom T.tab_simps(2) T.leg0_simps(2)
T.leg0_simps(4-5) \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close>)
also have "... = F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D
((F f \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
D.inv (\<Phi> (f, w\<^sub>C))"
using D.whisker_left
by (metis D.arrI D.seqE T'.ide_leg0 \<gamma>')
also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
(D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<gamma>)) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
using \<theta>\<^sub>C' F\<theta>\<^sub>C'_def D.comp_assoc by simp
also have "... = (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
proof -
have "D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') = F f \<star>\<^sub>D F w\<^sub>C'"
using w\<^sub>C' \<Phi>_in_hom \<Phi>_components_are_iso
by (simp add: D.comp_inv_arr')
moreover have "D.hseq (F f) (D.inv \<phi>')"
using \<phi>' D.hseqI'
by (metis D.ide_is_iso D.in_hhom_def D.iso_inv_iso D.iso_is_arr
D.trg_inv D.vconn_implies_hpar(2) D.vconn_implies_hpar(4)
T'.ide_leg0 T'.leg1_simps(3) T.leg1_simps(2-3)
T.tab_simps(2) \<gamma> preserves_src we)
ultimately have "(D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>') =
F f \<star>\<^sub>D D.inv \<phi>'"
using w\<^sub>C' \<phi>' D.comp_cod_arr [of "F f \<star>\<^sub>D D.inv \<phi>'" "F f \<star>\<^sub>D F w\<^sub>C'"]
by auto
hence "((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>) =
((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
by simp
also have "... = F f \<star>\<^sub>D \<gamma>"
using \<gamma> \<phi>' \<theta>\<^sub>C' F\<theta>\<^sub>C'_def D.comp_cod_arr D.whisker_left D.hseqI'
by (metis D.comp_arr_inv' D.in_hhom_def D.in_homE T'.ide_leg0 w'e)
finally have "((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
(F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>) =
F f \<star>\<^sub>D \<gamma>"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
using \<gamma> D.comp_assoc by metis
also have "... = F \<theta>\<^sub>C"
using \<theta>\<^sub>C F\<theta>\<^sub>C_def by simp
finally show ?thesis by simp
qed
thus ?thesis using is_faithful [of \<theta>\<^sub>C "\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C')"]
by (metis C.cod_comp C.dom_comp C.hcomp_simps(3) C.in_homE C.seqE
D.not_arr_null T.leg0_simps(4) \<gamma>\<^sub>C' \<theta>\<^sub>C \<theta>\<^sub>C' is_extensional preserves_arr)
qed
have "F \<gamma>\<^sub>C' = F \<gamma>\<^sub>C"
using ** \<gamma>\<^sub>C \<gamma>\<^sub>C' 1 2 by blast
hence "?\<gamma>' = F \<gamma>\<^sub>C"
using \<gamma>\<^sub>C' by simp
thus "\<gamma> = \<gamma>e"
unfolding \<gamma>e_def
by (metis D.arrI D.comp_assoc D.inv_inv D.invert_side_of_triangle(1)
D.invert_side_of_triangle(2) D.iso_inv_iso \<gamma>' \<phi> \<phi>')
qed
qed
text \<open>We are now in a position to exhibit the 2-cell \<open>\<gamma>\<close> and show that it
is unique with the required properties.\<close>
show ?thesis
proof
let ?\<gamma> = "\<r>\<^sub>D[w'] \<cdot>\<^sub>D (w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w', e, d] \<cdot>\<^sub>D (\<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D
(w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow>\<^sub>D w'\<guillemotright>"
using P\<gamma>e w w' e.counit_in_hom(2) e.counit_is_iso
apply (intro D.comp_in_homI, auto)
apply (intro D.hcomp_in_vhom, auto simp add: D.vconn_implies_hpar(4))
by (intro D.hcomp_in_vhom, auto)
moreover have "\<beta> = F g \<star>\<^sub>D ?\<gamma>"
proof -
have "F g \<star>\<^sub>D ?\<gamma> =
(F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using w w' \<gamma> P\<gamma>e D.whisker_left e.antipar
by (metis D.arrI D.seqE T'.ide_leg1)
also have "... =
(F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] =
\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using w w' e.antipar P\<gamma>e D.assoc'_naturality [of "F g" \<gamma>e d]
by (metis D.dom_trg D.ideD(1-3) D.in_hhomE D.in_homE
D.src_dom D.trg.preserves_dom T'.leg1_simps(2) T'.leg1_simps(3,5-6)
T.tab_simps(2) T.leg0_simps(2) e e.ide_right preserves_src we)
also have
"... = (\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using D.comp_assoc by simp
also have "... = F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
proof -
have "(\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) =
(F g \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc' by auto
also have "... = F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
proof -
have "\<guillemotleft>F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d : F g \<star>\<^sub>D (w \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D F g \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
using we e.ide_right e.antipar P\<gamma>e D.hseqI'
by (intro D.hcomp_in_vhom, auto)
thus ?thesis
using D.comp_cod_arr by auto
qed
finally show ?thesis by blast
qed
finally have
"\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] =
F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
by simp
thus ?thesis by simp
qed
also have "... =
(F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D
(\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using P\<gamma>e by simp
also have
"... =
(F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d =
(\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d)"
proof -
have "D.arr (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e])"
using D.arrI D.in_hhom_def D.vconn_implies_hpar(2) P\<gamma>e we by auto
thus ?thesis
using D.whisker_right by auto
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D
((F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D[F g \<star>\<^sub>D w, e, d]) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d])) \<cdot>\<^sub>D
(F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d =
\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w, e, d]"
proof -
have "src\<^sub>D \<beta> = trg\<^sub>D e"
using \<beta>
by (metis D.dom_trg D.hseq_char' D.in_homE D.src_dom D.src_hcomp'
D.trg.is_extensional D.trg.preserves_arr D.trg.preserves_dom
\<open>trg\<^sub>D e = a\<close> a_def)
moreover have "src\<^sub>D (F g) = trg\<^sub>D w"
by simp
moreover have "src\<^sub>D (F g) = trg\<^sub>D w'"
by simp
moreover have
"\<guillemotleft>(\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d : ((F g \<star>\<^sub>D w) \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
using \<beta> w w' e e.antipar
by (intro D.hcomp_in_vhom, auto)
ultimately have
"\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w, e, d] =
\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d)"
using w' e e.ide_left e.ide_right e.antipar \<beta> D.assoc'_naturality
by (metis D.assoc_naturality D.in_homE e.triangle_equiv_form(1)
e.triangle_in_hom(3) e.triangle_in_hom(4) e.triangle_right
e.triangle_right' e.triangle_right_implies_left)
also have
"... = (\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w', e, d]) \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d)"
using D.comp_assoc by simp
also have "... = (((F g \<star>\<^sub>D w') \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d)"
using w' e e.antipar \<beta> D.comp_assoc_assoc' by simp
also have "... = (\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d"
proof -
have "\<guillemotleft>(\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d : ((F g \<star>\<^sub>D w) \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
using w e e.antipar \<beta>
by (intro D.hcomp_in_vhom, auto)
thus ?thesis
using D.comp_cod_arr by auto
qed
finally show ?thesis by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D
(\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] =
\<a>\<^sub>D[F g, w', e \<star>\<^sub>D d]"
proof -
have "D.seq (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d])
(\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d))"
using w w' e e.antipar D.hseqI'
by (intro D.seqI D.hseqI, auto)
thus ?thesis
using w w' e e.antipar D.pentagon [of "F g" w' e d] D.invert_side_of_triangle(2)
D.assoc'_eq_inv_assoc D.comp_assoc D.ide_hcomp D.ideD(1)
D.iso_assoc D.hcomp_simps(1) T'.ide_leg1 T.leg1_simps(2-3)
T.tab_simps(2) \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> \<open>trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)\<close>
e.ide_left e.ide_right preserves_src
by metis
qed
moreover have
"\<a>\<^sub>D[F g \<star>\<^sub>D w, e, d] \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D
(F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) =
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e \<star>\<^sub>D d]"
proof -
have "D.seq (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d)
(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]))"
using w w' e e.antipar D.hseqI'
by (intro D.seqI D.hseqI, auto)
moreover have "D.inv \<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w, e, d] = \<a>\<^sub>D[F g \<star>\<^sub>D w, e, d]"
using w w' e e.antipar D.iso_inv_iso D.inv_inv by simp
ultimately show ?thesis
using w w' e e.antipar D.pentagon' [of "F g" w e d]
D.iso_inv_iso D.inv_inv D.comp_assoc D.invert_side_of_triangle(1)
by (metis D.assoc'_simps(3) D.comp_null(2) D.ide_hcomp D.ideD(1)
D.iso_assoc' D.not_arr_null D.seq_if_composable D.src_hcomp' T'.ide_leg1
\<open>trg\<^sub>D e = a\<close> a_def e.ide_left e.ide_right)
qed
ultimately show ?thesis
using w w' e e.antipar \<beta> D.comp_assoc by metis
qed
also have "... = (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', trg\<^sub>D e] \<cdot>\<^sub>D
(((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, trg\<^sub>D e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e \<star>\<^sub>D d] =
\<a>\<^sub>D[F g, w', trg\<^sub>D e] \<cdot>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>)"
using w' e e.antipar D.assoc_naturality [of "F g" w' \<epsilon>] by simp
moreover have "\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) =
((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, trg\<^sub>D e]"
using w e e.antipar D.assoc'_naturality [of "F g" w "D.inv \<epsilon>"]
e.counit_is_iso e.counit_in_hom
by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = ((F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', trg\<^sub>D e]) \<cdot>\<^sub>D
(\<beta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, trg\<^sub>D e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]))"
proof -
have "((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) =
\<beta> \<star>\<^sub>D trg\<^sub>D e"
proof -
have "((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) =
((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D D.inv \<epsilon>)"
using w w' e e.antipar D.interchange [of \<beta> "F g \<star>\<^sub>D w" "e \<star>\<^sub>D d" "D.inv \<epsilon>"]
D.comp_arr_dom D.comp_cod_arr e.counit_is_iso
by (metis D.in_homE \<beta> d.unit_simps(1) d.unit_simps(3))
also have "... = ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
using w w' e e.antipar \<beta> D.interchange [of "F g \<star>\<^sub>D w'" \<beta> "D.inv \<epsilon>" "trg\<^sub>D e"]
D.comp_arr_dom D.comp_cod_arr e.counit_is_iso
by auto
also have
"... = (((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
using D.comp_assoc by simp
also have "... = ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon> \<cdot>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
using w' D.whisker_left [of "F g \<star>\<^sub>D w'"] by simp
also have "... = ((F g \<star>\<^sub>D w') \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
by (simp add: D.comp_arr_inv')
also have "... = \<beta> \<star>\<^sub>D trg\<^sub>D e"
using \<beta> D.comp_cod_arr D.hseqI'
by (metis D.hcomp_simps(4) D.comp_null(2) D.hseq_char' D.in_homE
D.src.preserves_cod D.src_cod e.counit_in_hom(2) e.counit_simps(4))
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w]"
using w w' D.runit_hcomp D.runit_hcomp [of "F g" w] by simp
also have "... = \<r>\<^sub>D[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D \<beta>"
using \<beta> D.runit'_naturality
by (metis D.arr_cod D.arr_dom D.cod_dom D.in_homE D.src.preserves_cod
D.src_dom D.src_hcomp' \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close>)
also have "... = (\<r>\<^sub>D[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w']) \<cdot>\<^sub>D \<beta>"
using D.comp_assoc by simp
also have "... = \<beta>"
using w' \<beta> D.comp_cod_arr D.comp_arr_inv' D.iso_runit by auto
finally show ?thesis by simp
qed
moreover have "\<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<gamma>)"
proof -
have "\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<gamma>) =
\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using w \<theta> \<gamma> D.whisker_left
by (metis D.arrI D.seqE T'.ide_leg0)
also have
"... = (\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D[w'])) \<cdot>\<^sub>D (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have 1: "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] =
\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using w w' e we w'e e.antipar P\<gamma>e D.assoc'_naturality [of "F f" \<gamma>e d]
by (metis D.cod_trg D.in_hhomE D.in_homE D.src_cod D.trg.preserves_cod
T'.leg0_simps(2,4-5) T.tab_simps(2) T.leg0_simps(2)
e.triangle_in_hom(4) e.triangle_right' preserves_src)
also have
2: "... = (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using D.comp_assoc by simp
also have "... = F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
proof -
have "(\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) =
(F f \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using 1 2 e.antipar D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc'
by force
also have "... = F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
proof -
have "\<guillemotleft>F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d : F f \<star>\<^sub>D (w \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D F f \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
using we 1 2 e.antipar P\<gamma>e D.hseqI'
by (intro D.hcomp_in_vhom, auto)
thus ?thesis
using D.comp_cod_arr by blast
qed
finally show ?thesis by blast
qed
finally have
"\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) =
F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = ((\<theta>' \<cdot>\<^sub>D \<r>\<^sub>D[F f \<star>\<^sub>D w']) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', src\<^sub>D w']) \<cdot>\<^sub>D (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using w' D.runit_hcomp(3) [of "F f" w'] D.comp_assoc by simp
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', src\<^sub>D w'] \<cdot>\<^sub>D
(F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>)) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using \<theta>' D.runit_naturality [of \<theta>'] D.comp_assoc by fastforce
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D ((F f \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using w' D.assoc'_naturality [of "F f" w' \<epsilon>] D.comp_assoc by simp
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D ((F f \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) = \<theta>' \<star>\<^sub>D \<epsilon>"
using D.interchange D.comp_arr_dom D.comp_cod_arr
by (metis D.in_homE \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> \<theta>' e.counit_simps(1)
e.counit_simps(3))
also have "... = (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d)"
using \<theta>' D.interchange [of u \<theta>' \<epsilon> "e \<star>\<^sub>D d"] D.comp_arr_dom D.comp_cod_arr
by auto
finally have "(\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D ((F f \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) = (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<a>\<^sub>D[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d])) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) =
(F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w \<star>\<^sub>D e, d]"
using D.assoc_naturality [of "F f" \<gamma>e d]
by (metis D.cod_trg D.in_hhomE D.in_homE D.src_cod D.trg.preserves_cod P\<gamma>e
T'.leg0_simps(2,4-5) T.tab_simps(2) T.leg0_simps(2) e e.antipar(1)
e.triangle_in_hom(4) e.triangle_right' preserves_src w'e)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<a>\<^sub>D[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) =
F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]"
using w D.comp_cod_arr D.comp_assoc_assoc' by (simp add: D.hseqI')
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d =
\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]"
proof -
have "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] =
\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using P\<gamma>e e.antipar D.assoc'_naturality
by (metis D.in_hhom_def D.in_homE D.vconn_implies_hpar(1)
D.vconn_implies_hpar(2) T'.leg0_simps(2,4-5)
T.leg0_simps(2) T.tab_simps(2) \<open>src\<^sub>D e = map\<^sub>0 a\<^sub>C\<close>
d.triangle_equiv_form(1) d.triangle_in_hom(3) d.triangle_left
preserves_src we)
also have
"... = (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using D.comp_assoc by simp
also have "... = (F f \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
using D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc' by auto
also have "... = F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
using D.comp_cod_arr
by (metis D.comp_cod_arr D.comp_null(2) D.hseq_char D.hseq_char'
D.in_homE D.whisker_left D.whisker_right P\<gamma>e T'.ide_leg0 e.ide_right)
finally show ?thesis by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D[F f \<star>\<^sub>D w', e, d]) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] =
\<a>\<^sub>D[F f \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d)"
proof -
have "\<a>\<^sub>D[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d] =
((F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (\<a>\<^sub>D[F f, w', e] \<star>\<^sub>D d)"
using w' D.pentagon D.comp_assoc by simp
moreover have "D.seq \<a>\<^sub>D[F f, w', e \<star>\<^sub>D d] \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d]"
using w' by simp
moreover have "D.inv (\<a>\<^sub>D[F f, w', e] \<star>\<^sub>D d) = \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d"
using w' by simp
ultimately show ?thesis
using w' D.comp_assoc
D.invert_opposite_sides_of_square
[of "\<a>\<^sub>D[F f, w', e \<star>\<^sub>D d]" "\<a>\<^sub>D[F f \<star>\<^sub>D w', e, d]"
"(F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d]"
"\<a>\<^sub>D[F f, w', e] \<star>\<^sub>D d"]
by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
(((\<theta>' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d] = \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D e) \<star>\<^sub>D d)"
using w' \<theta>' e.ide_left e.ide_right e.antipar D.assoc_naturality [of \<theta>' e d]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
((\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "((\<theta>' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) =
(\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d"
using w' w'e \<theta>' \<theta>\<^sub>C e.ide_left e.ide_right e.antipar D.whisker_right
by (metis (full_types) C.arrI D.cod_comp D.seqE D.seqI F\<theta>\<^sub>C_def P\<gamma>e
preserves_arr)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
((\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) =
\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using P\<gamma>e by simp
moreover have "D.arr (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e))"
by (metis C.in_homE D.comp_assoc D.comp_null(1) D.ext F\<theta>\<^sub>C_def P\<gamma>e \<theta>\<^sub>C
preserves_arr)
moreover have "D.arr (\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e])"
using P\<gamma>e calculation(2) by auto
ultimately have "(\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) =
(\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using \<psi> \<theta>\<^sub>C F\<theta>\<^sub>C_def D.iso_is_section D.section_is_mono
by (metis D.monoE)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
((\<theta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d])) \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d =
((\<theta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d)"
proof -
have "D.arr ((\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e])"
by (metis C.arrI D.cod_comp D.seqE D.seqI F\<theta>\<^sub>C_def \<theta>\<^sub>C preserves_arr)
thus ?thesis
using D.whisker_right e.ide_right by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
(((\<theta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f \<star>\<^sub>D w, e, d]) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using w D.pentagon' D.comp_assoc by simp
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((\<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[u, e, d]) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using \<theta> e.antipar D.assoc'_naturality [of \<theta> e d] D.comp_assoc by fastforce
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D
(F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(\<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u, e, d]) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) = \<theta> \<star>\<^sub>D e \<star>\<^sub>D d"
proof -
have "(\<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u, e, d]) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) =
(u \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d)"
using \<theta> ue e.ide_left e.ide_right e.antipar D.comp_arr_inv' D.comp_cod_arr
by auto
also have "... = \<theta> \<star>\<^sub>D e \<star>\<^sub>D d"
using ue e.ide_left e.ide_right e.antipar D.hcomp_simps(4) D.hseq_char' \<theta>
D.comp_cod_arr [of "\<theta> \<star>\<^sub>D e \<star>\<^sub>D d" "u \<star>\<^sub>D e \<star>\<^sub>D d"]
by force
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D ((u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d)) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
using w e.antipar D.assoc'_naturality [of "F f" w "D.inv \<epsilon>"] D.comp_assoc by simp
also have
"... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) = (\<theta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>)"
using \<theta> e.antipar D.interchange D.comp_arr_dom D.comp_cod_arr
by (metis D.in_homE \<open>trg\<^sub>D e = a\<close> e.counit_simps(1-3,5))
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
proof -
have "(((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] =
\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]"
proof -
have "(((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] =
((F f \<star>\<^sub>D w) \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]"
using w e.ide_left e.ide_right e.antipar e.counit_is_iso D.comp_arr_inv'
D.comp_assoc D.whisker_left
by (metis D.ide_hcomp D.seqI' T'.ide_leg0 T'.leg1_simps(3)
T.leg1_simps(2-3) T.tab_simps(2) \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close>
d.unit_in_vhom e.counit_in_hom(2) e.counit_simps(3) preserves_src)
also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]"
using w D.comp_cod_arr D.assoc'_in_hom(2) [of "F f" w "trg\<^sub>D e"] D.hseqI'
\<open>trg\<^sub>D e = a\<close> \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close>
by (metis D.assoc'_is_natural_1 D.ideD(1) D.ideD(2) D.trg.preserves_ide
D.trg_trg T'.leg0_simps(2,4) T'.leg1_simps(3)
T.leg1_simps(2-3) T.tab_simps(2) a_def e.ide_left
preserves_src)
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (\<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D trg\<^sub>D e)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f \<star>\<^sub>D w]"
using w D.runit_hcomp(2) [of "F f" w] D.comp_assoc by simp
also have 1: "... = (\<theta> \<cdot>\<^sub>D \<r>\<^sub>D[F f \<star>\<^sub>D w]) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f \<star>\<^sub>D w]"
using \<theta> D.runit_naturality [of \<theta>] by auto
also have "... = \<theta>"
using w \<theta> D.comp_arr_dom D.comp_assoc
by (metis D.hcomp_arr_obj(2) D.in_homE D.obj_src 1 \<open>src\<^sub>D \<theta> = a\<close> \<open>trg\<^sub>D e = a\<close>)
finally show ?thesis by simp
qed
ultimately show "\<guillemotleft>?\<gamma> : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D ?\<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<gamma>)"
by simp
show "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D \<gamma>' \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>') \<Longrightarrow> \<gamma>' = ?\<gamma>"
proof -
fix \<gamma>'
assume \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D \<gamma>' \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>')"
show "\<gamma>' = ?\<gamma>"
proof -
have "?\<gamma> = \<r>\<^sub>D[w'] \<cdot>\<^sub>D (w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<a>\<^sub>D[w', e, d] \<cdot>\<^sub>D ((\<gamma>' \<star>\<^sub>D e) \<star>\<^sub>D d)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
proof -
have "\<gamma>e = \<gamma>' \<star>\<^sub>D e"
proof -
have "\<guillemotleft>\<gamma>' \<star>\<^sub>D e : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
using \<gamma>' by (intro D.hcomp_in_vhom, auto)
moreover have
"\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] = F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e"
proof -
have "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] =
\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]"
using \<gamma>' by simp
also have "... = \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e)"
using \<gamma>' D.assoc_naturality
by (metis D.assoc'_naturality D.hcomp_in_vhomE D.ideD(2) D.ideD(3)
D.in_homE T'.leg1_simps(5-6) \<beta>
\<open>\<guillemotleft>\<gamma>' \<star>\<^sub>D e : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>\<close> e.ide_left)
also have "... = (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e)"
using D.comp_assoc by simp
also have "... = F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e"
by (metis D.hcomp_reassoc(2) D.in_homE D.not_arr_null D.seq_if_composable
T'.leg1_simps(2,5-6) \<beta> \<gamma>' calculation
\<open>\<guillemotleft>\<gamma>' \<star>\<^sub>D e : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>\<close> e.triangle_equiv_form(1)
e.triangle_in_hom(3) e.triangle_right e.triangle_right_implies_left)
finally show ?thesis by simp
qed
moreover have "\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e)"
proof -
have "\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e) =
\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using \<gamma>' \<theta> e.ide_left D.assoc'_naturality
by (metis D.hcomp_in_vhomE D.ideD(2) D.ideD(3) D.in_homE
T'.leg0_simps(2,4-5) T'.leg1_simps(3) \<beta> calculation(1))
also have "... = \<psi> \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using D.comp_assoc by simp
also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using D.whisker_right \<gamma>' \<theta> by auto
also have "... = \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
using \<gamma>' by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using UN by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<r>\<^sub>D[w'] \<cdot>\<^sub>D ((w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D e \<star>\<^sub>D d)) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using w' \<gamma>' D.comp_assoc D.assoc_naturality
by (metis D.in_homE D.src_dom \<open>trg\<^sub>D e = a\<close> a_def e.antipar(1)
e.triangle_equiv_form(1) e.triangle_in_hom(3-4)
e.triangle_right e.triangle_right' e.triangle_right_implies_left)
also have "... = (\<r>\<^sub>D[w'] \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D trg\<^sub>D e)) \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
proof -
have "(w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D e \<star>\<^sub>D d) = \<gamma>' \<star>\<^sub>D \<epsilon>"
using w' \<gamma>' e.antipar D.comp_arr_dom D.comp_cod_arr
D.interchange [of w' \<gamma>' \<epsilon> "e \<star>\<^sub>D d"]
by auto
also have "... = (\<gamma>' \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>)"
using w \<gamma>' e.antipar D.comp_arr_dom D.comp_cod_arr D.interchange
by (metis D.in_homE \<open>trg\<^sub>D e = a\<close> e.counit_simps(1) e.counit_simps(3,5))
finally have "(w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D e \<star>\<^sub>D d) = (\<gamma>' \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<gamma>' \<cdot>\<^sub>D \<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D
(w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using \<gamma>' D.runit_naturality D.comp_assoc
by (metis D.in_homE D.src_dom \<open>trg\<^sub>D e = a\<close> a_def)
also have "... = \<gamma>'"
proof -
have "\<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D
\<r>\<^sub>D\<^sup>-\<^sup>1[w] =
\<r>\<^sub>D[w] \<cdot>\<^sub>D ((w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D
\<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using D.comp_assoc by simp
also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D ((w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (w \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D
\<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using w \<gamma> e.ide_left e.ide_right we e.antipar D.comp_assoc_assoc'(1)
\<open>trg\<^sub>D e = a\<close> a_def
by presburger
also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D ((w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using w \<gamma> e.ide_left e.ide_right we e.antipar D.comp_cod_arr
by (metis D.whisker_left d.unit_simps(1,3))
also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D src\<^sub>D w) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using w e.counit_is_iso C.comp_arr_inv'
by (metis D.comp_arr_inv' D.seqI' D.whisker_left \<open>trg\<^sub>D e = a\<close> a_def
d.unit_in_vhom e.counit_in_hom(2) e.counit_simps(3))
also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
using w e.antipar D.comp_cod_arr by simp
also have "... = w"
using w
by (simp add: D.comp_arr_inv')
finally have "\<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D
(w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w] = w"
by simp
thus ?thesis
using \<gamma>' D.comp_arr_dom by auto
qed
finally show ?thesis by simp
qed
qed
qed
qed
qed
show ?thesis ..
qed
lemma reflects_tabulation:
assumes "C.ide r" and "C.ide f" and "\<guillemotleft>\<rho> : g \<Rightarrow>\<^sub>C r \<star>\<^sub>C f\<guillemotright>"
assumes "tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F r) (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>) (F f) (F g)"
shows "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g"
proof -
interpret \<rho>': tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>F r\<close> \<open>D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>\<close> \<open>F f\<close> \<open>F g\<close>
using assms by auto
interpret \<rho>: tabulation_data V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g
using assms by (unfold_locales, simp_all)
interpret \<rho>: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g
proof
show "\<And>u \<omega>. \<lbrakk> C.ide u; \<guillemotleft>\<omega> : C.dom \<omega> \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>w \<theta> \<nu>. C.ide w \<and> \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu> : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<guillemotright> \<and>
C.iso \<nu> \<and> \<rho>.composite_cell w \<theta> \<cdot>\<^sub>C \<nu> = \<omega>"
proof -
fix u \<omega>
assume u: "C.ide u"
assume \<omega>: "\<guillemotleft>\<omega> : C.dom \<omega> \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright>"
have hseq_ru: "src\<^sub>C r = trg\<^sub>C u"
using \<omega> C.ide_cod C.ideD(1) by fastforce
hence 1: "\<guillemotleft>D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F r \<star>\<^sub>D F u\<guillemotright>"
using assms u \<omega> \<Phi>_in_hom \<Phi>_components_are_iso
by (intro D.comp_in_homI, auto)
hence 2: "D.dom (D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega>) = F (C.dom \<omega>)"
by auto
obtain w \<theta> \<nu>
where w\<theta>\<nu>: "D.ide w \<and> \<guillemotleft>\<theta> : F f \<star>\<^sub>D w \<Rightarrow>\<^sub>D F u\<guillemotright> \<and>
\<guillemotleft>\<nu> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w\<guillemotright> \<and> D.iso \<nu> \<and>
\<rho>'.composite_cell w \<theta> \<cdot>\<^sub>D \<nu> = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega>"
using 1 2 u \<rho>'.T1 [of "F u" "D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega>"] by auto
have hseq_Ff_w: "src\<^sub>D (F f) = trg\<^sub>D w"
using u \<omega> w\<theta>\<nu>
by (metis "1" D.arrI D.not_arr_null D.seqE D.seq_if_composable \<rho>'.tab_simps(2))
have hseq_Fg_w: "src\<^sub>D (F g) = trg\<^sub>D w"
using u \<omega> w\<theta>\<nu> by (simp add: hseq_Ff_w)
have w: "\<guillemotleft>w : map\<^sub>0 (src\<^sub>C \<omega>) \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright>"
using u \<omega> w\<theta>\<nu> hseq_Fg_w
by (metis "1" C.arrI D.arrI D.hseqI' D.ideD(1) D.in_hhom_def D.src_hcomp'
D.src_vcomp D.vconn_implies_hpar(1) D.vconn_implies_hpar(3)
D.vseq_implies_hpar(1) \<rho>'.leg1_simps(2) \<rho>.leg0_simps(2) hseq_Ff_w
preserves_src)
obtain w' where w': "\<guillemotleft>w' : src\<^sub>C \<omega> \<rightarrow>\<^sub>C src\<^sub>C f\<guillemotright> \<and> C.ide w' \<and> D.isomorphic (F w') w"
using assms w \<omega> w\<theta>\<nu> locally_essentially_surjective by force
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F w' \<Rightarrow>\<^sub>D w\<guillemotright> \<and> D.iso \<phi>"
using w' D.isomorphic_def by blast
have src_fw': "src\<^sub>C (f \<star>\<^sub>C w') = src\<^sub>C u"
using u w' \<omega>
by (metis C.cod_src C.hseqI' C.ideD(1) C.in_hhom_def C.in_homE C.src.preserves_cod
C.hcomp_simps(1) \<rho>.leg0_in_hom(1) \<rho>.base_simps(2) hseq_ru)
have 3: "\<guillemotleft>\<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w')) : F (f \<star>\<^sub>C w') \<Rightarrow>\<^sub>D F u\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Phi> (f, w')) : F (f \<star>\<^sub>C w') \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F w'\<guillemotright>"
using assms w' \<Phi>_in_hom \<Phi>_components_are_iso by auto
show "\<guillemotleft>F f \<star>\<^sub>D \<phi> : F f \<star>\<^sub>D F w' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D w\<guillemotright>"
using \<phi> \<rho>'.leg0_in_hom(2) w' by auto
show "\<guillemotleft>\<theta> : F f \<star>\<^sub>D w \<Rightarrow>\<^sub>D F u\<guillemotright>"
using w\<theta>\<nu> by simp
qed
have 4: "\<exists>\<theta>'. \<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright> \<and> F \<theta>' = \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))"
using w' u hseq_ru src_fw' 3 locally_full by auto
obtain \<theta>' where
\<theta>': "\<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright> \<and> F \<theta>' = \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))"
using 4 by auto
have 5: "\<guillemotleft>\<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w')\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>\<nu> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w\<guillemotright>"
using w\<theta>\<nu> by simp
show "\<guillemotleft>F g \<star>\<^sub>D D.inv \<phi> : F g \<star>\<^sub>D w \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w'\<guillemotright>"
using assms \<phi>
by (meson D.hcomp_in_vhom D.inv_in_hom \<rho>'.leg1_in_hom(2) hseq_Fg_w)
show "\<guillemotleft>\<Phi> (g, w') : F g \<star>\<^sub>D F w' \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w')\<guillemotright>"
using assms w' \<Phi>_in_hom by auto
qed
have 6: "\<exists>\<nu>'. \<guillemotleft>\<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright> \<and>
F \<nu>' = \<Phi>(g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu>"
using u w' \<omega> C.in_hhom_def hseq_ru C.hseqI' C.hcomp_simps(1-2)
by (metis "5" C.arrI C.ide_hcomp C.ideD(1) C.ide_dom C.vconn_implies_hpar(1,4)
\<rho>.base_simps(2) \<rho>.ide_leg1 \<rho>.leg1_in_hom(1) locally_full)
obtain \<nu>' where
\<nu>': "\<guillemotleft>\<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright> \<and> F \<nu>' = \<Phi>(g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu>"
using 6 by auto
have "C.ide w' \<and> \<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright> \<and> C.iso \<nu>' \<and>
\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>' = \<omega>"
using w' \<theta>' \<nu>'
apply (intro conjI)
apply auto
proof -
show "C.iso \<nu>'"
proof -
have "D.iso (F \<nu>')"
proof -
have "D.iso (\<Phi>(g, w'))"
using w' \<Phi>_components_are_iso by auto
moreover have "D.iso (F g \<star>\<^sub>D D.inv \<phi>)"
using \<phi>
by (meson "5" D.arrI D.iso_hcomp D.hseq_char' D.ide_is_iso D.iso_inv_iso
D.seqE D.seq_if_composable \<rho>'.ide_leg1)
moreover have "D.iso \<nu>"
using w\<theta>\<nu> by simp
ultimately show ?thesis
using \<nu>' D.isos_compose
by (metis "5" D.arrI D.seqE)
qed
thus ?thesis using reflects_iso by blast
qed
have 7: "\<guillemotleft>\<rho>.composite_cell w' \<theta>' : g \<star>\<^sub>C w' \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright>"
using u w' \<theta>' \<rho>.composite_cell_in_hom hseq_ru src_fw' C.hseqI'
by (metis C.in_hhomE C.hcomp_simps(1) \<rho>.leg0_simps(2))
hence 8: "\<guillemotleft>\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright>"
using \<nu>' by blast
show "\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>' = \<omega>"
proof -
have 1: "C.par (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>') \<omega>"
using \<omega> 8 hseq_ru C.hseqI' C.in_homE by metis
moreover have "F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>') = F \<omega>"
proof -
have "F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>') =
F (r \<star>\<^sub>C \<theta>') \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w'] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w') \<cdot>\<^sub>D F \<nu>'"
using w' \<theta>' \<nu>' 1 C.comp_assoc
by (metis C.seqE preserves_comp)
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D
\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w'))) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
((D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D
\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<nu>'"
proof -
have "F \<a>\<^sub>C[r, f, w'] =
\<Phi> (r, f \<star>\<^sub>C w') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w'))"
using assms w'
by (simp add: C.in_hhom_def preserves_assoc(1))
moreover have
"F (r \<star>\<^sub>C \<theta>') = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w'))"
using assms \<theta>' preserves_hcomp [of r \<theta>']
by (metis "1" C.in_homE C.seqE \<rho>.base_simps(3) \<rho>.base_simps(4))
moreover have
"F (\<rho> \<star>\<^sub>C w') = \<Phi> (r \<star>\<^sub>C f, w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (g, w'))"
using w' preserves_hcomp [of \<rho> w'] by auto
ultimately show ?thesis
by (simp add: D.comp_assoc)
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
(F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<nu>'"
proof -
have "(D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) =
F r \<star>\<^sub>D \<Phi> (f, w')"
using w' \<Phi>_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
C.in_hhom_def C.trg_hcomp' D.comp_inv_arr' C.ide_hcomp
by (metis C.ideD(1) D.hcomp_simps(4) \<Phi>_simps(1,3-5)
\<rho>'.leg0_simps(3) \<rho>'.base_simps(2,4) \<rho>.ide_leg0 \<rho>.ide_base
\<rho>.leg0_simps(3))
moreover have "(D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') =
F \<rho> \<star>\<^sub>D F w'"
using w' D.comp_inv_arr' \<Phi>_components_are_iso D.hseqI' hseq_Fg_w D.comp_cod_arr
by auto
ultimately show ?thesis by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) \<cdot>\<^sub>D
(F r \<star>\<^sub>D \<Phi> (f, w'))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu>"
using w' \<theta>' \<nu>' D.comp_assoc by simp
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w')) \<cdot>\<^sub>D
\<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D
F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D ((D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D \<Phi> (g, w')) \<cdot>\<^sub>D
(F g \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D \<nu>"
proof -
have "(F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) =
F r \<star>\<^sub>D (\<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) \<cdot>\<^sub>D \<Phi> (f, w')"
proof -
have "D.seq (\<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) (\<Phi> (f, w'))"
using assms 3 \<rho>.ide_base w' w\<theta>\<nu> \<Phi>_in_hom [of f w'] \<Phi>_components_are_iso
C.in_hhom_def
apply (intro D.seqI)
using C.in_hhom_def
apply auto[3]
apply blast
by auto
thus ?thesis
using assms w' w\<theta>\<nu> \<Phi>_in_hom \<Phi>_components_are_iso D.whisker_left by simp
qed
moreover have "(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') =
D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w'"
using w' D.whisker_right by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D
(F g \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D \<nu>"
proof -
have "(F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w')) \<cdot>\<^sub>D \<Phi> (f, w') = F f \<star>\<^sub>D \<phi>"
using assms(2) w' \<phi> 3 \<Phi>_components_are_iso \<Phi>_in_hom D.hseqI' D.comp_inv_arr'
D.comp_arr_dom
by (metis C.in_hhom_def D.hcomp_simps(3) D.in_homE D.seqE \<rho>'.leg0_simps(4))
moreover have "(D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D \<Phi> (g, w')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) =
F g \<star>\<^sub>D D.inv \<phi>"
using assms w' \<phi> 3 \<Phi>_components_are_iso \<Phi>_in_hom D.hseqI' D.comp_inv_arr'
D.comp_cod_arr
by (metis "5" C.in_hhom_def D.arrI D.comp_assoc D.seqE \<rho>.ide_leg1
\<rho>.leg1_simps(3))
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
(\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w) \<cdot>\<^sub>D \<nu>"
proof -
have "(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) =
D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D D.inv \<phi>"
using assms w' \<phi> \<Phi>_in_hom \<Phi>_components_are_iso D.comp_arr_dom D.comp_cod_arr
D.interchange [of "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>" "F g" "F w'" "D.inv \<phi>"]
by auto
also have "... = ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w)"
using assms w' \<phi> \<Phi>_components_are_iso D.comp_arr_dom D.comp_cod_arr
D.interchange [of "F r \<star>\<^sub>D F f" "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>" "D.inv \<phi>" w]
by auto
finally have "(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) =
((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
(F r \<star>\<^sub>D F f \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w) \<cdot>\<^sub>D \<nu>"
proof -
have "\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>) =
(F r \<star>\<^sub>D F f \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w]"
proof -
have "src\<^sub>D (F r) = trg\<^sub>D (F f)"
by simp
moreover have "src\<^sub>D (F f) = trg\<^sub>D (D.inv \<phi>)"
using \<phi>
by (metis "5" D.arrI D.hseqE D.seqE \<rho>'.leg1_simps(3))
ultimately show ?thesis
using assms w' \<phi> D.assoc_naturality [of "F r" "F f" "D.inv \<phi>"] by auto
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w) \<cdot>\<^sub>D \<nu>"
using assms \<phi> w\<theta>\<nu> D.comp_arr_inv' D.comp_arr_dom D.comp_cod_arr
D.whisker_left D.whisker_left D.comp_assoc
by (metis D.ideD(1) D.in_homE \<rho>'.ide_base tabulation_data.leg0_simps(1)
tabulation_def)
also have "... = (\<Phi> (r, u) \<cdot>\<^sub>D D.inv (\<Phi> (r, u))) \<cdot>\<^sub>D F \<omega>"
using w\<theta>\<nu> D.comp_assoc by simp
also have "... = F \<omega>"
using u \<omega> \<Phi>_in_hom \<Phi>.components_are_iso D.comp_arr_inv'
by (metis C.in_homE \<Phi>_components_are_iso \<Phi>_simps(5) \<rho>.ide_base is_natural_1
naturality hseq_ru)
finally show ?thesis by blast
qed
ultimately show ?thesis
using is_faithful [of "\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>'" \<omega>] by simp
qed
qed
thus "\<exists>w \<theta> \<nu>. C.ide w \<and> \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu> : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<guillemotright> \<and>
C.iso \<nu> \<and> \<rho>.composite_cell w \<theta> \<cdot>\<^sub>C \<nu> = \<omega>"
by auto
qed
show "\<And>u w w' \<theta> \<theta>' \<beta>. \<lbrakk> C.ide w; C.ide w'; \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright>;
\<guillemotleft>\<beta> : g \<star>\<^sub>C w \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright>;
\<rho>.composite_cell w \<theta> = \<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta> \<rbrakk>
\<Longrightarrow> \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
proof -
fix u w w' \<theta> \<theta>' \<beta>
assume w: "C.ide w"
assume w': "C.ide w'"
assume \<theta>: "\<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright>"
assume \<theta>': "\<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright>"
assume \<beta>: "\<guillemotleft>\<beta> : g \<star>\<^sub>C w \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright>"
assume eq: "\<rho>.composite_cell w \<theta> = \<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta>"
show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
proof -
have hseq_ru: "src\<^sub>C r = trg\<^sub>C u"
using w \<theta>
by (metis C.horizontal_homs_axioms C.ideD(1) C.in_homE C.hcomp_simps(2)
C.vconn_implies_hpar(4) \<rho>.leg0_simps(3) category.ide_dom horizontal_homs_def)
have hseq_fw: "src\<^sub>C f = trg\<^sub>C w \<and> src\<^sub>C f = trg\<^sub>C w'"
using w w' \<rho>.ide_leg0 \<theta> \<theta>'
by (metis C.horizontal_homs_axioms C.ideD(1) C.in_homE C.not_arr_null
C.seq_if_composable category.ide_dom horizontal_homs_def)
have hseq_gw: "src\<^sub>C g = trg\<^sub>C w \<and> src\<^sub>C g = trg\<^sub>C w'"
using w w' \<rho>.ide_leg0 \<theta> \<theta>' \<open>src\<^sub>C f = trg\<^sub>C w \<and> src\<^sub>C f = trg\<^sub>C w'\<close> by auto
have *: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : F w \<Rightarrow>\<^sub>D F w'\<guillemotright> \<and>
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D \<gamma> \<and>
F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
proof -
have "D.ide (F w) \<and> D.ide (F w')"
using w w' by simp
moreover have 1: "\<guillemotleft>F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) : F f \<star>\<^sub>D F w \<Rightarrow>\<^sub>D F u\<guillemotright>"
using w \<theta> \<Phi>_in_hom \<rho>.ide_leg0 hseq_fw by blast
moreover have 2: "\<guillemotleft>F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') : F f \<star>\<^sub>D F w' \<Rightarrow>\<^sub>D F u\<guillemotright>"
using w' \<theta>' \<Phi>_in_hom \<rho>.ide_leg0 hseq_fw by blast
moreover have
"\<guillemotleft>D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) : F g \<star>\<^sub>D F w \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w'\<guillemotright>"
using w w' \<beta> \<rho>.ide_leg1 \<Phi>_in_hom \<Phi>_components_are_iso hseq_gw preserves_hom
by force
moreover have "\<rho>'.composite_cell (F w) (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) =
\<rho>'.composite_cell (F w') (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
proof -
have "\<rho>'.composite_cell (F w') (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) =
(F r \<star>\<^sub>D F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
using D.comp_assoc by simp
also have "... =
(F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
using w' \<theta>' 2 D.whisker_left D.whisker_right D.comp_assoc by auto
also have "... = (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D
\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w'))) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
((D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D
\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
proof -
have "(D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) =
F r \<star>\<^sub>D \<Phi> (f, w')"
using w' \<Phi>_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
C.in_hhom_def C.trg_hcomp' D.comp_inv_arr' C.ide_hcomp
by (metis C.ideD(1) D.hcomp_simps(4) \<Phi>_simps(1) \<Phi>_simps(3-5)
\<rho>'.leg0_simps(3) \<rho>'.base_simps(2,4) \<rho>.ide_leg0 \<rho>.ide_base
\<rho>.leg0_simps(3) hseq_fw)
moreover have "(D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') =
F \<rho> \<star>\<^sub>D F w'"
using w' D.comp_inv_arr' \<Phi>_in_hom \<Phi>_components_are_iso D.hseqI'
D.comp_cod_arr hseq_fw
by auto
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
(\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D (D.inv (\<Phi> (r, f \<star>\<^sub>C w'))) \<cdot>\<^sub>D
(\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
(D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D
(\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D
D.inv (\<Phi> (g, w'))) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
proof -
have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') = F r \<star>\<^sub>D F \<theta>'"
using assms(1) \<theta>' \<Phi>_components_are_iso D.comp_cod_arr D.hseqI' hseq_ru
D.comp_inv_arr'
by auto
thus ?thesis
using D.comp_assoc by metis
qed
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
(F (r \<star>\<^sub>C \<theta>') \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w'] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w')) \<cdot>\<^sub>D
F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
proof -
have "F (r \<star>\<^sub>C \<theta>') = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w'))"
using w' \<theta>' preserves_hcomp C.hseqI' hseq_ru by auto
moreover have "F \<a>\<^sub>C[r, f, w'] =
\<Phi> (r, f \<star>\<^sub>C w') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w'))"
using w' preserves_assoc(1) hseq_fw by force
moreover have
"F (\<rho> \<star>\<^sub>C w') = \<Phi> (r \<star>\<^sub>C f, w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (g, w'))"
using w' preserves_hcomp C.hseqI' hseq_fw by fastforce
ultimately show ?thesis
using D.comp_assoc by auto
qed
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F (\<rho>.composite_cell w' \<theta>') \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
using w' \<theta>' C.comp_assoc hseq_ru hseq_fw C.hseqI' by auto
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D (F (\<rho>.composite_cell w' \<theta>') \<cdot>\<^sub>D F \<beta>) \<cdot>\<^sub>D \<Phi> (g, w)"
using D.comp_assoc by simp
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta>) \<cdot>\<^sub>D \<Phi> (g, w)"
proof -
have "F (\<rho>.composite_cell w' \<theta>') \<cdot>\<^sub>D F \<beta> = F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta>)"
using w w' \<theta>' \<beta> \<rho>.composite_cell_in_hom
preserves_comp [of "\<rho>.composite_cell w' \<theta>'" \<beta>]
by (metis C.dom_comp C.hcomp_simps(3) C.ide_char C.in_homE C.seqE C.seqI
D.ext D.seqE \<rho>.tab_in_hom(2) is_extensional preserves_reflects_arr)
thus ?thesis by simp
qed
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F (\<rho>.composite_cell w \<theta>) \<cdot>\<^sub>D \<Phi> (g, w)"
using eq by simp
also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D \<Phi> (g, w)"
using w \<theta> C.comp_assoc hseq_ru hseq_fw C.hseqI' D.comp_assoc by auto
also have "... = ((D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
\<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>)) \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D
\<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D
\<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D
((D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D
\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w)) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D \<Phi> (g, w)"
proof -
have "F (r \<star>\<^sub>C \<theta>) = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w))"
using w \<theta> preserves_hcomp C.hseqI' hseq_ru by auto
moreover have "F \<a>\<^sub>C[r, f, w] =
\<Phi> (r, f \<star>\<^sub>C w) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w))"
using w preserves_assoc(1) hseq_fw by force
moreover have
"F (\<rho> \<star>\<^sub>C w) = \<Phi> (r \<star>\<^sub>C f, w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
using w preserves_hcomp C.hseqI' hseq_fw by fastforce
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w)"
proof -
have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>) = F r \<star>\<^sub>D F \<theta>"
using \<theta> \<Phi>_in_hom \<Phi>_components_are_iso D.comp_cod_arr hseq_ru D.hseqI'
D.comp_inv_arr'
by auto
moreover have
"(D.inv (\<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) =
F r \<star>\<^sub>D \<Phi> (f, w)"
using w \<Phi>_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
C.in_hhom_def C.trg_hcomp' D.comp_inv_arr' C.ide_hcomp
by (metis C.ideD(1) D.hcomp_simps(4) \<Phi>_simps(1) \<Phi>_simps(3-5)
\<rho>'.leg0_simps(3) \<rho>'.base_simps(2,4) \<rho>.ide_leg0 \<rho>.ide_base
\<rho>.leg0_simps(3) hseq_fw)
moreover have "(D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w) =
F \<rho> \<star>\<^sub>D F w"
using w D.comp_inv_arr' \<Phi>_components_are_iso D.hseqI' D.comp_cod_arr hseq_fw
by simp
moreover have "(F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D \<Phi> (g, w) = F \<rho> \<star>\<^sub>D F w"
using w \<theta> \<Phi>_components_are_iso D.comp_arr_dom D.comp_inv_arr'
hseq_gw D.hseqI'
by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = \<rho>'.composite_cell (F w) (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
using w \<theta> 1 D.whisker_left D.whisker_right D.comp_assoc by auto
finally show ?thesis by simp
qed
ultimately show ?thesis
using w w' \<theta> \<theta>' \<beta> eq
\<rho>'.T2 [of "F w" "F w'" "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)" "F u" "F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')"
"D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"]
by blast
qed
obtain \<gamma>' where \<gamma>': "\<guillemotleft>\<gamma>' : F w \<Rightarrow>\<^sub>D F w'\<guillemotright> \<and>
D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D \<gamma>' \<and>
F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>')"
using * by auto
obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> F \<gamma> = \<gamma>'"
using \<theta> \<theta> w w' \<gamma>' locally_full [of w w' \<gamma>']
by (metis C.hseqI' C.ideD(1) C.src_hcomp' C.vconn_implies_hpar(3)
\<rho>.leg0_simps(2) \<theta>' hseq_fw)
have "\<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
proof -
have "F \<theta> = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>))"
proof -
have "F \<theta> = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>') \<cdot>\<^sub>D D.inv (\<Phi> (f, w))"
using w' \<theta>' \<gamma>' preserves_hcomp hseq_fw D.comp_assoc D.invert_side_of_triangle
by (metis C.in_homE D.comp_arr_inv' \<Phi>_components_are_iso \<Phi>_simps(5) \<rho>.ide_leg0
\<theta> is_natural_1 w)
also have "... = F \<theta>' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>)"
using w' D.comp_assoc hseq_fw preserves_hcomp \<Phi>_components_are_iso
D.comp_arr_inv'
by (metis C.hseqI' C.in_homE C.trg_cod \<gamma> \<rho>.leg0_in_hom(2))
also have "... = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>))"
using \<gamma> \<theta>' hseq_fw C.hseqI' preserves_comp
by (metis C.hcomp_simps(4) C.in_homE C.seqI D.seqE \<rho>.leg0_simps(5) \<theta>
calculation preserves_reflects_arr)
finally show ?thesis by simp
qed
thus ?thesis
using \<gamma> \<theta> \<theta>' is_faithful
by (metis (mono_tags, lifting) C.cod_comp C.dom_comp C.hcomp_simps(3)
C.in_homE C.seqE \<rho>.leg0_simps(4) preserves_reflects_arr)
qed
moreover have "\<beta> = g \<star>\<^sub>C \<gamma>"
proof -
have "F \<beta> = F (g \<star>\<^sub>C \<gamma>)"
proof -
have "F \<beta> = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>') \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
by (metis (no_types) C.in_homE D.comp_arr_inv' D.comp_assoc
\<Phi>_components_are_iso \<Phi>_simps(5) \<beta> \<gamma>' \<rho>.ide_leg1 hseq_gw is_natural_1
naturality w w')
also have "... = F (g \<star>\<^sub>C \<gamma>)"
using w \<gamma> \<gamma>' preserves_hcomp hseq_gw
by (metis C.hseqE C.hseqI' C.in_homE C.seqE \<open>\<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)\<close>
\<rho>.leg1_simps(2) \<rho>.leg1_simps(5) \<rho>.leg1_simps(6) \<theta> hseq_fw)
finally show ?thesis by simp
qed
thus ?thesis
using \<gamma> \<beta> is_faithful
by (metis C.hcomp_simps(3-4) C.in_homE \<rho>.leg1_simps(5-6) preserves_reflects_arr)
qed
ultimately have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
using \<gamma> by blast
moreover have "\<And>\<gamma>\<^sub>1 \<gamma>\<^sub>2. \<guillemotleft>\<gamma>\<^sub>1 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>1 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>1) \<Longrightarrow>
\<guillemotleft>\<gamma>\<^sub>2 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>2 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>2) \<Longrightarrow> \<gamma>\<^sub>1 = \<gamma>\<^sub>2"
proof -
fix \<gamma>\<^sub>1 \<gamma>\<^sub>2
assume \<gamma>\<^sub>1: "\<guillemotleft>\<gamma>\<^sub>1 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>1 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>1)"
assume \<gamma>\<^sub>2: "\<guillemotleft>\<gamma>\<^sub>2 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>2 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>2)"
have F\<beta>\<^sub>1: "F \<beta> = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
using w w' \<beta> hseq_gw \<gamma>\<^sub>1 preserves_hcomp [of g \<gamma>\<^sub>1] \<Phi>_components_are_iso
by auto
have F\<beta>\<^sub>2: "F \<beta> = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
using w w' \<beta> hseq_gw \<gamma>\<^sub>2 preserves_hcomp [of g \<gamma>\<^sub>2] \<Phi>_components_are_iso
by auto
have "D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D F \<gamma>\<^sub>1"
proof -
have "F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>1)"
using w w' \<beta> hseq_gw \<gamma>\<^sub>1 F\<beta>\<^sub>1 preserves_hcomp \<Phi>_components_are_iso
D.invert_side_of_triangle D.iso_inv_iso
by (metis C.arrI D.comp_assoc D.inv_inv \<rho>.ide_leg1 preserves_reflects_arr)
thus ?thesis
using w w' \<beta> hseq_gw \<gamma>\<^sub>1 preserves_hcomp \<Phi>_components_are_iso
D.invert_side_of_triangle
by (metis C.arrI D.cod_comp D.seqE D.seqI F\<beta>\<^sub>1 \<rho>.ide_leg1 preserves_arr)
qed
moreover have "D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D F \<gamma>\<^sub>2"
proof -
have "F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>2)"
using w w' \<beta> hseq_gw \<gamma>\<^sub>2 F\<beta>\<^sub>2 preserves_hcomp \<Phi>_components_are_iso
D.invert_side_of_triangle D.iso_inv_iso
by (metis C.arrI D.comp_assoc D.inv_inv \<rho>.ide_leg1 preserves_reflects_arr)
thus ?thesis
using w w' \<beta> hseq_gw \<gamma>\<^sub>2 preserves_hcomp \<Phi>_components_are_iso
D.invert_side_of_triangle
by (metis C.arrI D.cod_comp D.seqE D.seqI F\<beta>\<^sub>2 \<rho>.ide_leg1 preserves_arr)
qed
moreover have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1)"
proof -
have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>1)) \<cdot>\<^sub>D \<Phi> (f, w)"
using \<gamma>\<^sub>1 by blast
also have "... = (F \<theta>' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>\<^sub>1)) \<cdot>\<^sub>D \<Phi> (f, w)"
using \<gamma>\<^sub>1 \<theta> by auto
also have
"... = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D D.inv (\<Phi> (f, w))) \<cdot>\<^sub>D \<Phi> (f, w)"
using C.hseqI' \<gamma>\<^sub>1 hseq_fw preserves_hcomp by auto
also have
"... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D D.inv (\<Phi> (f, w)) \<cdot>\<^sub>D \<Phi> (f, w)"
using D.comp_assoc by simp
also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D (F f \<star>\<^sub>D F w)"
by (simp add: D.comp_inv_arr' hseq_fw w)
also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1)"
using w \<gamma>\<^sub>1 D.whisker_left [of "F f" "F \<gamma>\<^sub>1" "F w"] D.comp_arr_dom by auto
finally show ?thesis
using D.comp_assoc by simp
qed
moreover have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2)"
proof -
have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>2)) \<cdot>\<^sub>D \<Phi> (f, w)"
using \<gamma>\<^sub>2 by blast
also have "... = (F \<theta>' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>\<^sub>2)) \<cdot>\<^sub>D \<Phi> (f, w)"
using \<gamma>\<^sub>2 \<theta> by auto
also have
"... = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D D.inv (\<Phi> (f, w))) \<cdot>\<^sub>D \<Phi> (f, w)"
using C.hseqI' \<gamma>\<^sub>2 hseq_fw preserves_hcomp by auto
also have
"... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D D.inv (\<Phi> (f, w)) \<cdot>\<^sub>D \<Phi> (f, w)"
using D.comp_assoc by simp
also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D (F f \<star>\<^sub>D F w)"
by (simp add: D.comp_inv_arr' hseq_fw w)
also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2)"
using w \<gamma>\<^sub>2 D.whisker_left [of "F f" "F \<gamma>\<^sub>2" "F w"] D.comp_arr_dom by auto
finally show ?thesis
using D.comp_assoc by simp
qed
ultimately have "F \<gamma>\<^sub>1 = F \<gamma>\<^sub>2"
using \<gamma>\<^sub>1 \<gamma>\<^sub>2 * by blast
thus "\<gamma>\<^sub>1 = \<gamma>\<^sub>2"
using \<gamma>\<^sub>1 \<gamma>\<^sub>2 is_faithful [of \<gamma>\<^sub>1 \<gamma>\<^sub>2] by auto
qed
ultimately show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
by blast
qed
qed
qed
show ?thesis ..
qed
end
end
diff --git a/thys/Bicategory/document/root.tex b/thys/Bicategory/document/root.tex
--- a/thys/Bicategory/document/root.tex
+++ b/thys/Bicategory/document/root.tex
@@ -1,346 +1,345 @@
\documentclass[11pt,notitlepage,a4paper]{report}
\usepackage{isabelle,isabellesym,eufrak}
\usepackage[english]{babel}
% For graphics files
\usepackage[pdftex]{graphicx}
% this should be the last package used
\usepackage{pdfsetup}
% urls in roman style, theory text in math-similar italics
\urlstyle{rm}
\isabellestyle{it}
% XYPic package, for drawing commutative diagrams.
\input{xy}
\xyoption{curve}
\xyoption{arrow}
\xyoption{matrix}
\xyoption{2cell}
\xyoption{line}
\UseAllTwocells
% Even though I stayed within the default boundary in the JEdit buffer,
% some proof lines wrap around in the PDF document. To minimize this,
% increase the text width a bit from the default.
\addtolength\textwidth{60pt}
\addtolength\oddsidemargin{-30pt}
\addtolength\evensidemargin{-30pt}
\begin{document}
\title{Bicategories}
\author{Eugene W. Stark\\[\medskipamount]
Department of Computer Science\\
Stony Brook University\\
Stony Brook, New York 11794 USA}
\maketitle
\begin{abstract}
Taking as a starting point the author's previous work
(\cite{Category3-AFP} \cite{MonoidalCategory-AFP})
on developing aspects of category theory in Isabelle/HOL, this article gives a
compatible formalization of the notion of ``bicategory'' and develops a
framework within which formal proofs of facts about bicategories can be given.
The framework includes a number of basic results, including the
Coherence Theorem, the Strictness Theorem, pseudofunctors and biequivalence,
and facts about internal equivalences and adjunctions in a bicategory.
As a driving application and demonstration of the utility of the framework,
it is used to give a formal proof of a theorem, due to Carboni, Kasangian,
and Street \cite{carboni-et-al}, that characterizes up to biequivalence
the bicategories of spans in a category with pullbacks.
The formalization effort necessitated the filling-in of many details
that were not evident from the brief presentation in the original paper,
as well as identifying a few minor corrections along the way.
\end{abstract}
\tableofcontents
\phantomsection
\addcontentsline{toc}{chapter}{Introduction}
\chapter*{Introduction}
Bicategories, introduced by B\'{e}nabou \cite{benabou}, are a generalization of categories
in which the sets of arrows between pairs of objects (\emph{i.e.}~the ``hom-sets'')
themselves have the structure of categories. In a typical formulation, the definition of
bicategories involves three separate kinds of entities: \emph{objects} (or \emph{$0$-cells}),
\emph{arrows} (or \emph{$1$-cells}), and morphisms between arrows (or \emph{$2$-cells}).
There are two kinds of composition: \emph{vertical} composition, which composes $2$-cells
within a single hom-category, and \emph{horizontal} composition, which composes $2$-cells in
``adjacent'' hom-categories ${\rm hom}(A, B)$ and ${\rm hom}(B, C)$.
Horizontal composition is required to be functorial with respect to vertical composition;
the identification of a $1$-cell with the corresponding identity $2$-cell then leads to the
ability to horizontally compose $1$-cells with $2$-cells (\emph{i.e.}~``whiskering'')
and to horizontally compose $1$-cells with each other.
Each hom-category ${\rm hom}(A, A)$ is further equipped with an \emph{identity} $1$-cell
${\rm id}_A$, which serves as a unit for horizontal composition.
In a \emph{strict} bicategory, also known as a \emph{$2$-category}, the usual unit and
associativity laws for horizontal composition are required to hold exactly,
or (as it is said) ``on the nose''.
In a general bicategory, these laws are only required to hold ``weakly'';
that is, up to a collection of (vertical) isomorphisms that satisfy certain
\emph{coherence conditions}.
A bicategory, all of whose hom-categories are discrete, is essentially an ordinary category.
A bicategory with just one object amounts to a monoidal category whose tensor is given by
horizontal composition.
Alternatively, we may think of bicategories as a generalization of monoidal categories in
which the tensor is permitted to be a partial operation, in analogy to the way in which
ordinary categories can be considered as a generalization of monoids.
A standard example of a bicategory is \textbf{Cat}, the bicategory whose $0$-cells are
categories, whose $1$-cells are functors, and whose $2$-cells are natural transformations.
This is in fact a $2$-category; however, as two categories that are related by an equivalence
of categories have the same ``categorical'' properties, it is often more sensible to
consider constructions on categories as given up to equivalence, rather than up to
isomorphism, and this leads to considering \textbf{Cat} as a bicategory and using
bicategorical constructions rather than as a $2$-category and using $2$-categorical ones.
This is one reason for the importance of bicategories: as Street \cite{street-fibrations-ii} remarks,
``In recent years it has become even more obvious that, although the fundamental constructions
of set theory are categorical, the fundamental constructions of category theory are bicategorical.''
An alternative reason for studying bicategories, which is more aligned with my own
personal interests and forms a major reason why I chose to pursue the present project,
is that they provide an elegant framework for theories of generalized relations,
as has been shown by Carboni, Walters, Street, and others \cite{carboni-et-al}
\cite{cartesian-bicategories-i} \cite{cartesian-bicategories-ii} \cite{carboni-partial-maps}.
Indeed, the category of sets and relations becomes a bicategory by taking the inclusions
between relations as $2$-cells and thereby becomes an exemplar of the notion
bicategory of relations which itself is a specialization of the notion of
cartesian bicategory \cite{cartesian-bicategories-i} \cite{cartesian-bicategories-ii}.
In the study of the semantics of programming languages containing nondeterministic or
concurrent constructs, it is natural to consider the meaning of a program in such a language
as some kind of relation between inputs and outputs. Ordinary relations can be used for
this purpose in simple situations, but they fail to be adequate for the study of higher-order
nondeterministic programs or for concurrent programs that engage in interaction with their environment,
so some sort of notion of generalized relation is needed. One is therefore led to try to identify
some kind of bicategories of generalized relations as framework suitable for defining the
semantics of such programs. One expects these to be instances of cartesian bicategories.
I attempted for a long time to try to develop a semantic framework for a certain class of
interactive concurrent programs along the lines outlined above, but ultimately failed to obtain
the kind of comprehensive understanding that I was seeking. The basic idea was to try to
regard a program as denoting a kind of generalized machine, expressed as some sort of
bimodule or two-sided fibration ({\em cf.}~\cite{street-fibrations-i} \cite{street-fibrations-ii}),
to be represented as a certain kind of span in an underlying category of ``maps'',
which would correspond to the meanings of deterministic programs.
A difficulty with trying to formulate any kind of theory like this is that there quickly gets
to be a lot of data and a lot of properties to keep track of, and it was certainly more than
I could handle.
For example, bicategories have objects, $1$-cells, and $2$-cells, as well as domains, codomains,
composition and identities for both the horizontal and vertical structure.
In addition, there are unit and associativity isomorphisms for the weak horizontal composition,
as well as their associated coherence conditions.
Cartesian bicategories are symmetric monoidal bicategories, which means that there is an additional
tensor product, which comes with another set of canonical isomorphisms and coherence conditions.
Still more canonical morphisms and coherence conditions are associated with the cartesian structure.
Even worse, in order to give a proper account of the computational ideas I was hoping to capture,
the underlying category of maps would at least have to be regarded as an ordered category,
if not a more general $2$-category or bicategory, so the situation starts to become truly daunting.
With so much data and so many properties, it is unusual in the literature to find proofs written
out in anything approaching complete detail.
To the extent that proofs are given, they often involve additional assumptions made purely for
convenience and presentational clarity, such as assuming that the bicategories under consideration
are strict when actually they are not, and then discharging these assumptions by appeals to informal
arguments such as ``the result holds in the general case because we can always replace a non-strict
bicategory by an equivalent strict one.''
This is perhaps fine if you happen to have finely honed insight, but in my case I am always left
wondering if something important hasn't been missed or glossed over, and I don't trust very much
my own ability to avoid gross errors if I were to work at the same level of detail as the proofs
that I see in the literature.
So my real motivation for the present project was to try to see whether a proof assistant
would actually be useful in carrying out fully formalized, machine-checkable proofs of some kind
of interesting facts about bicategories. I also hoped in the process to develop a better
understanding of some concepts that I knew that I hadn't understood very well.
The project described in the present article is divided into two main parts.
The first part, which comprises Chapter 1, seeks to develop a formalization of the notion of
bicategory using Isabelle/HOL and to prove various facts about bicategories that are required
for a subsequent application. Additional goals here are:
(1) to be able to make as much use as possible of the formalizations previously created for
categories \cite{Category3-AFP} and monoidal categories \cite{MonoidalCategory-AFP};
(2) to create a plausibly useful framework for future extension; and
(3) to better understand some subtleties involved in the definition of bicategory.
In this chapter, we give an HOL formalization of bicategories that makes use of and extends the
formalization of categories given in \cite{Category3-AFP}. In that previous work, categories
were formalized in an ``object-free'' style in terms of a suitably defined associative partial
binary operation of composition on a single type. Elements of the type that behave as units
for the composition were called ``identities'' and the ``arrows'' were identified as
the elements of the type that are composable both on the left and on the right with identities.
The identities composable in this way with an arrow were then shown to be uniquely determined,
which permitted domain and codomain functions to be defined.
This formalization of categories is economical in terms of basic data (only a single partial
binary operation is required), but perhaps more importantly, functors and natural transformations
need not be defined as structured objects, but instead can be taken to be ordinary functions
between types that suitably preserve arrows and composition.
In order to carry forward unchanged the framework developed for categories, for the
formalization of bicategories we take as a jumping-off point the somewhat offbeat view of
a bicategory as a single global category under vertical composition (the arrows are
the $2$-cells), which is then equipped with an additional partial binary operation of
horizontal composition. This point of view corresponds to thinking of bicategories as
generalizations of monoidal categories in which the tensor is allowed to be a partial
operation. In a direct generalization of the approach taken for categories,
we then show that certain \emph{weak units} with respect to the horizontal composition play
the role of $0$-cells (the identities with respect to vertical composition play the role
of $1$-cells) and that we can define the \emph{sources} and \emph{targets} of an arrow
as the sets of weak units horizontally composable on the right and on the left with it.
We then define a notion of weak associativity for the horizontal composition and arrive
at the definition of a \emph{prebicategory}, which consists of a (vertical) category equipped
with an associative weak (horizontal) composition, subject to the additional assumption
that every vertical arrow has a nonempty set of sources and targets with respect to
the horizontal composition.
We then show that, to obtain from a prebicategory a structure that satisfies a more
traditional-looking definition of a bicategory, all that is necessary is to choose
arbitrarily a particular representative source and target for each arrow.
Moreover, every bicategory determines a prebicategory by simply forgetting the chosen
sources and targets.
This development clarifies that an \emph{a priori} assignment of source and target objects
for each $2$-cell is merely a convenience, rather than an element essential to the notion
of bicategory.
Additional highlights of Chapter 1 are as follows:
\begin{itemize}
\item As a result of having formalized bicategories essentially as ``monoidal categories with
partial tensor'', we are able to generalize to bicategories, in a mostly straightforward way,
the proof of the Coherence Theorem we previously gave for monoidal categories in
\cite{MonoidalCategory-AFP}.
We then develop some machinery that enables us to apply the Coherence Theorem to shortcut
certain kinds of reasoning involving canonical isomorphisms.
%
\item Using the syntactic setup developed for the proof of the Coherence Theorem, we also
give a proof of the Strictness Theorem, which states that every bicategory is biequivalent
to a $2$-category, its so-called ``strictification''.
%
\item We define the notions of internal equivalence and internal adjunction in a bicategory
and prove a number of basic facts about these notions, including composition of equivalences
and adjunctions, and that every equivalence can be refined to an adjoint equivalence.
%
\item We formalize the notion of a pseudofunctor between bicategories, generalizing the
notion of a monoidal functor between monoidal categories and we show that pseudofunctors
preserve internal equivalences and adjunctions.
%
\item We define a sub-class of pseudofunctors which we call \emph{equivalence pseudofunctors}.
Equivalence pseudofunctors are intended to coincide with those pseudofunctors that can
be extended to an equivalence of bicategories, but we do not attempt to give an independent
definition equivalence of bicategories in the present development. Instead, we establish various
properties of equivalence pseudofunctors to provide some confidence that the notion has been
formalized correctly. Besides establishing various preservation results, we prove that,
given an equivalence pseudofunctor, we may obtain one in the converse direction.
For the rest of this article we use the property of two bicategories being connected by an
equivalence pseudofunctor as a surrogate for the property of biequivalence,
leaving for future work a more proper formulation of equivalence of bicategories and a
full verification of the relationship of this notion with equivalence pseudofunctors.
\end{itemize}
The second part of the project, presented in Chapter 2, is to demonstrate the utility of
the framework by giving a formalized proof of a nontrivial theorem about bicategories.
For this part, I chose to tackle a theorem of Carboni, Kasangian, and Street
(\cite{carboni-et-al}, ``CKS'' for short)
which gives axioms that characterize up to equivalence those bicategories whose $1$-cells are
spans of arrows in an underlying category with pullbacks and whose $2$-cells are arrows
of spans. The original paper is very short (nine pages in total) and the result I planned to
formalize (Theorem 4) was given on the sixth page. I thought I had basically understood this result
and that the formalization would not take very long to accomplish, but I definitely
underestimated both my prior understanding of the result and the amount of auxiliary material
that it would be necessary to formalize before I could complete the main proof.
Eventually I did complete the formalization, and in the process filled in what seemed to me
to be significant omissions in Carboni, Kasangian, and Street's presentation, as well as
correcting some errors of a minor nature.
Highlights of Chapter 2 are the following:
\begin{itemize}
\item A formalization of the notion of a category with chosen pullbacks, a proof that
this formalization is in agreement with the general definition of limits we gave
previously in \cite{Category3-AFP}, and the development of some basic properties
of a category with pullbacks.
%
\item A construction, given a category $C$ with chosen pullbacks, of the ``span bicategory''
${\rm Span}(C)$, whose objects are those of the given category, whose $1$-cells are spans
of arrows of $C$, and whose $2$-cells are arrows of spans.
We characterize the maps (the \emph{i.e.}~left adjoints) in ${\rm Span}(C)$ as
exactly those spans whose ``input leg'' is invertible.
%
\item A formalization of the notion of \emph{tabulation} of a $1$-cell in a bicategory
and a development of some of its properties. Tabulations are a kind of bicategorical
limit introduced by CKS, which can be used to define a kind of biuniversal way of factoring
a $1$-cell up to isomorphism as the horizontal composition of a map and the adjoint of
a map.
%
\item A formalization of \emph{bicategories of spans}, which are bicategories that satisfy
three axioms introduced in CKS. We give a formal proof of CKS Theorem 4,
which characterizes the bicategories of spans as those bicategories that are biequivalent
to a bicategory ${\rm Span}(C)$ for some category $C$ with pullbacks.
One direction of the proof shows that if $C$ is a category with pullbacks,
then ${\rm Span}(C)$ satisfies the axioms for a bicategory of spans.
Moreover, we show that the notion ``bicategory of spans'' is preserved under equivalence
of bicategories, so that in fact any bicategory biequivalent to one of the form ${\rm Span}(C)$
is a bicategory of spans.
Conversely, we show that if $B$ is a bicategory of spans, then $B$ is biequivalent
to ${\rm Span}({\rm Maps}(B))$, where ${\rm Maps}(B)$ is the so-called \emph{classifying category}
of the maps in $B$, which has as objects those of $B$ and as arrows the isomorphism classes
of maps in $B$.
In order to formalize the proof of this result, it was necessary to develop a number of
details not mentioned by CKS, including ways of composing tabulations vertically and
horizontally, and spelling out a way to choose pullbacks in ${\rm Maps}(B)$ so that
the tupling of arrows of ${\rm Maps}(B)$ obtained using the chosen pullbacks agrees
with that obtained through horizontal composition of tabulations.
These details were required in order to give the definition of the compositor for an equivalence
pseudofunctor ${\rm SPN}$ from $B$ to ${\rm Span}({\rm Maps}(B))$ and establish the
necessary coherence conditions.
\end{itemize}
In the end, I think it can be concluded that Isabelle/HOL can be used with benefit to formalize
proofs about bicategories. It is certainly very helpful for keeping track of the data
involved and the proof obligations required. For example, in the formalization given here,
a total of 99 separate subgoals are involved in proving that a given set of data constitutes
a bicategory (only 7 subgoals are required for an ordinary category)
and another 29 subgoals must be proved in order to establish a pseudofunctor between two
bicategories (only 5 additional subgoals are required for an ordinary functor),
but the proof assistant assumes the burden of keeping track of these proof obligations and
presenting them to the human user in a structured, understandable fashion.
On the other hand, some of the results proved here still required some lengthy equational
``diagram chases'' for which the proof assistant (at least so far) didn't provide that much help
(aside from checking their correctness).
An exception to this was in the case of equational reasoning about expressions constructed
purely of canonical isomorphisms, which our formulation of the Coherence Theorem permitted
to be carried out automatically by the simplifier.
It seems likely, though, that there is still room for more general procedures to be developed
in order to allow other currently lengthy chains of equational reasoning to be carried out
automatically.
\phantomsection
\addcontentsline{toc}{chapter}{Preliminaries}
\chapter*{Preliminaries}
-\input{ConcreteCategory.tex}
\input{IsomorphismClass.tex}
\chapter{Bicategories}
\input{Prebicategory.tex}
\input{Bicategory.tex}
\input{Coherence.tex}
\input{CanonicalIsos.tex}
\input{Subbicategory.tex}
\input{InternalEquivalence.tex}
\input{Pseudofunctor.tex}
\input{Strictness.tex}
\input{InternalAdjunction.tex}
\chapter{Bicategories of Spans}
\input{CategoryWithPullbacks.tex}
\input{SpanBicategory.tex}
\input{Tabulation.tex}
\input{BicategoryOfSpans.tex}
\phantomsection
\addcontentsline{toc}{chapter}{Bibliography}
\bibliographystyle{abbrv}
\bibliography{root}
\end{document}
diff --git a/thys/Category3/AbstractedCategory.thy b/thys/Category3/AbstractedCategory.thy
deleted file mode 100644
--- a/thys/Category3/AbstractedCategory.thy
+++ /dev/null
@@ -1,186 +0,0 @@
-(* Title: AbstractedCategory
- Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
- Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
-*)
-
-chapter AbstractedCategory
-
-theory AbstractedCategory
-imports Category
-begin
-
- text\<open>
- The locale defined here allows us to lift a category to a different arrow
- type via an abstraction map. It is used to obtain categories with opaque
- arrow types, by first defining the category on the concrete representation type,
- then lifting the composition to the abstract type. I apply this technique
- in several places to avoid the possibility of ``contaminating'' theories
- with specific details about a particular construction on categories.
- The construction of functor categories is a good example of this.
-\<close>
-
- locale abstracted_category =
- C: category C
- for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
- and A :: "'c \<Rightarrow> 'a"
- and R :: "'a \<Rightarrow> 'c"
- and S :: "'c set" +
- assumes abs_rep: "A (R f) = f"
- and rep_abs: "x \<in> S \<Longrightarrow> R (A x) = x"
- and rep_in_domain: "R f \<in> S"
- and domain_closed: "C.arr x \<or> x = C.null \<Longrightarrow> x \<in> S"
- begin
-
- definition comp (infixr "\<cdot>" 55)
- where "g \<cdot> f \<equiv> if C.arr (R g \<cdot>\<^sub>C R f) then A (R g \<cdot>\<^sub>C R f) else A C.null"
-
- interpretation partial_magma comp
- proof
- show "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
- proof
- show "\<forall>f. A C.null \<cdot> f = A C.null \<and> f \<cdot> A C.null = A C.null"
- unfolding comp_def using rep_abs domain_closed by auto
- show "\<And>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n \<Longrightarrow> n = A C.null"
- unfolding comp_def using rep_abs domain_closed C.comp_null(1) by metis
- qed
- qed
-
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
-
- lemma null_char:
- shows "null = A C.null"
- using domain_closed rep_abs
- by (metis (no_types, lifting) C.comp_null(2) comp_def comp_null(1))
-
- lemma abs_preserves_ide:
- shows "C.ide f \<Longrightarrow> ide (A f)"
- proof -
- have "C.ide f \<Longrightarrow> A f \<cdot> A f \<noteq> null"
- using comp_def null_char rep_abs abs_rep domain_closed
- by (metis C.ideD(1) C.comp_ide_self C.not_arr_null)
- thus "C.ide f \<Longrightarrow> ide (A f)"
- unfolding ide_def
- using comp_def null_char rep_abs abs_rep domain_closed C.comp_arr_dom C.comp_cod_arr
- by fastforce
- qed
-
- lemma has_domain_char':
- shows "domains f \<noteq> {} \<longleftrightarrow> C.domains (R f) \<noteq> {}"
- proof
- assume f: "domains f \<noteq> {}"
- show "C.domains (R f) \<noteq> {}"
- using f unfolding domains_def C.domains_def comp_def null_char apply auto
- by (metis C.seqE C.cod_in_codomains C.comp_arr_dom C.has_codomain_iff_arr
- C.self_domain_iff_ide C.domains_char C.domains_comp C.domains_null C.codomains_char)
- next
- assume f: "C.domains (R f) \<noteq> {}"
- obtain a where a: "a \<in> C.domains (R f)" using f by blast
- have "A a \<in> domains f"
- proof -
- have "ide (A a)"
- using a abs_preserves_ide C.domains_def by simp
- moreover have "comp f (A a) \<noteq> null"
- using a
- unfolding comp_def C.domains_def null_char
- using domain_closed rep_abs C.in_homE C.ext by (simp, metis)
- ultimately show ?thesis using domains_def by blast
- qed
- thus "domains f \<noteq> {}" by auto
- qed
-
- lemma has_codomain_char':
- shows "codomains f \<noteq> {} \<longleftrightarrow> C.codomains (R f) \<noteq> {}"
- proof
- assume f: "codomains f \<noteq> {}"
- show "C.codomains (R f) \<noteq> {}"
- using f unfolding codomains_def C.codomains_def comp_def null_char apply auto
- by (metis (no_types, lifting) C.seqE C.cod_in_codomains C.comp_cod_arr
- C.has_codomain_iff_arr C.not_arr_null C.self_domain_iff_ide C.domains_char
- C.codomains_char)
- next
- assume f: "C.codomains (R f) \<noteq> {}"
- obtain b where b: "b \<in> C.codomains (R f)" using f by blast
- have "A b \<in> codomains f"
- proof -
- have "ide (A b)"
- using b abs_preserves_ide C.codomains_def by simp
- moreover have "comp (A b) f \<noteq> null"
- using b
- unfolding comp_def C.codomains_def null_char
- using domain_closed rep_abs C.in_homE C.ext by (simp, metis)
- ultimately show ?thesis using codomains_def by blast
- qed
- thus "codomains f \<noteq> {}" by auto
- qed
-
- lemma arr_char:
- shows "arr f \<longleftrightarrow> C.arr (R f)"
- using comp_def null_char arr_def C.arr_def has_domain_char' has_codomain_char' by simp
-
- lemma is_category:
- shows "category comp"
- proof
- fix f g h
- show 0: "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
- unfolding arr_def
- using domain_closed rep_abs has_domain_char' has_codomain_char' null_char
- by (auto simp add: C.has_domain_iff_arr comp_def)
- show "(domains f \<noteq> {}) = (codomains f \<noteq> {})"
- using has_domain_char' has_codomain_char' C.has_domain_iff_arr C.has_codomain_iff_arr
- by simp
- show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
- using comp_def arr_char rep_abs domain_closed
- by (metis C.seqE C.seqI C.dom_comp)
- show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
- using comp_def arr_char rep_abs domain_closed
- by (metis (full_types) C.compatible_iff_seq C.codomains_comp)
- show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
- using comp_def arr_char rep_abs domain_closed
- by (metis (full_types) C.compatible_iff_seq C.domains_comp)
- show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
- using comp_def rep_abs domain_closed C.comp_assoc by fastforce
- qed
-
- end
-
- sublocale abstracted_category \<subseteq> category comp
- using is_category by auto
-
- context abstracted_category
- begin
-
- lemma has_domain_char:
- shows "domains f \<noteq> {} \<longleftrightarrow> C.arr (R f)"
- using has_domain_char' by (simp add: C.arr_def C.has_domain_iff_has_codomain)
-
- lemma has_cod_char:
- shows "codomains f \<noteq> {} \<longleftrightarrow> C.arr (R f)"
- using has_codomain_char' by (simp add: C.arr_def C.has_domain_iff_has_codomain)
-
- lemma dom_char:
- shows "dom f = (if arr f then A (C.dom (R f)) else null)"
- using arr_char abs_preserves_ide has_domain_iff_arr dom_def
- domain_closed comp_def rep_abs C.arr_dom_iff_arr
- apply (cases "arr f")
- by (intro dom_eqI, simp_all)
-
- lemma cod_char:
- shows "cod f = (if arr f then A (C.cod (R f)) else null)"
- using arr_char abs_preserves_ide has_codomain_iff_arr cod_def
- domain_closed comp_def rep_abs C.arr_cod_iff_arr
- apply (cases "arr f")
- by (intro cod_eqI, simp_all)
-
- lemma ide_char:
- shows "ide a \<longleftrightarrow> C.ide (R a)"
- using arr_char dom_char domain_closed abs_rep rep_abs abs_preserves_ide
- by (metis C.arr_dom C.ide_char' ide_char)
-
- lemma comp_char:
- shows "g \<cdot> f = (if seq g f then A (R g \<cdot>\<^sub>C R f) else null)"
- using arr_char dom_char cod_char comp_def null_char seqI' not_arr_null
- by (simp add: domain_closed rep_abs)
-
- end
-
-end
diff --git a/thys/Category3/Adjunction.thy b/thys/Category3/Adjunction.thy
--- a/thys/Category3/Adjunction.thy
+++ b/thys/Category3/Adjunction.thy
@@ -1,3077 +1,3067 @@
(* Title: Adjunction
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter Adjunction
theory Adjunction
imports Yoneda
begin
text\<open>
This theory defines the notions of adjoint functor and adjunction in various
ways and establishes their equivalence.
The notions ``left adjoint functor'' and ``right adjoint functor'' are defined
in terms of universal arrows.
``Meta-adjunctions'' are defined in terms of natural bijections between hom-sets,
where the notion of naturality is axiomatized directly.
``Hom-adjunctions'' formalize the notion of adjunction in terms of natural
isomorphisms of hom-functors.
``Unit-counit adjunctions'' define adjunctions in terms of functors equipped
with unit and counit natural transformations that satisfy the usual
``triangle identities.''
The \<open>adjunction\<close> locale is defined as the grand unification of all the
definitions, and includes formulas that connect the data from each of them.
It is shown that each of the definitions induces an interpretation of the
\<open>adjunction\<close> locale, so that all the definitions are essentially equivalent.
Finally, it is shown that right adjoint functors are unique up to natural
isomorphism.
The reference \cite{Wikipedia-Adjoint-Functors} was useful in constructing this theory.
\<close>
section "Left Adjoint Functor"
text\<open>
``@{term e} is an arrow from @{term "F x"} to @{term y}.''
\<close>
locale arrow_from_functor =
C: category C +
D: category D +
F: "functor" D C F
for D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and F :: "'d \<Rightarrow> 'c"
and x :: 'd
and y :: 'c
and e :: 'c +
assumes arrow: "D.ide x \<and> C.in_hom e (F x) y"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
text\<open>
``@{term g} is a @{term[source=true] D}-coextension of @{term f} along @{term e}.''
\<close>
definition is_coext :: "'d \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
where "is_coext x' f g \<equiv> \<guillemotleft>g : x' \<rightarrow>\<^sub>D x\<guillemotright> \<and> f = e \<cdot>\<^sub>C F g"
end
text\<open>
``@{term e} is a terminal arrow from @{term "F x"} to @{term y}.''
\<close>
locale terminal_arrow_from_functor =
arrow_from_functor D C F x y e
for D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and F :: "'d \<Rightarrow> 'c"
and x :: 'd
and y :: 'c
and e :: 'c +
assumes is_terminal: "arrow_from_functor D C F x' y f \<Longrightarrow> (\<exists>!g. is_coext x' f g)"
begin
definition the_coext :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
where "the_coext x' f = (THE g. is_coext x' f g)"
lemma the_coext_prop:
assumes "arrow_from_functor D C F x' y f"
shows "\<guillemotleft>the_coext x' f : x' \<rightarrow>\<^sub>D x\<guillemotright>" and "f = e \<cdot>\<^sub>C F (the_coext x' f)"
using assms is_terminal the_coext_def is_coext_def theI2 [of "\<lambda>g. is_coext x' f g"]
apply metis
using assms is_terminal the_coext_def is_coext_def theI2 [of "\<lambda>g. is_coext x' f g"]
by metis
lemma the_coext_unique:
assumes "arrow_from_functor D C F x' y f" and "is_coext x' f g"
shows "g = the_coext x' f"
using assms is_terminal the_coext_def the_equality by metis
end
text\<open>
A left adjoint functor is a functor \<open>F: D \<rightarrow> C\<close>
that enjoys the following universal coextension property: for each object
@{term y} of @{term C} there exists an object @{term x} of @{term D} and an
arrow \<open>e \<in> C.hom (F x) y\<close> such that for any arrow
\<open>f \<in> C.hom (F x') y\<close> there exists a unique \<open>g \<in> D.hom x' x\<close>
such that @{term "f = C e (F g)"}.
\<close>
locale left_adjoint_functor =
C: category C +
D: category D +
"functor" D C F
for D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and F :: "'d \<Rightarrow> 'c" +
assumes ex_terminal_arrow: "C.ide y \<Longrightarrow> (\<exists>x e. terminal_arrow_from_functor D C F x y e)"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
end
section "Right Adjoint Functor"
text\<open>
``@{term e} is an arrow from @{term x} to @{term "G y"}.''
\<close>
locale arrow_to_functor =
C: category C +
D: category D +
G: "functor" C D G
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and G :: "'c \<Rightarrow> 'd"
and x :: 'd
and y :: 'c
and e :: 'd +
assumes arrow: "C.ide y \<and> D.in_hom e x (G y)"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
text\<open>
``@{term f} is a @{term[source=true] C}-extension of @{term g} along @{term e}.''
\<close>
definition is_ext :: "'c \<Rightarrow> 'd \<Rightarrow> 'c \<Rightarrow> bool"
where "is_ext y' g f \<equiv> \<guillemotleft>f : y \<rightarrow>\<^sub>C y'\<guillemotright> \<and> g = G f \<cdot>\<^sub>D e"
end
text\<open>
``@{term e} is an initial arrow from @{term x} to @{term "G y"}.''
\<close>
locale initial_arrow_to_functor =
arrow_to_functor C D G x y e
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and G :: "'c \<Rightarrow> 'd"
and x :: 'd
and y :: 'c
and e :: 'd +
assumes is_initial: "arrow_to_functor C D G x y' g \<Longrightarrow> (\<exists>!f. is_ext y' g f)"
begin
definition the_ext :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
where "the_ext y' g = (THE f. is_ext y' g f)"
lemma the_ext_prop:
assumes "arrow_to_functor C D G x y' g"
shows "\<guillemotleft>the_ext y' g : y \<rightarrow>\<^sub>C y'\<guillemotright>" and "g = G (the_ext y' g) \<cdot>\<^sub>D e"
using assms is_initial the_ext_def is_ext_def theI2 [of "\<lambda>f. is_ext y' g f"]
apply metis
using assms is_initial the_ext_def is_ext_def theI2 [of "\<lambda>f. is_ext y' g f"]
by metis
lemma the_ext_unique:
assumes "arrow_to_functor C D G x y' g" and "is_ext y' g f"
shows "f = the_ext y' g"
using assms is_initial the_ext_def the_equality by metis
end
text\<open>
A right adjoint functor is a functor \<open>G: C \<rightarrow> D\<close>
that enjoys the following universal extension property:
for each object @{term x} of @{term D} there exists an object @{term y} of @{term C}
and an arrow \<open>e \<in> D.hom x (G y)\<close> such that for any arrow
\<open>g \<in> D.hom x (G y')\<close> there exists a unique \<open>f \<in> C.hom y y'\<close>
such that @{term "h = D e (G f)"}.
\<close>
locale right_adjoint_functor =
C: category C +
D: category D +
"functor" C D G
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and G :: "'c \<Rightarrow> 'd" +
assumes initial_arrows_exist: "D.ide x \<Longrightarrow> (\<exists>y e. initial_arrow_to_functor C D G x y e)"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
end
section "Various Definitions of Adjunction"
subsection "Meta-Adjunction"
text\<open>
A ``meta-adjunction'' consists of a functor \<open>F: D \<rightarrow> C\<close>,
a functor \<open>G: C \<rightarrow> D\<close>, and for each object @{term x}
of @{term C} and @{term y} of @{term D} a bijection between
\<open>C.hom (F y) x\<close> to \<open>D.hom y (G x)\<close> which is natural in @{term x}
and @{term y}. The naturality is easy to express at the meta-level without having
to resort to the formal baggage of ``set category,'' ``hom-functor,''
and ``natural isomorphism,'' hence the name.
\<close>
locale meta_adjunction =
C: category C +
D: category D +
F: "functor" D C F +
G: "functor" C D G
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and F :: "'d \<Rightarrow> 'c"
and G :: "'c \<Rightarrow> 'd"
and \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
and \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c" +
assumes \<phi>_in_hom: "\<lbrakk> D.ide y; C.in_hom f (F y) x \<rbrakk> \<Longrightarrow> D.in_hom (\<phi> y f) y (G x)"
and \<psi>_in_hom: "\<lbrakk> C.ide x; D.in_hom g y (G x) \<rbrakk> \<Longrightarrow> C.in_hom (\<psi> x g) (F y) x"
and \<psi>_\<phi>: "\<lbrakk> D.ide y; C.in_hom f (F y) x \<rbrakk> \<Longrightarrow> \<psi> x (\<phi> y f) = f"
and \<phi>_\<psi>: "\<lbrakk> C.ide x; D.in_hom g y (G x) \<rbrakk> \<Longrightarrow> \<phi> y (\<psi> x g) = g"
and \<phi>_naturality: "\<lbrakk> C.in_hom f x x'; D.in_hom g y' y; C.in_hom h (F y) x \<rbrakk> \<Longrightarrow>
\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
text\<open>
The naturality of @{term \<psi>} is a consequence of the naturality of @{term \<phi>}
and the other assumptions.
\<close>
lemma \<psi>_naturality:
assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = \<psi> x' (G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g)"
proof -
have "\<guillemotleft>f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g : F y' \<rightarrow>\<^sub>C x'\<guillemotright>"
using f g h \<psi>_in_hom [of x h] by fastforce
moreover have "\<guillemotleft>(G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g : y' \<rightarrow>\<^sub>D G x'\<guillemotright>"
using f g h \<phi>_in_hom by auto
moreover have "\<psi> x' (\<phi> y' (f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g)) = \<psi> x' (G f \<cdot>\<^sub>D \<phi> y (\<psi> x h) \<cdot>\<^sub>D g)"
proof -
have "\<guillemotleft>\<psi> x h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
using f h \<psi>_in_hom by auto
thus ?thesis using f g \<phi>_naturality
by force
qed
ultimately show ?thesis
using f h \<psi>_\<phi> \<phi>_\<psi>
by (metis C.arrI C.ide_dom C.in_homE D.arrI D.ide_dom D.in_homE)
qed
end
subsection "Hom-Adjunction"
text\<open>
The bijection between hom-sets that defines an adjunction can be represented
formally as a natural isomorphism of hom-functors. However, stating the definition
this way is more complex than was the case for \<open>meta_adjunction\<close>.
One reason is that we need to have a ``set category'' that is suitable as
a target category for the hom-functors, and since the arrows of the categories
@{term C} and @{term D} will in general have distinct types, we need a set category
that simultaneously embeds both. Another reason is that we simply have to formally
construct the various categories and functors required to express the definition.
This is a good place to point out that I have often included more sublocales
in a locale than are strictly required. The main reason for this is the fact that
the locale system in Isabelle only gives one name to each entity introduced by
a locale: the name that it has in the first locale in which it occurs.
This means that entities that make their first appearance deeply nested in sublocales
will have to be referred to by long qualified names that can be difficult to
understand, or even to discover. To counteract this, I have typically introduced
sublocales before the superlocales that contain them to ensure that the entities
in the sublocales can be referred to by short meaningful (and predictable) names.
In my opinion, though, it would be better if the locale system would make entities
that occur in multiple locales accessible by \emph{all} possible qualified names,
so that the most perspicuous name could be used in any particular context.
\<close>
locale hom_adjunction =
C: category C +
D: category D +
S: set_category S +
Cop: dual_category C +
Dop: dual_category D +
CopxC: product_category Cop.comp C +
DopxD: product_category Dop.comp D +
DopxC: product_category Dop.comp C +
F: "functor" D C F +
G: "functor" C D G +
HomC: hom_functor C S \<phi>C +
HomD: hom_functor D S \<phi>D +
Fop: dual_functor Dop.comp Cop.comp F +
FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
\<Phi>: set_valued_transformation DopxC.comp S Hom_FopxC.map Hom_DopxG.map \<Phi> +
\<Psi>: set_valued_transformation DopxC.comp S Hom_DopxG.map Hom_FopxC.map \<Psi> +
\<Phi>\<Psi>: inverse_transformations DopxC.comp S Hom_FopxC.map Hom_DopxG.map \<Phi> \<Psi>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi>C :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and \<phi>D :: "'d * 'd \<Rightarrow> 'd \<Rightarrow> 's"
and F :: "'d \<Rightarrow> 'c"
and G :: "'c \<Rightarrow> 'd"
and \<Phi> :: "'d * 'c \<Rightarrow> 's"
and \<Psi> :: "'d * 'c \<Rightarrow> 's"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
abbreviation \<psi>C :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
where "\<psi>C \<equiv> HomC.\<psi>"
abbreviation \<psi>D :: "'d * 'd \<Rightarrow> 's \<Rightarrow> 'd"
where "\<psi>D \<equiv> HomD.\<psi>"
end
subsection "Unit/Counit Adjunction"
text\<open>
Expressed in unit/counit terms, an adjunction consists of functors
\<open>F: D \<rightarrow> C\<close> and \<open>G: C \<rightarrow> D\<close>, equipped with natural transformations
\<open>\<eta>: 1 \<rightarrow> GF\<close> and \<open>\<epsilon>: FG \<rightarrow> 1\<close> satisfying certain ``triangle identities''.
\<close>
locale unit_counit_adjunction =
C: category C +
D: category D +
F: "functor" D C F +
G: "functor" C D G +
GF: composite_functor D C D F G +
FG: composite_functor C D C G F +
- FGF: composite_functor D C C F "F o G" +
- GFG: composite_functor C D D G "G o F" +
- \<eta>: natural_transformation D D D.map "G o F" \<eta> +
- \<epsilon>: natural_transformation C C "F o G" C.map \<epsilon> +
- F\<eta>: horizontal_composite D D C D.map "G o F" F F \<eta> F +
- \<eta>G: horizontal_composite C D D G G D.map "G o F" G \<eta> +
- \<epsilon>F: horizontal_composite D C C F F "F o G" C.map F \<epsilon> +
- G\<epsilon>: horizontal_composite C C D "F o G" C.map G G \<epsilon> G +
- \<epsilon>FoF\<eta>: vertical_composite D C F "F o G o F" F "F o \<eta>" "\<epsilon> o F" +
- G\<epsilon>o\<eta>G: vertical_composite C D G "G o F o G" G "\<eta> o G" "G o \<epsilon>"
+ FGF: composite_functor D C C F \<open>F o G\<close> +
+ GFG: composite_functor C D D G \<open>G o F\<close> +
+ \<eta>: natural_transformation D D D.map \<open>G o F\<close> \<eta> +
+ \<epsilon>: natural_transformation C C \<open>F o G\<close> C.map \<epsilon> +
+ F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>\<close> +
+ \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta> o G\<close> +
+ \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close> +
+ G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>\<close> +
+ \<epsilon>FoF\<eta>: vertical_composite D C F \<open>F o G o F\<close> F \<open>F o \<eta>\<close> \<open>\<epsilon> o F\<close> +
+ G\<epsilon>o\<eta>G: vertical_composite C D G \<open>G o F o G\<close> G \<open>\<eta> o G\<close> \<open>G o \<epsilon>\<close>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and F :: "'d \<Rightarrow> 'c"
and G :: "'c \<Rightarrow> 'd"
and \<eta> :: "'d \<Rightarrow> 'd"
and \<epsilon> :: "'c \<Rightarrow> 'c" +
assumes triangle_F: "\<epsilon>FoF\<eta>.map = F"
and triangle_G: "G\<epsilon>o\<eta>G.map = G"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
end
lemma unit_determines_counit:
assumes "unit_counit_adjunction C D F G \<eta> \<epsilon>"
and "unit_counit_adjunction C D F G \<eta> \<epsilon>'"
shows "\<epsilon> = \<epsilon>'"
proof -
(* IDEA: \<epsilon>' = \<epsilon>'FG o (FG\<epsilon> o F\<eta>G) = \<epsilon>'\<epsilon> o F\<eta>G = \<epsilon>FG o (\<epsilon>'FG o F\<eta>G) = \<epsilon> *)
interpret Adj: unit_counit_adjunction C D F G \<eta> \<epsilon> using assms(1) by auto
interpret Adj': unit_counit_adjunction C D F G \<eta> \<epsilon>' using assms(2) by auto
- interpret FGFG: composite_functor C D C G "F o G o F" ..
- interpret FG\<epsilon>: horizontal_composite C D C "G o F o G" G F F "G o \<epsilon>" F ..
- interpret \<epsilon>'FG: horizontal_composite C D C G G "F o G o F" F G "\<epsilon>' o F" ..
- interpret F\<eta>G: horizontal_composite C D C G G F "F o G o F" G "F o \<eta>" ..
- interpret \<epsilon>'\<epsilon>: natural_transformation C C "F o G o F o G" Adj.C.map "\<epsilon>' o \<epsilon>"
+ interpret FGFG: composite_functor C D C G \<open>F o G o F\<close> ..
+ interpret FG\<epsilon>: natural_transformation C C \<open>(F o G) o (F o G)\<close> \<open>F o G\<close> \<open>(F o G) o \<epsilon>\<close>
+ using Adj.\<epsilon>.natural_transformation_axioms Adj.FG.natural_transformation_axioms
+ horizontal_composite Adj.FG.functor_axioms
+ by fastforce
+ interpret F\<eta>G: natural_transformation C C \<open>F o G\<close> \<open>F o G o F o G\<close> \<open>F o \<eta> o G\<close>
+ using Adj.\<eta>.natural_transformation_axioms Adj.F\<eta>.natural_transformation_axioms
+ Adj.G.natural_transformation_axioms horizontal_composite
+ by blast
+ interpret \<epsilon>'\<epsilon>: natural_transformation C C \<open>F o G o F o G\<close> Adj.C.map \<open>\<epsilon>' o \<epsilon>\<close>
proof -
- interpret \<epsilon>'\<epsilon>: horizontal_composite C C C "F o G" Adj.C.map "F o G" Adj.C.map \<epsilon> \<epsilon>' ..
- have "Adj.C.map = Adj.C.map o Adj.C.map" using Adj.C.map_def by auto
- moreover have "F o G o F o G = (F o G) o (F o G)" by auto
- ultimately show "natural_transformation C C (F o G o F o G) Adj.C.map (\<epsilon>' o \<epsilon>)"
- using \<epsilon>'\<epsilon>.natural_transformation_axioms by simp
+ have "natural_transformation C C ((F o G) o (F o G)) Adj.C.map (\<epsilon>' o \<epsilon>)"
+ using Adj.\<epsilon>.natural_transformation_axioms Adj'.\<epsilon>.natural_transformation_axioms
+ horizontal_composite Adj.C.is_functor comp_functor_identity
+ by (metis (no_types, lifting))
+ thus "natural_transformation C C (F o G o F o G) Adj.C.map (\<epsilon>' o \<epsilon>)"
+ using o_assoc by metis
qed
interpret \<epsilon>'\<epsilon>oF\<eta>G: vertical_composite
- C C "F o G" "F o G o F o G" Adj.C.map "F o \<eta> o G" "\<epsilon>' o \<epsilon>" ..
+ C C \<open>F o G\<close> \<open>F o G o F o G\<close> Adj.C.map \<open>F o \<eta> o G\<close> \<open>\<epsilon>' o \<epsilon>\<close> ..
have "\<epsilon>' = vertical_composite.map C C (F o Adj.G\<epsilon>o\<eta>G.map) \<epsilon>'"
using vcomp_ide_dom [of C C "F o G" Adj.C.map \<epsilon>'] Adj.triangle_G
by (simp add: Adj'.\<epsilon>.natural_transformation_axioms)
also have "... = vertical_composite.map C C
(vertical_composite.map C C (F o \<eta> o G) (F o G o \<epsilon>)) \<epsilon>'"
- proof -
- have "F o (\<eta> o G) = F o \<eta> o G \<and> F o (G o \<epsilon>) = F o G o \<epsilon>" by auto
- thus ?thesis
- using hcomp_vcomp_functor [of D C F C G "G o F o G" "\<eta> o G" G "G o \<epsilon>"]
- by (simp add: Adj.F.functor_axioms Adj.G\<epsilon>o\<eta>G.\<sigma>.natural_transformation_axioms
- Adj.G\<epsilon>o\<eta>G.\<tau>.natural_transformation_axioms)
- qed
+ using whisker_left Adj.F.functor_axioms Adj.G\<epsilon>.natural_transformation_axioms
+ Adj.\<eta>G.natural_transformation_axioms o_assoc
+ by (metis (no_types, lifting))
also have "... = vertical_composite.map C C
(vertical_composite.map C C (F o \<eta> o G) (\<epsilon>' o F o G)) \<epsilon>"
proof -
have "vertical_composite.map C C
(vertical_composite.map C C (F o \<eta> o G) (F o G o \<epsilon>)) \<epsilon>'
= vertical_composite.map C C (F o \<eta> o G)
(vertical_composite.map C C (F o G o \<epsilon>) \<epsilon>')"
- proof -
- have "F \<circ> (G o F o G) = F o G o F o G \<and> F o (G o \<epsilon>) = F o G o \<epsilon>" by auto
- thus ?thesis
- using F\<eta>G.natural_transformation_axioms FG\<epsilon>.natural_transformation_axioms
- Adj'.\<epsilon>.natural_transformation_axioms vcomp_assoc comp_identity_functor
- comp_functor_identity
- by simp
- qed
+ using vcomp_assoc
+ by (metis (no_types, lifting) Adj'.\<epsilon>.natural_transformation_axioms
+ FG\<epsilon>.natural_transformation_axioms F\<eta>G.natural_transformation_axioms o_assoc)
also have "... = vertical_composite.map C C (F o \<eta> o G)
(vertical_composite.map C C (\<epsilon>' o F o G) \<epsilon>)"
proof -
have "\<epsilon>' \<circ> Adj.C.map = \<epsilon>'"
using Adj'.\<epsilon>.natural_transformation_axioms hcomp_ide_dom by simp
moreover have "Adj.C.map \<circ> \<epsilon> = \<epsilon>"
using Adj.\<epsilon>.natural_transformation_axioms hcomp_ide_cod by simp
moreover have "\<epsilon>' \<circ> (F o G) = \<epsilon>' o F \<circ> G" by auto
ultimately show ?thesis
using Adj'.\<epsilon>.natural_transformation_axioms Adj.\<epsilon>.natural_transformation_axioms
- interchange [of C C "F o G" Adj.C.map \<epsilon> C "F o G" Adj.C.map \<epsilon>']
+ interchange_spc [of C C "F o G" Adj.C.map \<epsilon> C "F o G" Adj.C.map \<epsilon>']
by simp
qed
also have "... = vertical_composite.map C C
(vertical_composite.map C C (F o \<eta> o G) (\<epsilon>' o F o G)) \<epsilon>"
- using vcomp_assoc Adj.\<epsilon>.natural_transformation_axioms
- F\<eta>G.natural_transformation_axioms \<epsilon>'FG.natural_transformation_axioms
- by simp
+ using vcomp_assoc
+ by (metis Adj'.\<epsilon>F.natural_transformation_axioms Adj.G.natural_transformation_axioms
+ Adj.\<epsilon>.natural_transformation_axioms F\<eta>G.natural_transformation_axioms
+ horizontal_composite)
finally show ?thesis by simp
qed
also have "... = vertical_composite.map C C
(vertical_composite.map D C (F o \<eta>) (\<epsilon>' o F) o G) \<epsilon>"
- using hcomp_functor_vcomp [of C D G C F "F o G o F" "F o \<eta>" F "\<epsilon>' o F"]
- Adj.F\<eta>.natural_transformation_axioms Adj'.\<epsilon>F.natural_transformation_axioms
- comp_functor_identity comp_identity_functor Adj.G.functor_axioms
- Adj'.\<epsilon>FoF\<eta>.\<tau>.natural_transformation_axioms Adj.\<epsilon>FoF\<eta>.\<sigma>.natural_transformation_axioms
- by simp
+ using whisker_right Adj'.\<epsilon>F.natural_transformation_axioms
+ Adj.F\<eta>.natural_transformation_axioms Adj.G.functor_axioms
+ by metis
also have "... = vertical_composite.map C C (F o G) \<epsilon>"
using Adj'.triangle_F by simp
also have "... = \<epsilon>"
using vcomp_ide_cod Adj.\<epsilon>.natural_transformation_axioms by simp
finally show ?thesis by simp
qed
lemma counit_determines_unit:
assumes "unit_counit_adjunction C D F G \<eta> \<epsilon>"
and "unit_counit_adjunction C D F G \<eta>' \<epsilon>"
shows "\<eta> = \<eta>'"
proof -
interpret Adj: unit_counit_adjunction C D F G \<eta> \<epsilon> using assms(1) by auto
interpret Adj': unit_counit_adjunction C D F G \<eta>' \<epsilon> using assms(2) by auto
- interpret GFGF: composite_functor D C D F "G o F o G" ..
- interpret GF\<eta>: horizontal_composite D C D F "F o G o F" G G "F o \<eta>" G ..
- interpret \<eta>'GF: horizontal_composite D C D F F G "G o F o G" F "\<eta>' o G" ..
- interpret G\<epsilon>F: horizontal_composite D C D F F "G o F o G" G F "G o \<epsilon>" ..
- interpret \<eta>'\<eta>: natural_transformation D D Adj.D.map "G o F o G o F" "\<eta>' o \<eta>"
+ interpret GFGF: composite_functor D C D F \<open>G o F o G\<close> ..
+ interpret GF\<eta>: natural_transformation D D \<open>G o F\<close> \<open>(G o F) o (G o F)\<close> \<open>(G o F) o \<eta>\<close>
+ using Adj.\<eta>.natural_transformation_axioms Adj.GF.functor_axioms
+ Adj.GF.natural_transformation_axioms comp_functor_identity horizontal_composite
+ by (metis (no_types, lifting))
+ interpret \<eta>'GF: natural_transformation D D \<open>G o F\<close> \<open>(G o F) o (G o F)\<close> \<open>\<eta>' o (G o F)\<close>
+ using Adj'.\<eta>.natural_transformation_axioms Adj.GF.functor_axioms
+ Adj.GF.natural_transformation_axioms comp_identity_functor horizontal_composite
+ by (metis (no_types, lifting))
+ interpret G\<epsilon>F: natural_transformation D D \<open>G o F o G o F\<close> \<open>G o F\<close> \<open>G o \<epsilon> o F\<close>
+ using Adj.\<epsilon>.natural_transformation_axioms Adj.F.natural_transformation_axioms
+ Adj.G\<epsilon>.natural_transformation_axioms horizontal_composite
+ by blast
+ interpret \<eta>'\<eta>: natural_transformation D D Adj.D.map \<open>G o F o G o F\<close> \<open>\<eta>' o \<eta>\<close>
proof -
- interpret \<eta>'\<eta>: horizontal_composite D D D Adj.D.map "G o F" Adj.D.map "G o F" \<eta> \<eta>' ..
- have "Adj.D.map = Adj.D.map o Adj.D.map" using Adj.D.map_def by auto
- moreover have "G o F o G o F = (G o F) o (G o F)" by auto
- ultimately show "natural_transformation D D Adj.D.map (G o F o G o F) (\<eta>' o \<eta>)"
- using \<eta>'\<eta>.natural_transformation_axioms by simp
+ have "natural_transformation D D Adj.D.map ((G o F) o (G o F)) (\<eta>' o \<eta>)"
+ using Adj.\<eta>.natural_transformation_axioms Adj'.\<eta>.natural_transformation_axioms
+ horizontal_composite Adj.D.natural_transformation_axioms hcomp_ide_cod
+ by (metis (no_types, lifting))
+ thus "natural_transformation D D Adj.D.map (G o F o G o F) (\<eta>' o \<eta>)"
+ using o_assoc by metis
qed
interpret G\<epsilon>Fo\<eta>'\<eta>: vertical_composite
- D D Adj.D.map "G o F o G o F" "G o F" "\<eta>' o \<eta>" "G o \<epsilon> o F" ..
+ D D Adj.D.map \<open>G o F o G o F\<close> \<open>G o F\<close> \<open>\<eta>' o \<eta>\<close> \<open>G o \<epsilon> o F\<close> ..
have "\<eta>' = vertical_composite.map D D \<eta>' (G o Adj.\<epsilon>FoF\<eta>.map)"
using vcomp_ide_cod [of D D Adj.D.map "G o F" \<eta>'] Adj.triangle_F
by (simp add: Adj'.\<eta>.natural_transformation_axioms)
also have "... = vertical_composite.map D D \<eta>'
(vertical_composite.map D D (G o (F o \<eta>)) (G o (\<epsilon> o F)))"
- using hcomp_vcomp_functor [of C D G D F "F o G o F" "F o \<eta>" F "\<epsilon> o F"]
- Adj.G.functor_axioms Adj.\<epsilon>FoF\<eta>.\<sigma>.natural_transformation_axioms
- Adj.\<epsilon>FoF\<eta>.\<tau>.natural_transformation_axioms
- by simp
+ using whisker_left Adj.F\<eta>.natural_transformation_axioms Adj.G.functor_axioms
+ Adj.\<epsilon>F.natural_transformation_axioms
+ by fastforce
also have "... = vertical_composite.map D D
(vertical_composite.map D D \<eta>' (G o (F o \<eta>))) (G o \<epsilon> o F)"
- proof -
- have "G o (F o G o F) = G o F o G o F \<and> G o (\<epsilon> o F) = G o \<epsilon> o F" by auto
- thus ?thesis
- using vcomp_assoc
- [of D D Adj.D.map "G o F" \<eta>' "G o F o G o F" "G o (F o \<eta>)" "G o F" "G o \<epsilon> o F"]
- Adj'.\<eta>.natural_transformation_axioms G\<epsilon>F.natural_transformation_axioms
- GF\<eta>.natural_transformation_axioms
- by simp
- qed
+ using vcomp_assoc Adj'.\<eta>.natural_transformation_axioms
+ GF\<eta>.natural_transformation_axioms G\<epsilon>F.natural_transformation_axioms o_assoc
+ by (metis (no_types, lifting))
also have "... = vertical_composite.map D D
(vertical_composite.map D D \<eta> (\<eta>' o G o F)) (G o \<epsilon> o F)"
proof -
have "\<eta>' \<circ> Adj.D.map = \<eta>'"
using Adj'.\<eta>.natural_transformation_axioms hcomp_ide_dom by simp
moreover have "\<eta>' o (G o F) = \<eta>' o G o F \<and> G o (F o \<eta>) = G o F o \<eta>" by auto
ultimately show ?thesis
- using interchange [of D D Adj.D.map "G o F" \<eta> D Adj.D.map "G o F" \<eta>']
+ using interchange_spc [of D D Adj.D.map "G o F" \<eta> D Adj.D.map "G o F" \<eta>']
Adj.\<eta>.natural_transformation_axioms Adj'.\<eta>.natural_transformation_axioms
by simp
qed
also have "... = vertical_composite.map D D \<eta>
(vertical_composite.map D D (\<eta>' o G o F) (G o \<epsilon> o F))"
- proof -
- have "G o (F o G o F) = G o F o G o F \<and> G o (F o \<eta>) = G o F o \<eta>" by auto
- thus ?thesis
- using vcomp_assoc
- [of D D Adj.D.map "G o F" \<eta> "G o F o G o F" "\<eta>' o G o F" "G o F" "G o \<epsilon> o F"]
- Adj.\<eta>.natural_transformation_axioms \<eta>'GF.natural_transformation_axioms
- G\<epsilon>F.natural_transformation_axioms
- by simp
- qed
+ using vcomp_assoc
+ by (metis (no_types, lifting) Adj.\<eta>.natural_transformation_axioms
+ G\<epsilon>F.natural_transformation_axioms \<eta>'GF.natural_transformation_axioms o_assoc)
also have "... = vertical_composite.map D D \<eta>
(vertical_composite.map C D (\<eta>' o G) (G o \<epsilon>) o F)"
- proof -
- have "G o (F o G) = G o F o G" by auto
- moreover have "G \<circ> Adj.C.map = G"
- using Functor.comp_functor_identity Adj.G.functor_axioms by simp
- ultimately show ?thesis
- using hcomp_functor_vcomp [of D C F D "Adj.D.map \<circ> G" "G o F o G" "\<eta>' o G"
- G "G o \<epsilon>"]
- Adj'.\<eta>G.natural_transformation_axioms Adj.G\<epsilon>.natural_transformation_axioms
- Adj.F.functor_axioms
- by simp
- qed
+ using whisker_right Adj'.\<eta>G.natural_transformation_axioms Adj.F.functor_axioms
+ Adj.G\<epsilon>.natural_transformation_axioms
+ by fastforce
also have "... = vertical_composite.map D D \<eta> (G o F)"
using Adj'.triangle_G by simp
also have "... = \<eta>"
using vcomp_ide_dom Adj.GF.functor_axioms Adj.\<eta>.natural_transformation_axioms by simp
finally show ?thesis by simp
qed
subsection "Adjunction"
text\<open>
The grand unification of everything to do with an adjunction.
\<close>
locale adjunction =
C: category C +
D: category D +
S: set_category S +
Cop: dual_category C +
Dop: dual_category D +
CopxC: product_category Cop.comp C +
DopxD: product_category Dop.comp D +
DopxC: product_category Dop.comp C +
idDop: identity_functor Dop.comp +
HomC: hom_functor C S \<phi>C +
HomD: hom_functor D S \<phi>D +
F: left_adjoint_functor D C F +
G: right_adjoint_functor C D G +
GF: composite_functor D C D F G +
FG: composite_functor C D C G F +
FGF: composite_functor D C C F FG.map +
GFG: composite_functor C D D G GF.map +
Fop: dual_functor Dop.comp Cop.comp F +
FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
\<eta>: natural_transformation D D D.map GF.map \<eta> +
\<epsilon>: natural_transformation C C FG.map C.map \<epsilon> +
- F\<eta>: horizontal_composite D D C D.map "G o F" F F \<eta> F +
- \<eta>G: horizontal_composite C D D G G D.map "G o F" G \<eta> +
- \<epsilon>F: horizontal_composite D C C F F "F o G" C.map F \<epsilon> +
- G\<epsilon>: horizontal_composite C C D "F o G" C.map G G \<epsilon> G +
- \<epsilon>FoF\<eta>: vertical_composite D C F FGF.map F F\<eta>.map \<epsilon>F.map +
- G\<epsilon>o\<eta>G: vertical_composite C D G GFG.map G \<eta>G.map G\<epsilon>.map +
+ F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>\<close> +
+ \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta> o G\<close> +
+ \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close> +
+ G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>\<close> +
+ \<epsilon>FoF\<eta>: vertical_composite D C F FGF.map F \<open>F o \<eta>\<close> \<open>\<epsilon> o F\<close> +
+ G\<epsilon>o\<eta>G: vertical_composite C D G GFG.map G \<open>\<eta> o G\<close> \<open>G o \<epsilon>\<close> +
\<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi> +
\<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon> +
\<Phi>\<Psi>: hom_adjunction C D S \<phi>C \<phi>D F G \<Phi> \<Psi>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi>C :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and \<phi>D :: "'d * 'd \<Rightarrow> 'd \<Rightarrow> 's"
and F :: "'d \<Rightarrow> 'c"
and G :: "'c \<Rightarrow> 'd"
and \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
and \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
and \<eta> :: "'d \<Rightarrow> 'd"
and \<epsilon> :: "'c \<Rightarrow> 'c"
and \<Phi> :: "'d * 'c \<Rightarrow> 's"
and \<Psi> :: "'d * 'c \<Rightarrow> 's" +
assumes \<phi>_in_terms_of_\<eta>: "\<lbrakk> D.ide y; \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<rbrakk> \<Longrightarrow> \<phi> y f = G f \<cdot>\<^sub>D \<eta> y"
and \<psi>_in_terms_of_\<epsilon>: "\<lbrakk> C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<rbrakk> \<Longrightarrow> \<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g"
and \<eta>_in_terms_of_\<phi>: "D.ide y \<Longrightarrow> \<eta> y = \<phi> y (F y)"
and \<epsilon>_in_terms_of_\<psi>: "C.ide x \<Longrightarrow> \<epsilon> x = \<psi> x (G x)"
and \<phi>_in_terms_of_\<Phi>: "\<lbrakk> D.ide y; \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<rbrakk> \<Longrightarrow>
\<phi> y f = (\<Phi>\<Psi>.\<psi>D (y, G x) o S.Fun (\<Phi> (y, x)) o \<phi>C (F y, x)) f"
and \<psi>_in_terms_of_\<Psi>: "\<lbrakk> C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<rbrakk> \<Longrightarrow>
\<psi> x g = (\<Phi>\<Psi>.\<psi>C (F y, x) o S.Fun (\<Psi> (y, x)) o \<phi>D (y, G x)) g"
and \<Phi>_in_terms_of_\<phi>:
"\<lbrakk> C.ide x; D.ide y \<rbrakk> \<Longrightarrow>
\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<Phi>\<Psi>.\<psi>C (F y, x))"
and \<Psi>_in_terms_of_\<psi>:
"\<lbrakk> C.ide x; D.ide y \<rbrakk> \<Longrightarrow>
\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<Phi>\<Psi>.\<psi>D (y, G x))"
section "Meta-Adjunctions Induce Unit/Counit Adjunctions"
context meta_adjunction
begin
interpretation GF: composite_functor D C D F G ..
interpretation FG: composite_functor C D C G F ..
interpretation FGF: composite_functor D C C F FG.map ..
interpretation GFG: composite_functor C D D G GF.map ..
definition \<eta>o :: "'d \<Rightarrow> 'd"
where "\<eta>o y = \<phi> y (F y)"
lemma \<eta>o_in_hom:
assumes "D.ide y"
shows "\<guillemotleft>\<eta>o y : y \<rightarrow>\<^sub>D G (F y)\<guillemotright>"
using assms D.ide_in_hom \<eta>o_def \<phi>_in_hom by force
lemma \<phi>_in_terms_of_\<eta>o:
assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<phi> y f = G f \<cdot>\<^sub>D \<eta>o y"
proof (unfold \<eta>o_def)
have 1: "\<guillemotleft>F y : F y \<rightarrow>\<^sub>C F y\<guillemotright>"
using assms(1) D.ide_in_hom by blast
hence "\<phi> y (F y) = \<phi> y (F y) \<cdot>\<^sub>D y"
by (metis assms(1) D.in_homE \<phi>_in_hom D.comp_arr_dom)
thus "\<phi> y f = G f \<cdot>\<^sub>D \<phi> y (F y)"
using assms 1 D.ide_in_hom by (metis C.comp_arr_dom C.in_homE \<phi>_naturality)
qed
lemma \<phi>_F_char:
assumes "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>"
shows "\<phi> y' (F g) = \<eta>o y \<cdot>\<^sub>D g"
using assms \<eta>o_def \<phi>_in_hom [of y "F y" "F y"]
D.comp_cod_arr [of "D (\<phi> y (F y)) g" "G (F y)"]
\<phi>_naturality [of "F y" "F y" "F y" g y' y "F y"]
by fastforce
interpretation \<eta>: transformation_by_components D D D.map GF.map \<eta>o
proof
show "\<And>a. D.ide a \<Longrightarrow> \<guillemotleft>\<eta>o a : D.map a \<rightarrow>\<^sub>D GF.map a\<guillemotright>"
using \<eta>o_def \<phi>_in_hom D.ide_in_hom by force
fix f
assume f: "D.arr f"
show "\<eta>o (D.cod f) \<cdot>\<^sub>D D.map f = GF.map f \<cdot>\<^sub>D \<eta>o (D.dom f)"
using f \<phi>_F_char [of "D.map f" "D.dom f" "D.cod f"]
\<phi>_in_terms_of_\<eta>o [of "D.dom f" "F f" "F (D.cod f)"]
by force
qed
lemma \<eta>_map_simp:
assumes "D.ide y"
shows "\<eta>.map y = \<phi> y (F y)"
using assms \<eta>.map_simp_ide \<eta>o_def by simp
definition \<epsilon>o :: "'c \<Rightarrow> 'c"
where "\<epsilon>o x = \<psi> x (G x)"
lemma \<epsilon>o_in_hom:
assumes "C.ide x"
shows "\<guillemotleft>\<epsilon>o x : F (G x) \<rightarrow>\<^sub>C x\<guillemotright>"
using assms C.ide_in_hom \<epsilon>o_def \<psi>_in_hom by force
lemma \<psi>_in_terms_of_\<epsilon>o:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<psi> x g = \<epsilon>o x \<cdot>\<^sub>C F g"
proof -
have "\<epsilon>o x \<cdot>\<^sub>C F g = x \<cdot>\<^sub>C \<psi> x (G x) \<cdot>\<^sub>C F g"
using assms \<epsilon>o_def \<psi>_in_hom [of x "G x" "G x"]
C.comp_cod_arr [of "\<psi> x (G x) \<cdot>\<^sub>C F g" x]
by fastforce
also have "... = \<psi> x (G x \<cdot>\<^sub>D G x \<cdot>\<^sub>D g)"
using assms \<psi>_naturality [of x x x g y "G x" "G x"] by force
also have "... = \<psi> x g"
using assms D.comp_cod_arr by fastforce
finally show ?thesis by simp
qed
lemma \<psi>_G_char:
assumes "\<guillemotleft>f: x \<rightarrow>\<^sub>C x'\<guillemotright>"
shows "\<psi> x' (G f) = f \<cdot>\<^sub>C \<epsilon>o x"
proof (unfold \<epsilon>o_def)
have 0: "C.ide x \<and> C.ide x'" using assms by auto
thus "\<psi> x' (G f) = f \<cdot>\<^sub>C \<psi> x (G x)"
using 0 assms \<psi>_naturality \<psi>_in_hom [of x "G x" "G x"] G.preserves_hom \<epsilon>o_def
\<psi>_in_terms_of_\<epsilon>o G.is_natural_1 C.ide_in_hom
by (metis C.arrI C.in_homE)
qed
interpretation \<epsilon>: transformation_by_components C C FG.map C.map \<epsilon>o
apply unfold_locales
using \<epsilon>o_in_hom
apply simp
using \<psi>_G_char \<psi>_in_terms_of_\<epsilon>o
by (metis C.arr_iff_in_hom C.ide_cod C.map_simp G.preserves_hom comp_apply)
lemma \<epsilon>_map_simp:
assumes "C.ide x"
shows "\<epsilon>.map x = \<psi> x (G x)"
using assms \<epsilon>o_def by simp
interpretation FD: composite_functor D D C D.map F ..
interpretation CF: composite_functor D C C F C.map ..
interpretation GC: composite_functor C C D C.map G ..
interpretation DG: composite_functor C D D G D.map ..
- interpretation F\<eta>: horizontal_composite D D C D.map "G o F" F F \<eta>.map F ..
- interpretation F\<eta>: natural_transformation D C F "F o G o F" "F o \<eta>.map"
- apply unfold_locales using F\<eta>.is_extensional F\<eta>.is_natural_1 F\<eta>.is_natural_2 by auto
-
- interpretation \<epsilon>F: horizontal_composite D C C F F "F o G" C.map F \<epsilon>.map ..
- interpretation \<epsilon>F: natural_transformation D C "F o G o F" F "\<epsilon>.map o F"
- apply unfold_locales using \<epsilon>F.is_extensional \<epsilon>F.is_natural_1 \<epsilon>F.is_natural_2 by auto
+ interpretation F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>.map\<close>
+ proof -
+ have "natural_transformation D C F (F o (G o F)) (F o \<eta>.map)"
+ using \<eta>.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ thus "natural_transformation D C F (F o G o F) (F o \<eta>.map)"
+ using o_assoc by metis
+ qed
- interpretation \<eta>G: horizontal_composite C D D G G D.map "G o F" G \<eta>.map ..
- interpretation \<eta>G: natural_transformation C D G "G o F o G" "\<eta>.map o G"
- apply unfold_locales using \<eta>G.is_extensional \<eta>G.is_natural_1 \<eta>G.is_natural_2 by auto
+ interpretation \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon>.map o F\<close>
+ using \<epsilon>.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
- interpretation G\<epsilon>: horizontal_composite C C D "F o G" C.map G G \<epsilon>.map G ..
- interpretation G\<epsilon>: natural_transformation C D "G o F o G" G "G o \<epsilon>.map"
- apply unfold_locales using G\<epsilon>.is_extensional G\<epsilon>.is_natural_1 G\<epsilon>.is_natural_2 by auto
+ interpretation \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta>.map o G\<close>
+ using \<eta>.natural_transformation_axioms G.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
- interpretation \<epsilon>FoF\<eta>: vertical_composite D C F "F o G o F" F "F o \<eta>.map" "\<epsilon>.map o F" ..
- interpretation G\<epsilon>o\<eta>G: vertical_composite C D G "G o F o G" G "\<eta>.map o G" "G o \<epsilon>.map" ..
+ interpretation G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>.map\<close>
+ proof -
+ have "natural_transformation C D (G o (F o G)) G (G o \<epsilon>.map)"
+ using \<epsilon>.natural_transformation_axioms G.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ thus "natural_transformation C D (G o F o G) G (G o \<epsilon>.map)"
+ using o_assoc by metis
+ qed
+
+ interpretation \<epsilon>FoF\<eta>: vertical_composite D C F \<open>F o G o F\<close> F \<open>F o \<eta>.map\<close> \<open>\<epsilon>.map o F\<close> ..
+ interpretation G\<epsilon>o\<eta>G: vertical_composite C D G \<open>G o F o G\<close> G \<open>\<eta>.map o G\<close> \<open>G o \<epsilon>.map\<close> ..
lemma unit_counit_F:
assumes "D.ide y"
shows "F y = \<epsilon>o (F y) \<cdot>\<^sub>C F (\<eta>o y)"
using assms \<psi>_in_terms_of_\<epsilon>o \<eta>o_def \<psi>_\<phi> \<eta>o_in_hom F.preserves_ide C.ide_in_hom by metis
lemma unit_counit_G:
assumes "C.ide x"
shows "G x = G (\<epsilon>o x) \<cdot>\<^sub>D \<eta>o (G x)"
using assms \<phi>_in_terms_of_\<eta>o \<epsilon>o_def \<phi>_\<psi> \<epsilon>o_in_hom G.preserves_ide D.ide_in_hom by metis
theorem induces_unit_counit_adjunction:
shows "unit_counit_adjunction C D F G \<eta>.map \<epsilon>.map"
proof
show "\<epsilon>FoF\<eta>.map = F"
- proof (intro NaturalTransformation.eqI)
- show "natural_transformation D C F F \<epsilon>FoF\<eta>.map"
- using \<epsilon>FoF\<eta>.is_natural_transformation by auto
- show "natural_transformation D C F F F" ..
- show "\<And>y. D.ide y \<Longrightarrow> \<epsilon>FoF\<eta>.map y = F y"
- using \<epsilon>FoF\<eta>.map_simp_ide unit_counit_F by auto
- qed
+ using \<epsilon>FoF\<eta>.is_natural_transformation \<epsilon>FoF\<eta>.map_simp_ide unit_counit_F
+ F.natural_transformation_axioms
+ by (intro NaturalTransformation.eqI, auto)
show "G\<epsilon>o\<eta>G.map = G"
- proof (intro NaturalTransformation.eqI)
- show "natural_transformation C D G G G\<epsilon>o\<eta>G.map"
- using G\<epsilon>o\<eta>G.is_natural_transformation by auto
- show "natural_transformation C D G G G" ..
- show "\<And>x. C.ide x \<Longrightarrow> G\<epsilon>o\<eta>G.map x = G x"
- using G\<epsilon>o\<eta>G.map_simp_ide unit_counit_G by auto
- qed
+ using G\<epsilon>o\<eta>G.is_natural_transformation G\<epsilon>o\<eta>G.map_simp_ide unit_counit_G
+ G.natural_transformation_axioms
+ by (intro NaturalTransformation.eqI, auto)
qed
text\<open>
From the defined @{term \<eta>} and @{term \<epsilon>} we can recover the original @{term \<phi>} and @{term \<psi>}.
\<close>
lemma \<phi>_in_terms_of_\<eta>:
assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<phi> y f = G f \<cdot>\<^sub>D \<eta>.map y"
using assms by (simp add: \<phi>_in_terms_of_\<eta>o)
lemma \<psi>_in_terms_of_\<epsilon>:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<psi> x g = \<epsilon>.map x \<cdot>\<^sub>C F g"
using assms by (simp add: \<psi>_in_terms_of_\<epsilon>o)
- abbreviation \<eta> :: "'d \<Rightarrow> 'd" where "\<eta> \<equiv> \<eta>.map"
- abbreviation \<epsilon> :: "'c \<Rightarrow> 'c" where "\<epsilon> \<equiv> \<epsilon>.map"
+ definition \<eta> :: "'d \<Rightarrow> 'd" where "\<eta> \<equiv> \<eta>.map"
+ definition \<epsilon> :: "'c \<Rightarrow> 'c" where "\<epsilon> \<equiv> \<epsilon>.map"
lemma \<eta>_is_natural_transformation:
- shows "natural_transformation D D D.map GF.map \<eta>" ..
+ shows "natural_transformation D D D.map GF.map \<eta>"
+ unfolding \<eta>_def ..
lemma \<epsilon>_is_natural_transformation:
- shows "natural_transformation C C FG.map C.map \<epsilon>" ..
+ shows "natural_transformation C C FG.map C.map \<epsilon>"
+ unfolding \<epsilon>_def ..
end
section "Meta-Adjunctions Induce Left and Right Adjoint Functors"
context meta_adjunction
begin
interpretation unit_counit_adjunction C D F G \<eta> \<epsilon>
- using induces_unit_counit_adjunction by auto
+ using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
lemma has_terminal_arrows_from_functor:
assumes x: "C.ide x"
shows "terminal_arrow_from_functor D C F (G x) x (\<epsilon> x)"
and "\<And>y' f. arrow_from_functor D C F y' x f
\<Longrightarrow> terminal_arrow_from_functor.the_coext D C F (G x) (\<epsilon> x) y' f = \<phi> y' f"
proof -
- interpret \<epsilon>x: arrow_from_functor D C F "G x" x "\<epsilon> x"
+ interpret \<epsilon>x: arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon> x\<close>
apply unfold_locales
using x \<epsilon>.preserves_hom G.preserves_ide by auto
have 1: "\<And>y' f. arrow_from_functor D C F y' x f \<Longrightarrow>
\<epsilon>x.is_coext y' f (\<phi> y' f) \<and> (\<forall>g'. \<epsilon>x.is_coext y' f g' \<longrightarrow> g' = \<phi> y' f)"
proof
fix y' :: 'd and f :: 'c
assume f: "arrow_from_functor D C F y' x f"
show "\<epsilon>x.is_coext y' f (\<phi> y' f)"
- using f x \<phi>_in_hom \<psi>_\<phi> \<psi>_in_terms_of_\<epsilon> \<epsilon>x.is_coext_def arrow_from_functor.arrow
+ using f x \<epsilon>_def \<phi>_in_hom \<psi>_\<phi> \<psi>_in_terms_of_\<epsilon> \<epsilon>x.is_coext_def arrow_from_functor.arrow
by metis
show "\<forall>g'. \<epsilon>x.is_coext y' f g' \<longrightarrow> g' = \<phi> y' f"
- using \<epsilon>o_def \<psi>_in_terms_of_\<epsilon>o x \<epsilon>_map_simp \<phi>_\<psi> \<epsilon>x.is_coext_def by simp
+ using \<epsilon>o_def \<psi>_in_terms_of_\<epsilon>o x \<epsilon>_map_simp \<phi>_\<psi> \<epsilon>x.is_coext_def \<epsilon>_def by simp
qed
- interpret \<epsilon>x: terminal_arrow_from_functor D C F "G x" x "\<epsilon> x"
+ interpret \<epsilon>x: terminal_arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon> x\<close>
apply unfold_locales using 1 by blast
show "terminal_arrow_from_functor D C F (G x) x (\<epsilon> x)" ..
show "\<And>y' f. arrow_from_functor D C F y' x f \<Longrightarrow> \<epsilon>x.the_coext y' f = \<phi> y' f"
using 1 \<epsilon>x.the_coext_def by auto
qed
lemma has_left_adjoint_functor:
shows "left_adjoint_functor D C F"
apply unfold_locales using has_terminal_arrows_from_functor by auto
end
context meta_adjunction
begin
interpretation unit_counit_adjunction C D F G \<eta> \<epsilon>
- using induces_unit_counit_adjunction by auto
+ using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
lemma has_initial_arrows_to_functor:
assumes y: "D.ide y"
shows "initial_arrow_to_functor C D G y (F y) (\<eta> y)"
and "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow>
initial_arrow_to_functor.the_ext C D G (F y) (\<eta> y) x' g = \<psi> x' g"
proof -
- interpret \<eta>y: arrow_to_functor C D G y "F y" "\<eta> y"
+ interpret \<eta>y: arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta> y\<close>
apply unfold_locales using y by auto
have 1: "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow>
\<eta>y.is_ext x' g (\<psi> x' g) \<and> (\<forall>f'. \<eta>y.is_ext x' g f' \<longrightarrow> f' = \<psi> x' g)"
proof
fix x' :: 'c and g :: 'd
assume g: "arrow_to_functor C D G y x' g"
show "\<eta>y.is_ext x' g (\<psi> x' g)"
- using g y \<psi>_in_hom \<phi>_\<psi> \<phi>_in_terms_of_\<eta> \<eta>y.is_ext_def arrow_to_functor.arrow
+ using g y \<psi>_in_hom \<phi>_\<psi> \<phi>_in_terms_of_\<eta> \<eta>y.is_ext_def arrow_to_functor.arrow \<eta>_def
by metis
show "\<forall>f'. \<eta>y.is_ext x' g f' \<longrightarrow> f' = \<psi> x' g"
- using y \<eta>o_def \<phi>_in_terms_of_\<eta>o \<eta>_map_simp \<psi>_\<phi> \<eta>y.is_ext_def by simp
+ using y \<eta>o_def \<phi>_in_terms_of_\<eta>o \<eta>_map_simp \<psi>_\<phi> \<eta>y.is_ext_def \<eta>_def by simp
qed
- interpret \<eta>y: initial_arrow_to_functor C D G y "F y" "\<eta> y"
+ interpret \<eta>y: initial_arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta> y\<close>
apply unfold_locales using 1 by blast
show "initial_arrow_to_functor C D G y (F y) (\<eta> y)" ..
show "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow> \<eta>y.the_ext x' g = \<psi> x' g"
using 1 \<eta>y.the_ext_def by auto
qed
lemma has_right_adjoint_functor:
shows "right_adjoint_functor C D G"
apply unfold_locales using has_initial_arrows_to_functor by auto
end
section "Unit/Counit Adjunctions Induce Meta-Adjunctions"
context unit_counit_adjunction
begin
definition \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
where "\<phi> y h = G h \<cdot>\<^sub>D \<eta> y"
definition \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
where "\<psi> x h = \<epsilon> x \<cdot>\<^sub>C F h"
interpretation meta_adjunction C D F G \<phi> \<psi>
proof
fix x :: 'c and y :: 'd and f :: 'c
assume y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
show 0: "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
using f y G.preserves_hom \<eta>.preserves_hom \<phi>_def D.ide_in_hom
by (metis D.comp_in_homI D.in_homE comp_apply D.map_simp)
show "\<psi> x (\<phi> y f) = f"
proof -
have "\<psi> x (\<phi> y f) = (\<epsilon> x \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (\<eta> y)"
using y f \<phi>_def \<psi>_def C.comp_assoc by auto
also have "... = (f \<cdot>\<^sub>C \<epsilon> (F y)) \<cdot>\<^sub>C F (\<eta> y)"
using y f \<epsilon>.naturality by auto
also have "... = f"
using y f \<epsilon>FoF\<eta>.map_simp_2 triangle_F C.comp_arr_dom D.ide_in_hom C.comp_assoc
by fastforce
finally show ?thesis by auto
qed
next
fix x :: 'c and y :: 'd and g :: 'd
assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
show "\<guillemotleft>\<psi> x g : F y \<rightarrow>\<^sub>C x\<guillemotright>" using g x \<psi>_def by fastforce
show "\<phi> y (\<psi> x g) = g"
proof -
have "\<phi> y (\<psi> x g) = (G (\<epsilon> x) \<cdot>\<^sub>D \<eta> (G x)) \<cdot>\<^sub>D g"
using g x \<phi>_def \<psi>_def \<eta>.naturality [of g] D.comp_assoc by auto
also have "... = g"
using x g triangle_G D.comp_ide_arr G\<epsilon>o\<eta>G.map_simp_ide by auto
finally show ?thesis by auto
qed
next
fix f :: 'c and g :: 'd and h :: 'c and x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
show "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
using \<phi>_def f g h \<eta>.naturality D.comp_assoc by fastforce
qed
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G \<phi> \<psi>" ..
text\<open>
From the defined @{term \<phi>} and @{term \<psi>} we can recover the original @{term \<eta>} and @{term \<epsilon>}.
\<close>
lemma \<eta>_in_terms_of_\<phi>:
assumes "D.ide y"
shows "\<eta> y = \<phi> y (F y)"
using assms \<phi>_def D.comp_cod_arr by auto
lemma \<epsilon>_in_terms_of_\<psi>:
assumes "C.ide x"
shows "\<epsilon> x = \<psi> x (G x)"
using assms \<psi>_def C.comp_arr_dom by auto
end
section "Left and Right Adjoint Functors Induce Meta-Adjunctions"
text\<open>
A left adjoint functor induces a meta-adjunction, modulo the choice of a
right adjoint and counit.
\<close>
context left_adjoint_functor
begin
definition Go :: "'c \<Rightarrow> 'd"
where "Go a = (SOME b. \<exists>e. terminal_arrow_from_functor D C F b a e)"
definition \<epsilon>o :: "'c \<Rightarrow> 'c"
where "\<epsilon>o a = (SOME e. terminal_arrow_from_functor D C F (Go a) a e)"
lemma Go_\<epsilon>o_terminal:
assumes "\<exists>b e. terminal_arrow_from_functor D C F b a e"
shows "terminal_arrow_from_functor D C F (Go a) a (\<epsilon>o a)"
using assms Go_def \<epsilon>o_def
someI_ex [of "\<lambda>b. \<exists>e. terminal_arrow_from_functor D C F b a e"]
someI_ex [of "\<lambda>e. terminal_arrow_from_functor D C F (Go a) a e"]
by simp
text\<open>
The right adjoint @{term G} to @{term F} takes each arrow @{term f} of
@{term[source=true] C} to the unique @{term[source=true] D}-coextension of
@{term "C f (\<epsilon>o (C.dom f))"} along @{term "\<epsilon>o (C.cod f)"}.
\<close>
definition G :: "'c \<Rightarrow> 'd"
where "G f = (if C.arr f then
terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (\<epsilon>o (C.cod f))
(Go (C.dom f)) (f \<cdot>\<^sub>C \<epsilon>o (C.dom f))
else D.null)"
lemma G_ide:
assumes "C.ide x"
shows "G x = Go x"
proof -
- interpret terminal_arrow_from_functor D C F "Go x" x "\<epsilon>o x"
+ interpret terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
using assms ex_terminal_arrow Go_\<epsilon>o_terminal by blast
have 1: "arrow_from_functor D C F (Go x) x (\<epsilon>o x)" ..
have "is_coext (Go x) (\<epsilon>o x) (Go x)"
using arrow is_coext_def C.in_homE C.comp_arr_dom by auto
hence "Go x = the_coext (Go x) (\<epsilon>o x)" using 1 the_coext_unique by blast
moreover have "\<epsilon>o x = C x (\<epsilon>o (C.dom x))"
using assms arrow C.comp_ide_arr C.seqI' C.ide_in_hom C.in_homE by metis
ultimately show ?thesis using assms G_def C.cod_dom C.ide_in_hom C.in_homE by metis
qed
lemma G_is_functor:
shows "functor C D G"
proof
fix f :: 'c
assume "\<not>C.arr f"
thus "G f = D.null" using G_def by auto
next
fix f :: 'c
assume f: "C.arr f"
let ?x = "C.dom f"
let ?x' = "C.cod f"
- interpret x\<epsilon>: terminal_arrow_from_functor D C F "Go ?x" "?x" "\<epsilon>o ?x"
+ interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> \<open>?x\<close> \<open>\<epsilon>o ?x\<close>
using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
- interpret x'\<epsilon>: terminal_arrow_from_functor D C F "Go ?x'" "?x'" "\<epsilon>o ?x'"
+ interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> \<open>?x'\<close> \<open>\<epsilon>o ?x'\<close>
using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (\<epsilon>o ?x))"
using f x\<epsilon>.arrow by (unfold_locales, auto)
have "G f = x'\<epsilon>.the_coext (Go ?x) (C f (\<epsilon>o ?x))" using f G_def by simp
hence Gf: "\<guillemotleft>G f : Go ?x \<rightarrow>\<^sub>D Go ?x'\<guillemotright> \<and> f \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x' \<cdot>\<^sub>C F (G f)"
using 1 x'\<epsilon>.the_coext_prop by simp
show "D.arr (G f)" using Gf by auto
show "D.dom (G f) = G ?x" using f Gf G_ide by auto
show "D.cod (G f) = G ?x'" using f Gf G_ide by auto
next
fix f f' :: 'c
assume ff': "C.arr (C f' f)"
have f: "C.arr f" using ff' by auto
let ?x = "C.dom f"
let ?x' = "C.cod f"
let ?x'' = "C.cod f'"
- interpret x\<epsilon>: terminal_arrow_from_functor D C F "Go ?x" "?x" "\<epsilon>o ?x"
+ interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> \<open>?x\<close> \<open>\<epsilon>o ?x\<close>
using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
- interpret x'\<epsilon>: terminal_arrow_from_functor D C F "Go ?x'" "?x'" "\<epsilon>o ?x'"
+ interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> \<open>?x'\<close> \<open>\<epsilon>o ?x'\<close>
using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
- interpret x''\<epsilon>: terminal_arrow_from_functor D C F "Go ?x''" "?x''" "\<epsilon>o ?x''"
+ interpret x''\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x''\<close> \<open>?x''\<close> \<open>\<epsilon>o ?x''\<close>
using ff' ex_terminal_arrow Go_\<epsilon>o_terminal by auto
have 1: "arrow_from_functor D C F (Go ?x) ?x' (f \<cdot>\<^sub>C \<epsilon>o ?x)"
using f x\<epsilon>.arrow by (unfold_locales, auto)
have 2: "arrow_from_functor D C F (Go ?x') ?x'' (f' \<cdot>\<^sub>C \<epsilon>o ?x')"
using ff' x'\<epsilon>.arrow by (unfold_locales, auto)
have "G f = x'\<epsilon>.the_coext (Go ?x) (C f (\<epsilon>o ?x))"
using f G_def by simp
hence Gf: "D.in_hom (G f) (Go ?x) (Go ?x') \<and> f \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x' \<cdot>\<^sub>C F (G f)"
using 1 x'\<epsilon>.the_coext_prop by simp
have "G f' = x''\<epsilon>.the_coext (Go ?x') (f' \<cdot>\<^sub>C \<epsilon>o ?x')"
using ff' G_def by auto
hence Gf': "\<guillemotleft>G f' : Go (C.cod f) \<rightarrow>\<^sub>D Go (C.cod f')\<guillemotright> \<and> f' \<cdot>\<^sub>C \<epsilon>o ?x' = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f')"
using 2 x''\<epsilon>.the_coext_prop by simp
show "G (f' \<cdot>\<^sub>C f) = G f' \<cdot>\<^sub>D G f"
proof -
have "x''\<epsilon>.is_coext (Go ?x) ((f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x) (G f' \<cdot>\<^sub>D G f)"
proof -
have "\<guillemotleft>G f' \<cdot>\<^sub>D G f : Go (C.dom f) \<rightarrow>\<^sub>D Go (C.cod f')\<guillemotright>" using 1 2 Gf Gf' by auto
moreover have "(f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f' \<cdot>\<^sub>D G f)"
proof -
have "(f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x = f' \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon>o ?x"
using C.comp_assoc by force
also have "... = (f' \<cdot>\<^sub>C \<epsilon>o ?x') \<cdot>\<^sub>C F (G f)"
using Gf C.comp_assoc by fastforce
also have "... = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f' \<cdot>\<^sub>D G f)"
using Gf Gf' C.comp_assoc by fastforce
finally show ?thesis by auto
qed
ultimately show ?thesis using x''\<epsilon>.is_coext_def by auto
qed
moreover have "arrow_from_functor D C F (Go ?x) ?x'' ((f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x)"
using ff' x\<epsilon>.arrow by (unfold_locales, blast)
ultimately show ?thesis
using ff' G_def x''\<epsilon>.the_coext_unique C.seqE C.cod_comp C.dom_comp by auto
qed
qed
interpretation G: "functor" C D G using G_is_functor by auto
lemma G_simp:
assumes "C.arr f"
shows "G f = terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (\<epsilon>o (C.cod f))
(Go (C.dom f)) (f \<cdot>\<^sub>C \<epsilon>o (C.dom f))"
using assms G_def by simp
interpretation idC: identity_functor C ..
interpretation GF: composite_functor C D C G F ..
interpretation \<epsilon>: transformation_by_components C C GF.map C.map \<epsilon>o
proof
fix x :: 'c
assume x: "C.ide x"
show "\<guillemotleft>\<epsilon>o x : GF.map x \<rightarrow>\<^sub>C C.map x\<guillemotright>"
proof -
- interpret terminal_arrow_from_functor D C F "Go x" x "\<epsilon>o x"
+ interpret terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
using x Go_\<epsilon>o_terminal ex_terminal_arrow by simp
show ?thesis using x G_ide arrow by auto
qed
next
fix f :: 'c
assume f: "C.arr f"
show "\<epsilon>o (C.cod f) \<cdot>\<^sub>C GF.map f = C.map f \<cdot>\<^sub>C \<epsilon>o (C.dom f)"
proof -
let ?x = "C.dom f"
let ?x' = "C.cod f"
- interpret x\<epsilon>: terminal_arrow_from_functor D C F "Go ?x" ?x "\<epsilon>o ?x"
+ interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> ?x \<open>\<epsilon>o ?x\<close>
using f Go_\<epsilon>o_terminal ex_terminal_arrow by simp
- interpret x'\<epsilon>: terminal_arrow_from_functor D C F "Go ?x'" ?x' "\<epsilon>o ?x'"
+ interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> ?x' \<open>\<epsilon>o ?x'\<close>
using f Go_\<epsilon>o_terminal ex_terminal_arrow by simp
have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (\<epsilon>o ?x))"
using f x\<epsilon>.arrow by (unfold_locales, auto)
have "G f = x'\<epsilon>.the_coext (Go ?x) (f \<cdot>\<^sub>C \<epsilon>o ?x)"
using f G_simp by blast
hence "x'\<epsilon>.is_coext (Go ?x) (f \<cdot>\<^sub>C \<epsilon>o ?x) (G f)"
using 1 x'\<epsilon>.the_coext_prop x'\<epsilon>.is_coext_def by auto
thus ?thesis
using f x'\<epsilon>.is_coext_def by simp
qed
qed
definition \<psi>
where "\<psi> x h = C (\<epsilon>.map x) (F h)"
lemma \<psi>_in_hom:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<guillemotleft>\<psi> x g : F y \<rightarrow>\<^sub>C x\<guillemotright>"
unfolding \<psi>_def using assms \<epsilon>.maps_ide_in_hom by auto
lemma \<psi>_natural:
assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = \<psi> x' ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
proof -
have "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = f \<cdot>\<^sub>C (\<epsilon>.map x \<cdot>\<^sub>C F h) \<cdot>\<^sub>C F g"
unfolding \<psi>_def by auto
also have "... = (f \<cdot>\<^sub>C \<epsilon>.map x) \<cdot>\<^sub>C F h \<cdot>\<^sub>C F g"
using C.comp_assoc by fastforce
also have "... = (f \<cdot>\<^sub>C \<epsilon>.map x) \<cdot>\<^sub>C F (h \<cdot>\<^sub>D g)"
using g h by fastforce
also have "... = (\<epsilon>.map x' \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (h \<cdot>\<^sub>D g)"
using f \<epsilon>.naturality by auto
also have "... = \<epsilon>.map x' \<cdot>\<^sub>C F ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
using f g h C.comp_assoc by fastforce
also have "... = \<psi> x' ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
unfolding \<psi>_def by auto
finally show ?thesis by auto
qed
lemma \<psi>_inverts_coext:
assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "arrow_from_functor.is_coext D C F (G x) (\<epsilon>.map x) y (\<psi> x g) g"
proof -
- interpret x\<epsilon>: arrow_from_functor D C F "G x" x "\<epsilon>.map x"
+ interpret x\<epsilon>: arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon>.map x\<close>
using x \<epsilon>.maps_ide_in_hom by (unfold_locales, auto)
show "x\<epsilon>.is_coext y (\<psi> x g) g"
using x g \<psi>_def x\<epsilon>.is_coext_def G_ide by blast
qed
lemma \<psi>_invertible:
assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<exists>!g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"
proof
have x: "C.ide x" using f by auto
- interpret x\<epsilon>: terminal_arrow_from_functor D C F "Go x" x "\<epsilon>o x"
+ interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
using x ex_terminal_arrow Go_\<epsilon>o_terminal by auto
have 1: "arrow_from_functor D C F y x f"
using y f by (unfold_locales, auto)
let ?g = "x\<epsilon>.the_coext y f"
have "\<psi> x ?g = f"
using 1 x y \<psi>_def x\<epsilon>.the_coext_prop G_ide \<psi>_inverts_coext x\<epsilon>.is_coext_def by simp
thus "\<guillemotleft>?g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x ?g = f"
using 1 x x\<epsilon>.the_coext_prop G_ide by simp
show "\<And>g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = f \<Longrightarrow> g' = ?g"
using 1 x y \<psi>_inverts_coext G_ide x\<epsilon>.the_coext_unique by force
qed
definition \<phi>
where "\<phi> y f = (THE g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G (C.cod f)\<guillemotright> \<and> \<psi> (C.cod f) g = f)"
lemma \<phi>_in_hom:
assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
using assms \<psi>_invertible \<phi>_def theI' [of "\<lambda>g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"]
by auto
lemma \<phi>_\<psi>:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<phi> y (\<psi> x g) = g"
proof -
have "C.cod (\<psi> x g) = x"
using assms \<psi>_in_hom by auto
hence "\<phi> y (\<psi> x g) = (THE g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = \<psi> x g)"
using \<phi>_def by auto
moreover have "\<exists>!g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = \<psi> x g"
using assms \<psi>_in_hom \<psi>_invertible D.ide_dom by blast
moreover have "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = \<psi> x g"
using assms(2) by auto
ultimately show "\<phi> y (\<psi> x g) = g" by auto
qed
lemma \<psi>_\<phi>:
assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<psi> x (\<phi> y f) = f"
using assms \<psi>_invertible \<phi>_def theI' [of "\<lambda>g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"]
by auto
lemma \<phi>_natural:
assumes "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = (G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g"
proof -
have "C.ide x' \<and> D.ide y \<and> D.in_hom (\<phi> y h) y (G x)"
using assms \<phi>_in_hom by auto
thus ?thesis
using assms D.comp_in_homI G.preserves_hom \<psi>_natural [of f x x' g y' y "\<phi> y h"] \<phi>_\<psi> \<psi>_\<phi>
by auto
qed
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G \<phi> \<psi>"
using \<phi>_in_hom \<psi>_in_hom \<phi>_\<psi> \<psi>_\<phi> \<phi>_natural D.comp_assoc
by (unfold_locales, simp_all)
end
text\<open>
A right adjoint functor induces a meta-adjunction, modulo the choice of a
left adjoint and unit.
\<close>
context right_adjoint_functor
begin
definition Fo :: "'d \<Rightarrow> 'c"
where "Fo y = (SOME x. \<exists>u. initial_arrow_to_functor C D G y x u)"
definition \<eta>o :: "'d \<Rightarrow> 'd"
where "\<eta>o y = (SOME u. initial_arrow_to_functor C D G y (Fo y) u)"
lemma Fo_\<eta>o_initial:
assumes "\<exists>x u. initial_arrow_to_functor C D G y x u"
shows "initial_arrow_to_functor C D G y (Fo y) (\<eta>o y)"
using assms Fo_def \<eta>o_def
someI_ex [of "\<lambda>x. \<exists>u. initial_arrow_to_functor C D G y x u"]
someI_ex [of "\<lambda>u. initial_arrow_to_functor C D G y (Fo y) u"]
by simp
text\<open>
The left adjoint @{term F} to @{term g} takes each arrow @{term g} of
@{term[source=true] D} to the unique @{term[source=true] C}-extension of
@{term "D (\<eta>o (D.cod g)) g"} along @{term "\<eta>o (D.dom g)"}.
\<close>
definition F :: "'d \<Rightarrow> 'c"
where "F g = (if D.arr g then
initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (\<eta>o (D.dom g))
(Fo (D.cod g)) (\<eta>o (D.cod g) \<cdot>\<^sub>D g)
else C.null)"
lemma F_ide:
assumes "D.ide y"
shows "F y = Fo y"
proof -
- interpret initial_arrow_to_functor C D G y "Fo y" "\<eta>o y"
+ interpret initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
using assms initial_arrows_exist Fo_\<eta>o_initial by blast
have 1: "arrow_to_functor C D G y (Fo y) (\<eta>o y)" ..
have "is_ext (Fo y) (\<eta>o y) (Fo y)"
unfolding is_ext_def using arrow D.comp_ide_arr [of "G (Fo y)" "\<eta>o y"] by force
hence "Fo y = the_ext (Fo y) (\<eta>o y)" using 1 the_ext_unique by blast
moreover have "\<eta>o y = D (\<eta>o (D.cod y)) y"
using assms arrow D.comp_arr_ide D.comp_arr_dom by auto
ultimately show ?thesis
using assms F_def D.dom_cod D.in_homE D.ide_in_hom by metis
qed
lemma F_is_functor:
shows "functor D C F"
proof
fix g :: 'd
assume "\<not>D.arr g"
thus "F g = C.null" using F_def by auto
next
fix g :: 'd
assume g: "D.arr g"
let ?y = "D.dom g"
let ?y' = "D.cod g"
- interpret y\<eta>: initial_arrow_to_functor C D G ?y "Fo ?y" "\<eta>o ?y"
+ interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
using g initial_arrows_exist Fo_\<eta>o_initial by simp
- interpret y'\<eta>: initial_arrow_to_functor C D G ?y' "Fo ?y'" "\<eta>o ?y'"
+ interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
using g initial_arrows_exist Fo_\<eta>o_initial by simp
have 1: "arrow_to_functor C D G ?y (Fo ?y') (D (\<eta>o ?y') g)"
using g y'\<eta>.arrow by (unfold_locales, auto)
have "F g = y\<eta>.the_ext (Fo ?y') (D (\<eta>o ?y') g)"
using g F_def by simp
hence Fg: "\<guillemotleft>F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y'\<guillemotright> \<and> \<eta>o ?y' \<cdot>\<^sub>D g = G (F g) \<cdot>\<^sub>D \<eta>o ?y"
using 1 y\<eta>.the_ext_prop by simp
show "C.arr (F g)" using Fg by auto
show "C.dom (F g) = F ?y" using Fg g F_ide by auto
show "C.cod (F g) = F ?y'" using Fg g F_ide by auto
next
fix g :: 'd
fix g' :: 'd
assume g': "D.arr (D g' g)"
have g: "D.arr g" using g' by auto
let ?y = "D.dom g"
let ?y' = "D.cod g"
let ?y'' = "D.cod g'"
- interpret y\<eta>: initial_arrow_to_functor C D G ?y "Fo ?y" "\<eta>o ?y"
+ interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
using g initial_arrows_exist Fo_\<eta>o_initial by simp
- interpret y'\<eta>: initial_arrow_to_functor C D G ?y' "Fo ?y'" "\<eta>o ?y'"
+ interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
using g initial_arrows_exist Fo_\<eta>o_initial by simp
- interpret y''\<eta>: initial_arrow_to_functor C D G ?y'' "Fo ?y''" "\<eta>o ?y''"
+ interpret y''\<eta>: initial_arrow_to_functor C D G ?y'' \<open>Fo ?y''\<close> \<open>\<eta>o ?y''\<close>
using g' initial_arrows_exist Fo_\<eta>o_initial by auto
have 1: "arrow_to_functor C D G ?y (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
using g y'\<eta>.arrow by (unfold_locales, auto)
have "F g = y\<eta>.the_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
using g F_def by simp
hence Fg: "\<guillemotleft>F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y'\<guillemotright> \<and> \<eta>o ?y' \<cdot>\<^sub>D g = G (F g) \<cdot>\<^sub>D \<eta>o ?y"
using 1 y\<eta>.the_ext_prop by simp
have 2: "arrow_to_functor C D G ?y' (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g')"
using g' y''\<eta>.arrow by (unfold_locales, auto)
have "F g' = y'\<eta>.the_ext (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g')"
using g' F_def by auto
hence Fg': "\<guillemotleft>F g' : Fo ?y' \<rightarrow>\<^sub>C Fo ?y''\<guillemotright> \<and> \<eta>o ?y'' \<cdot>\<^sub>D g' = G (F g') \<cdot>\<^sub>D \<eta>o ?y'"
using 2 y'\<eta>.the_ext_prop by simp
show "F (g' \<cdot>\<^sub>D g) = F g' \<cdot>\<^sub>C F g"
proof -
have "y\<eta>.is_ext (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g) (F g' \<cdot>\<^sub>C F g)"
proof -
have "\<guillemotleft>F g' \<cdot>\<^sub>C F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y''\<guillemotright>" using 1 2 Fg Fg' by auto
moreover have "\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g = G (F g' \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>o ?y"
proof -
have "\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g = (G (F g') \<cdot>\<^sub>D \<eta>o ?y') \<cdot>\<^sub>D g"
using Fg' g g' y''\<eta>.arrow by (metis D.comp_assoc)
also have "... = G (F g') \<cdot>\<^sub>D \<eta>o ?y' \<cdot>\<^sub>D g"
using D.comp_assoc by fastforce
also have "... = G (F g' \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>o ?y"
using Fg Fg' D.comp_assoc by fastforce
finally show ?thesis by auto
qed
ultimately show ?thesis using y\<eta>.is_ext_def by auto
qed
moreover have "arrow_to_functor C D G ?y (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g)"
using g g' y''\<eta>.arrow by (unfold_locales, auto)
ultimately show ?thesis
using g g' F_def y\<eta>.the_ext_unique D.dom_comp D.cod_comp by auto
qed
qed
interpretation F: "functor" D C F using F_is_functor by auto
lemma F_simp:
assumes "D.arr g"
shows "F g = initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (\<eta>o (D.dom g))
(Fo (D.cod g)) (\<eta>o (D.cod g) \<cdot>\<^sub>D g)"
using assms F_def by simp
interpretation FG: composite_functor D C D F G ..
interpretation \<eta>: transformation_by_components D D D.map FG.map \<eta>o
proof
fix y :: 'd
assume y: "D.ide y"
show "\<guillemotleft>\<eta>o y : D.map y \<rightarrow>\<^sub>D FG.map y\<guillemotright>"
proof -
- interpret initial_arrow_to_functor C D G y "Fo y" "\<eta>o y"
+ interpret initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
using y Fo_\<eta>o_initial initial_arrows_exist by simp
show ?thesis using y F_ide arrow by auto
qed
next
fix g :: 'd
assume g: "D.arr g"
show "\<eta>o (D.cod g) \<cdot>\<^sub>D D.map g = FG.map g \<cdot>\<^sub>D \<eta>o (D.dom g)"
proof -
let ?y = "D.dom g"
let ?y' = "D.cod g"
- interpret y\<eta>: initial_arrow_to_functor C D G ?y "Fo ?y" "\<eta>o ?y"
+ interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
using g Fo_\<eta>o_initial initial_arrows_exist by simp
- interpret y'\<eta>: initial_arrow_to_functor C D G ?y' "Fo ?y'" "\<eta>o ?y'"
+ interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
using g Fo_\<eta>o_initial initial_arrows_exist by simp
have "arrow_to_functor C D G ?y (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
using g y'\<eta>.arrow by (unfold_locales, auto)
moreover have "F g = y\<eta>.the_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
using g F_simp by blast
ultimately have "y\<eta>.is_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g) (F g)"
using y\<eta>.the_ext_prop y\<eta>.is_ext_def by auto
thus ?thesis
using g y\<eta>.is_ext_def by simp
qed
qed
definition \<phi>
where "\<phi> y h = D (G h) (\<eta>.map y)"
lemma \<phi>_in_hom:
assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
unfolding \<phi>_def using assms \<eta>.maps_ide_in_hom by auto
lemma \<phi>_natural:
assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = (G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g"
proof -
have "(G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g = (G f \<cdot>\<^sub>D G h \<cdot>\<^sub>D \<eta>.map y) \<cdot>\<^sub>D g"
unfolding \<phi>_def by auto
also have "... = (G f \<cdot>\<^sub>D G h) \<cdot>\<^sub>D \<eta>.map y \<cdot>\<^sub>D g"
using D.comp_assoc by fastforce
also have "... = G (f \<cdot>\<^sub>C h) \<cdot>\<^sub>D G (F g) \<cdot>\<^sub>D \<eta>.map y'"
using f g h \<eta>.naturality by fastforce
also have "... = (G (f \<cdot>\<^sub>C h) \<cdot>\<^sub>D G (F g)) \<cdot>\<^sub>D \<eta>.map y'"
using D.comp_assoc by fastforce
also have "... = G (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>.map y'"
using f g h D.comp_assoc by fastforce
also have "... = \<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)"
unfolding \<phi>_def by auto
finally show ?thesis by auto
qed
lemma \<phi>_inverts_ext:
assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "arrow_to_functor.is_ext C D G (F y) (\<eta>.map y) x (\<phi> y f) f"
proof -
- interpret y\<eta>: arrow_to_functor C D G y "F y" "\<eta>.map y"
+ interpret y\<eta>: arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta>.map y\<close>
using y \<eta>.maps_ide_in_hom by (unfold_locales, auto)
show "y\<eta>.is_ext x (\<phi> y f) f"
using f y \<phi>_def y\<eta>.is_ext_def F_ide by (unfold_locales, auto)
qed
lemma \<phi>_invertible:
assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<exists>!f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"
proof
have y: "D.ide y" using g by auto
- interpret y\<eta>: initial_arrow_to_functor C D G y "Fo y" "\<eta>o y"
+ interpret y\<eta>: initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
using y initial_arrows_exist Fo_\<eta>o_initial by auto
have 1: "arrow_to_functor C D G y x g"
using x g by (unfold_locales, auto)
let ?f = "y\<eta>.the_ext x g"
have "\<phi> y ?f = g"
using \<phi>_def y\<eta>.the_ext_prop 1 F_ide x y \<phi>_inverts_ext y\<eta>.is_ext_def by fastforce
moreover have "\<guillemotleft>?f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
using 1 y y\<eta>.the_ext_prop F_ide by simp
ultimately show "\<guillemotleft>?f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y ?f = g" by auto
show "\<And>f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = g \<Longrightarrow> f' = ?f"
using 1 y \<phi>_inverts_ext y\<eta>.the_ext_unique F_ide by force
qed
definition \<psi>
where "\<psi> x g = (THE f. \<guillemotleft>f : F (D.dom g) \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> (D.dom g) f = g)"
lemma \<psi>_in_hom:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "C.in_hom (\<psi> x g) (F y) x"
using assms \<phi>_invertible \<psi>_def theI' [of "\<lambda>f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"]
by auto
lemma \<psi>_\<phi>:
assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<psi> x (\<phi> y f) = f"
proof -
have "D.dom (\<phi> y f) = y" using assms \<phi>_in_hom by blast
hence "\<psi> x (\<phi> y f) = (THE f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = \<phi> y f)"
using \<psi>_def by auto
moreover have "\<exists>!f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = \<phi> y f"
using assms \<phi>_in_hom \<phi>_invertible C.ide_cod by blast
ultimately show ?thesis using assms(2) by auto
qed
lemma \<phi>_\<psi>:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<phi> y (\<psi> x g) = g"
using assms \<phi>_invertible \<psi>_def theI' [of "\<lambda>f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"]
by auto
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G \<phi> \<psi>"
using \<phi>_in_hom \<psi>_in_hom \<phi>_\<psi> \<psi>_\<phi> \<phi>_natural D.comp_assoc
by (unfold_locales, auto)
end
section "Meta-Adjunctions Induce Hom-Adjunctions"
text\<open>
To obtain a hom-adjunction from a meta-adjunction, we need to exhibit hom-functors
from @{term C} and @{term D} to a common set category @{term S}, so it is necessary
to apply an actual concrete construction of such a category.
We use the category \<open>SetCat\<close> whose element type is the disjoint sum
@{typ "('c+'d)"} of the arrow types of @{term C} and @{term D}.
\<close>
context meta_adjunction
begin
- definition inC :: "'c \<Rightarrow> ('c+'d) SetCat.arr"
- where "inC \<equiv> UP o Inl"
+ definition inC :: "'c \<Rightarrow> ('c+'d) setcat.arr"
+ where "inC \<equiv> SetCat.UP o Inl"
- definition inD :: "'d \<Rightarrow> ('c+'d) SetCat.arr"
- where "inD \<equiv> UP o Inr"
+ definition inD :: "'d \<Rightarrow> ('c+'d) setcat.arr"
+ where "inD \<equiv> SetCat.UP o Inr"
- interpretation S: set_category "SetCat.comp :: ('c+'d) SetCat.arr comp"
+ interpretation S: set_category \<open>SetCat.comp :: ('c+'d) setcat.arr comp\<close>
using SetCat.is_set_category by auto
interpretation Cop: dual_category C ..
interpretation Dop: dual_category D ..
interpretation CopxC: product_category Cop.comp C ..
interpretation DopxD: product_category Dop.comp D ..
interpretation DopxC: product_category Dop.comp C ..
- interpretation HomC: hom_functor C "SetCat.comp :: ('c+'d) SetCat.arr comp" "\<lambda>_. inC"
+ interpretation HomC: hom_functor C \<open>SetCat.comp :: ('c+'d) setcat.arr comp\<close> \<open>\<lambda>_. inC\<close>
apply unfold_locales
unfolding inC_def using SetCat.UP_mapsto
apply auto[1]
using SetCat.inj_UP
- by (metis (no_types, lifting) injD inj_Inl inj_compose inj_onI)
- interpretation HomD: hom_functor D "SetCat.comp :: ('c+'d) SetCat.arr comp" "\<lambda>_. inD"
+ by (metis injD inj_Inl inj_compose inj_on_def)
+ interpretation HomD: hom_functor D \<open>SetCat.comp :: ('c+'d) setcat.arr comp\<close> \<open>\<lambda>_. inD\<close>
apply unfold_locales
unfolding inD_def using SetCat.UP_mapsto
apply auto[1]
using SetCat.inj_UP
- by (metis (no_types, lifting) injD inj_Inr inj_compose inj_onI)
+ by (metis injD inj_Inr inj_compose inj_on_def)
interpretation Fop: dual_functor D C F ..
interpretation FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map ..
interpretation DopxG: product_functor Dop.comp C Dop.comp D Dop.map G ..
interpretation Hom_FopxC: composite_functor DopxC.comp CopxC.comp SetCat.comp
FopxC.map HomC.map ..
interpretation Hom_DopxG: composite_functor DopxC.comp DopxD.comp SetCat.comp
DopxG.map HomD.map ..
lemma inC_\<psi> [simp]:
assumes "C.ide b" and "C.ide a" and "x \<in> inC ` C.hom b a"
shows "inC (HomC.\<psi> (b, a) x) = x"
using assms by auto
lemma \<psi>_inC [simp]:
assumes "C.arr f"
shows "HomC.\<psi> (C.dom f, C.cod f) (inC f) = f"
using assms HomC.\<psi>_\<phi> by blast
lemma inD_\<psi> [simp]:
assumes "D.ide b" and "D.ide a" and "x \<in> inD ` D.hom b a"
shows "inD (HomD.\<psi> (b, a) x) = x"
using assms by auto
lemma \<psi>_inD [simp]:
assumes "D.arr f"
shows "HomD.\<psi> (D.dom f, D.cod f) (inD f) = f"
using assms HomD.\<psi>_\<phi> by blast
lemma Hom_FopxC_simp:
assumes "DopxC.arr gf"
shows "Hom_FopxC.map gf =
S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
(HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
(inC \<circ> (\<lambda>h. snd gf \<cdot>\<^sub>C h \<cdot>\<^sub>C F (fst gf))
\<circ> HomC.\<psi> (F (D.cod (fst gf)), C.dom (snd gf)))"
using assms HomC.map_def by simp
lemma Hom_DopxG_simp:
assumes "DopxC.arr gf"
shows "Hom_DopxG.map gf =
S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
(HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
(inD \<circ> (\<lambda>h. G (snd gf) \<cdot>\<^sub>D h \<cdot>\<^sub>D fst gf)
\<circ> HomD.\<psi> (D.cod (fst gf), G (C.dom (snd gf))))"
using assms HomD.map_def by simp
definition \<Phi>o
where "\<Phi>o yx = S.mkArr (HomC.set (F (fst yx), snd yx))
(HomD.set (fst yx, G (snd yx)))
(inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
lemma \<Phi>o_in_hom:
assumes yx: "DopxC.ide yx"
shows "\<guillemotleft>\<Phi>o yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
proof -
have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
using yx HomC.map_ide by auto
moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
using yx HomD.map_ide by auto
moreover have
"\<guillemotleft>S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
(inD \<circ> \<phi> (fst yx) \<circ> HomC.\<psi> (F (fst yx), snd yx)) :
S.mkIde (HomC.set (F (fst yx), snd yx))
\<rightarrow>\<^sub>S S.mkIde (HomD.set (fst yx, G (snd yx)))\<guillemotright>"
proof (intro S.mkArr_in_hom)
show "HomC.set (F (fst yx), snd yx) \<subseteq> S.Univ" using yx HomC.set_subset_Univ by simp
show "HomD.set (fst yx, G (snd yx)) \<subseteq> S.Univ" using yx HomD.set_subset_Univ by simp
show "inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)
\<in> HomC.set (F (fst yx), snd yx) \<rightarrow> HomD.set (fst yx, G (snd yx))"
proof
fix x
assume x: "x \<in> HomC.set (F (fst yx), snd yx)"
show "(inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)) x
\<in> HomD.set (fst yx, G (snd yx))"
using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"]
\<phi>_in_hom [of "fst yx"] HomD.\<phi>_mapsto [of "fst yx" "G (snd yx)"]
by auto
qed
qed
ultimately show ?thesis using \<Phi>o_def by auto
qed
interpretation \<Phi>: transformation_by_components DopxC.comp SetCat.comp
Hom_FopxC.map Hom_DopxG.map \<Phi>o
proof
fix yx
assume yx: "DopxC.ide yx"
show "\<guillemotleft>\<Phi>o yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
using yx \<Phi>o_in_hom by auto
next
fix gf
assume gf: "DopxC.arr gf"
show "SetCat.comp (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)
= SetCat.comp (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))"
proof -
let ?g = "fst gf"
let ?f = "snd gf"
let ?x = "C.dom ?f"
let ?x' = "C.cod ?f"
let ?y = "D.cod ?g"
let ?y' = "D.dom ?g"
let ?Fy = "F ?y"
let ?Fy' = "F ?y'"
let ?Fg = "F ?g"
let ?Gx = "G ?x"
let ?Gx' = "G ?x'"
let ?Gf = "G ?f"
have 1: "S.arr (Hom_FopxC.map gf) \<and>
Hom_FopxC.map gf = S.mkArr (HomC.set (?Fy, ?x)) (HomC.set (?Fy', ?x'))
(inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))"
using gf Hom_FopxC.preserves_arr Hom_FopxC_simp by blast
have 2: "S.arr (\<Phi>o (DopxC.cod gf)) \<and>
\<Phi>o (DopxC.cod gf) = S.mkArr (HomC.set (?Fy', ?x')) (HomD.set (?y', ?Gx'))
(inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))"
using gf \<Phi>o_in_hom [of "DopxC.cod gf"] \<Phi>o_def [of "DopxC.cod gf"] \<phi>_in_hom
by auto
have 3: "S.arr (\<Phi>o (DopxC.dom gf)) \<and>
\<Phi>o (DopxC.dom gf) = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y, ?Gx))
(inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))"
using gf \<Phi>o_in_hom [of "DopxC.dom gf"] \<Phi>o_def [of "DopxC.dom gf"] \<phi>_in_hom
by auto
have 4: "S.arr (Hom_DopxG.map gf) \<and>
Hom_DopxG.map gf = S.mkArr (HomD.set (?y, ?Gx)) (HomD.set (?y', ?Gx'))
(inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))"
using gf Hom_DopxG.preserves_arr Hom_DopxG_simp by blast
have 5: "S.seq (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf) \<and>
SetCat.comp (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)
= S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x)))"
proof -
have "S.seq (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)"
using gf 1 2 \<Phi>o_in_hom Hom_FopxC.preserves_hom by (intro S.seqI', auto)
thus ?thesis
using S.comp_mkArr 1 2 by metis
qed
have 6: "SetCat.comp (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))
= S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x)))"
proof -
have "S.seq (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))"
using gf 3 4 S.arr_mkArr S.cod_mkArr S.dom_mkArr by (intro S.seqI; metis)
thus ?thesis
using 3 4 S.comp_mkArr by metis
qed
have 7:
"restrict ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) (HomC.set (?Fy, ?x))
= restrict ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) (HomC.set (?Fy, ?x))"
proof (intro restrict_ext)
show "\<And>h. h \<in> HomC.set (?Fy, ?x) \<Longrightarrow>
((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
= ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
proof -
fix h
assume h: "h \<in> HomC.set (?Fy, ?x)"
have \<psi>h: "\<guillemotleft>HomC.\<psi> (?Fy, ?x) h : ?Fy \<rightarrow>\<^sub>C ?x\<guillemotright>"
using gf h HomC.\<psi>_mapsto [of ?Fy ?x] CopxC.ide_char by auto
show "((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
= ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
proof -
have
"((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
= inD (\<phi> ?y' (HomC.\<psi> (?Fy', ?x') (inC (?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg))))"
by simp
also have "... = inD (\<phi> ?y' (?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg))"
using gf \<psi>h HomC.\<phi>_mapsto HomC.\<psi>_mapsto \<phi>_in_hom
\<psi>_inC [of "?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg"]
by auto
also have "... = inD (D ?Gf (D (\<phi> ?y (HomC.\<psi> (?Fy, ?x) h)) ?g))"
proof -
have "\<guillemotleft>?f : C.dom ?f \<rightarrow> C.cod ?f\<guillemotright>"
using gf by auto
moreover have "\<guillemotleft>?g : D.dom ?g \<rightarrow>\<^sub>D D.cod ?g\<guillemotright>"
using gf by auto
ultimately show ?thesis
using gf \<psi>h \<phi>_in_hom G.preserves_hom C.in_homE D.in_homE
\<phi>_naturality [of ?f ?x ?x' ?g ?y' ?y "HomC.\<psi> (?Fy, ?x) h"]
by simp
qed
also have "... =
inD (D ?Gf (D (HomD.\<psi> (?y, ?Gx) (inD (\<phi> ?y (HomC.\<psi> (?Fy, ?x) h)))) ?g))"
using gf \<psi>h \<phi>_in_hom by simp
also have "... = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
by simp
finally show ?thesis by auto
qed
qed
qed
have 8: "S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x)))
= S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x)))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))))"
using 5 by metis
show "\<And>t. t \<in> HomC.set (?Fy, ?x) \<Longrightarrow>
((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) t
= ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) t"
using 7 restrict_apply by fast
qed
show ?thesis using 5 6 8 by auto
qed
qed
lemma \<Phi>_simp:
assumes YX: "DopxC.ide yx"
shows "\<Phi>.map yx =
S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
(inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
using YX \<Phi>o_def by simp
abbreviation \<Psi>o
where "\<Psi>o yx \<equiv> S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
(inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))"
lemma \<Psi>o_in_hom:
assumes yx: "DopxC.ide yx"
shows "\<guillemotleft>\<Psi>o yx : Hom_DopxG.map yx \<rightarrow>\<^sub>S Hom_FopxC.map yx\<guillemotright>"
proof -
have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
using yx HomC.map_ide by auto
moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
using yx HomD.map_ide by auto
moreover have "\<guillemotleft>\<Psi>o yx : S.mkIde (HomD.set (fst yx, G (snd yx)))
\<rightarrow>\<^sub>S S.mkIde (HomC.set (F (fst yx), snd yx))\<guillemotright>"
proof (intro S.mkArr_in_hom)
show "HomC.set (F (fst yx), snd yx) \<subseteq> S.Univ" using yx HomC.set_subset_Univ by simp
show "HomD.set (fst yx, G (snd yx)) \<subseteq> S.Univ" using yx HomD.set_subset_Univ by simp
show "inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))
\<in> HomD.set (fst yx, G (snd yx)) \<rightarrow> HomC.set (F (fst yx), snd yx)"
proof
fix x
assume x: "x \<in> HomD.set (fst yx, G (snd yx))"
show "(inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))) x
\<in> HomC.set (F (fst yx), snd yx)"
using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<psi>_in_hom [of "snd yx"]
HomC.\<phi>_mapsto [of "F (fst yx)" "snd yx"]
by auto
qed
qed
ultimately show ?thesis by auto
qed
lemma \<Phi>_inv:
assumes yx: "DopxC.ide yx"
shows "S.inverse_arrows (\<Phi>.map yx) (\<Psi>o yx)"
proof -
have 1: "\<guillemotleft>\<Phi>.map yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
using yx \<Phi>.preserves_hom [of yx yx yx] DopxC.ide_in_hom by blast
have 2: "\<guillemotleft>\<Psi>o yx : Hom_DopxG.map yx \<rightarrow>\<^sub>S Hom_FopxC.map yx\<guillemotright>"
using yx \<Psi>o_in_hom by simp
have 3: "\<Phi>.map yx = S.mkArr (HomC.set (F (fst yx), snd yx))
(HomD.set (fst yx, G (snd yx)))
(inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
using yx \<Phi>_simp by blast
have antipar: "S.antipar (\<Phi>.map yx) (\<Psi>o yx)"
using 1 2 by fastforce
moreover have "S.ide (SetCat.comp (\<Psi>o yx) (\<Phi>.map yx))"
proof -
have "SetCat.comp (\<Psi>o yx) (\<Phi>.map yx) =
S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)))"
using 1 2 3 antipar by fastforce
also have
"... = S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
(\<lambda>x. x)"
proof -
have
"S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx)) (\<lambda>x. x)
= ..."
proof
show
"S.arr (S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
(\<lambda>x. x))"
using yx HomC.set_subset_Univ by simp
show "\<And>x. x \<in> HomC.set (F (fst yx), snd yx) \<Longrightarrow>
x = ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x"
proof -
fix x
assume x: "x \<in> HomC.set (F (fst yx), snd yx)"
have "((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x
= inC (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx))
(inD (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx) x)))))"
by simp
also have "... = inC (\<psi> (snd yx) (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx) x)))"
using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"] \<phi>_in_hom by force
also have "... = inC (HomC.\<psi> (F (fst yx), snd yx) x)"
using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"] \<psi>_\<phi> by force
also have "... = x" using x yx inC_\<psi> by simp
finally show "x = ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x"
by auto
qed
qed
thus ?thesis by auto
qed
also have "... = S.mkIde (HomC.set (F (fst yx), snd yx))"
using yx S.mkIde_as_mkArr HomC.set_subset_Univ by force
finally have
"SetCat.comp (\<Psi>o yx) (\<Phi>.map yx) = S.mkIde (HomC.set (F (fst yx), snd yx))"
by auto
thus ?thesis using yx HomC.set_subset_Univ by simp
qed
moreover have "S.ide (SetCat.comp (\<Phi>.map yx) (\<Psi>o yx))"
proof -
have "SetCat.comp (\<Phi>.map yx) (\<Psi>o yx) =
S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))))"
using 1 2 3 S.comp_mkArr antipar by fastforce
also
have "... = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
(\<lambda>x. x)"
proof -
have
"S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx))) (\<lambda>x. x)
= ..."
proof
show
"S.arr (S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
(\<lambda>x. x))"
using yx HomD.set_subset_Univ by simp
show "\<And>x. x \<in> (HomD.set (fst yx, G (snd yx))) \<Longrightarrow>
x = ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x"
proof -
fix x
assume x: "x \<in> HomD.set (fst yx, G (snd yx))"
have "((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x
= inD (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx)
(inC (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x)))))"
by simp
also have "... = inD (\<phi> (fst yx) (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x)))"
proof -
have "\<guillemotleft>\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x) : F (fst yx) \<rightarrow> snd yx\<guillemotright>"
using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<psi>_in_hom by auto
thus ?thesis by simp
qed
also have "... = inD (HomD.\<psi> (fst yx, G (snd yx)) x)"
using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<phi>_\<psi> by force
also have "... = x" using x yx inD_\<psi> by simp
finally show "x = ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x"
by auto
qed
qed
thus ?thesis by auto
qed
also have "... = S.mkIde (HomD.set (fst yx, G (snd yx)))"
using yx S.mkIde_as_mkArr HomD.set_subset_Univ by force
finally have
"SetCat.comp (\<Phi>.map yx) (\<Psi>o yx) = S.mkIde (HomD.set (fst yx, G (snd yx)))"
by auto
thus ?thesis using yx HomD.set_subset_Univ by simp
qed
ultimately show ?thesis by auto
qed
interpretation \<Phi>: natural_isomorphism DopxC.comp SetCat.comp
Hom_FopxC.map Hom_DopxG.map \<Phi>.map
apply (unfold_locales) using \<Phi>_inv by blast
interpretation \<Psi>: inverse_transformation DopxC.comp SetCat.comp
Hom_FopxC.map Hom_DopxG.map \<Phi>.map ..
interpretation \<Phi>\<Psi>: inverse_transformations DopxC.comp SetCat.comp
Hom_FopxC.map Hom_DopxG.map \<Phi>.map \<Psi>.map
using \<Psi>.inverts_components by (unfold_locales, simp)
abbreviation \<Phi> where "\<Phi> \<equiv> \<Phi>.map"
abbreviation \<Psi> where "\<Psi> \<equiv> \<Psi>.map"
abbreviation HomC where "HomC \<equiv> HomC.map"
abbreviation \<phi>C where "\<phi>C \<equiv> \<lambda>_. inC"
abbreviation HomD where "HomD \<equiv> HomD.map"
abbreviation \<phi>D where "\<phi>D \<equiv> \<lambda>_. inD"
theorem induces_hom_adjunction: "hom_adjunction C D SetCat.comp \<phi>C \<phi>D F G \<Phi> \<Psi>"
using F.is_extensional by (unfold_locales, auto)
lemma \<Psi>_simp:
assumes yx: "DopxC.ide yx"
shows "\<Psi> yx = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
(inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))"
using assms \<Phi>o_def \<Phi>_inv S.inverse_unique by simp
text\<open>
The original @{term \<phi>} and @{term \<psi>} can be recovered from @{term \<Phi>} and @{term \<Psi>}.
\<close>
interpretation \<Phi>: set_valued_transformation DopxC.comp SetCat.comp
Hom_FopxC.map Hom_DopxG.map \<Phi>.map ..
interpretation \<Psi>: set_valued_transformation DopxC.comp SetCat.comp
Hom_DopxG.map Hom_FopxC.map \<Psi>.map ..
lemma \<phi>_in_terms_of_\<Phi>':
assumes y: "D.ide y" and f: "\<guillemotleft>f: F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<phi> y f = (HomD.\<psi> (y, G x) o \<Phi>.FUN (y, x) o inC) f"
proof -
have x: "C.ide x" using f by auto
have 1: "S.arr (\<Phi> (y, x))" using x y by fastforce
have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(inD o \<phi> y o HomC.\<psi> (F y, x))"
using x y \<Phi>o_def by auto
have "(HomD.\<psi> (y, G x) o \<Phi>.FUN (y, x) o inC) f =
HomD.\<psi> (y, G x)
(restrict (inD o \<phi> y o HomC.\<psi> (F y, x)) (HomC.set (F y, x)) (inC f))"
using 1 2 by simp
also have "... = \<phi> y f"
using x y f HomC.\<phi>_mapsto \<phi>_in_hom HomC.\<psi>_mapsto C.ide_in_hom D.ide_in_hom
by auto
finally show ?thesis by auto
qed
lemma \<psi>_in_terms_of_\<Psi>':
assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<psi> x g = (HomC.\<psi> (F y, x) o \<Psi>.FUN (y, x) o inD) g"
proof -
have y: "D.ide y" using g by auto
have 1: "S.arr (\<Psi> (y, x))"
using x y \<Psi>.preserves_reflects_arr [of "(y, x)"] by simp
have 2: "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(inC o \<psi> x o HomD.\<psi> (y, G x))"
using x y \<Psi>_simp by force
have "(HomC.\<psi> (F y, x) o \<Psi>.FUN (y, x) o inD) g =
HomC.\<psi> (F y, x)
(restrict (inC o \<psi> x o HomD.\<psi> (y, G x)) (HomD.set (y, G x)) (inD g))"
using 1 2 by simp
also have "... = \<psi> x g"
using x y g HomD.\<phi>_mapsto \<psi>_in_hom HomD.\<psi>_mapsto C.ide_in_hom D.ide_in_hom
by auto
finally show ?thesis by auto
qed
end
section "Hom-Adjunctions Induce Meta-Adjunctions"
context hom_adjunction
begin
definition \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
where
"\<phi> y h = (HomD.\<psi> (y, G (C.cod h)) o \<Phi>.FUN (y, C.cod h) o \<phi>C (F y, C.cod h)) h"
definition \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
where
"\<psi> x h = (HomC.\<psi> (F (D.dom h), x) o \<Psi>.FUN (D.dom h, x) o \<phi>D (D.dom h, G x)) h"
lemma Hom_FopxC_map_simp:
assumes "DopxC.arr gf"
shows "Hom_FopxC.map gf =
S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
(HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
(\<phi>C (F (D.dom (fst gf)), C.cod (snd gf))
o (\<lambda>h. snd gf \<cdot>\<^sub>C h \<cdot>\<^sub>C F (fst gf))
o HomC.\<psi> (F (D.cod (fst gf)), C.dom (snd gf)))"
using assms HomC.map_def by simp
lemma Hom_DopxG_map_simp:
assumes "DopxC.arr gf"
shows "Hom_DopxG.map gf =
S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
(HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
(\<phi>D (D.dom (fst gf), G (C.cod (snd gf)))
o (\<lambda>h. G (snd gf) \<cdot>\<^sub>D h \<cdot>\<^sub>D fst gf)
o HomD.\<psi> (D.cod (fst gf), G (C.dom (snd gf))))"
using assms HomD.map_def by simp
lemma \<Phi>_Fun_mapsto:
assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
shows "\<Phi>.FUN (y, x) \<in> HomC.set (F y, x) \<rightarrow> HomD.set (y, G x)"
proof -
have "S.arr (\<Phi> (y, x)) \<and> \<Phi>.DOM (y, x) = HomC.set (F y, x) \<and>
\<Phi>.COD (y, x) = HomD.set (y, G x)"
using assms HomC.set_map HomD.set_map by auto
thus ?thesis using S.Fun_mapsto by blast
qed
lemma \<phi>_mapsto:
assumes y: "D.ide y"
shows "\<phi> y \<in> C.hom (F y) x \<rightarrow> D.hom y (G x)"
proof
fix h
assume h: "h \<in> C.hom (F y) x"
hence 1: " \<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>" by simp
show "\<phi> y h \<in> D.hom y (G x)"
proof -
have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
using y h 1 HomC.\<phi>_mapsto [of "F y" x] by fastforce
hence "\<Phi>.FUN (y, x) (\<phi>C (F y, x) h) \<in> HomD.set (y, G x)"
using h y \<Phi>_Fun_mapsto by auto
thus ?thesis
using y h 1 \<phi>_def HomC.\<phi>_mapsto HomD.\<psi>_mapsto [of y "G x"] by fastforce
qed
qed
lemma \<Phi>_simp:
assumes "D.ide y" and "C.ide x"
shows "S.arr (\<Phi> (y, x))"
and "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
proof -
show 1: "S.arr (\<Phi> (y, x))" using assms by auto
hence "\<Phi> (y, x) = S.mkArr (\<Phi>.DOM (y, x)) (\<Phi>.COD (y, x)) (\<Phi>.FUN (y, x))"
using S.mkArr_Fun by metis
also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (\<Phi>.FUN (y, x))"
using assms HomC.set_map HomD.set_map by fastforce
also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (\<Phi>.FUN (y, x)))"
using 1 calculation by argo
show "\<And>h. h \<in> HomC.set (F y, x) \<Longrightarrow>
\<Phi>.FUN (y, x) h = (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) h"
proof -
fix h
assume h: "h \<in> HomC.set (F y, x)"
hence "\<guillemotleft>\<psi>C (F y, x) h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
using assms HomC.\<psi>_mapsto [of "F y" x] by auto
hence "(\<phi>D (y, G x) o \<phi> y o HomC.\<psi> (F y, x)) h =
\<phi>D (y, G x) (\<psi>D (y, G x) (\<Phi>.FUN (y, x) (\<phi>C (F y, x) (\<psi>C (F y, x) h))))"
using h \<phi>_def by auto
also have "... = \<phi>D (y, G x) (\<psi>D (y, G x) (\<Phi>.FUN (y, x) h))"
using assms h HomC.\<phi>_\<psi> \<Phi>_Fun_mapsto by simp
also have "... = \<Phi>.FUN (y, x) h"
using assms h \<Phi>_Fun_mapsto [of y "\<psi>C (F y, x) h"] HomC.\<psi>_mapsto
HomD.\<phi>_\<psi> [of y "G x"] C.ide_in_hom D.ide_in_hom
by blast
finally show "\<Phi>.FUN (y, x) h = (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) h" by auto
qed
qed
finally show "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
by force
qed
lemma \<Psi>_Fun_mapsto:
assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
shows "\<Psi>.FUN (y, x) \<in> HomD.set (y, G x) \<rightarrow> HomC.set (F y, x)"
proof -
have "S.arr (\<Psi> (y, x)) \<and> \<Psi>.COD (y, x) = HomC.set (F y, x) \<and>
\<Psi>.DOM (y, x) = HomD.set (y, G x)"
using assms HomC.set_map HomD.set_map by auto
thus ?thesis using S.Fun_mapsto by fast
qed
lemma \<psi>_mapsto:
assumes x: "C.ide x"
shows "\<psi> x \<in> D.hom y (G x) \<rightarrow> C.hom (F y) x"
proof
fix h
assume h: "h \<in> D.hom y (G x)"
hence 1: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>" by auto
show "\<psi> x h \<in> C.hom (F y) x"
proof -
have "\<phi>D (y, G x) h \<in> HomD.set (y, G x)"
using x h 1 HomD.\<phi>_mapsto [of y "G x"] by fastforce
hence "\<Psi>.FUN (y, x) (\<phi>D (y, G x) h) \<in> HomC.set (F y, x)"
using h x \<Psi>_Fun_mapsto by auto
thus ?thesis
using x h 1 \<psi>_def HomD.\<phi>_mapsto HomC.\<psi>_mapsto [of "F y" x] by fastforce
qed
qed
lemma \<Psi>_simp:
assumes "D.ide y" and "C.ide x"
shows "S.arr (\<Psi> (y, x))"
and "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
proof -
show 1: "S.arr (\<Psi> (y, x))" using assms by auto
hence "\<Psi> (y, x) = S.mkArr (\<Psi>.DOM (y, x)) (\<Psi>.COD (y, x)) (\<Psi>.FUN (y, x))"
using S.mkArr_Fun by metis
also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (\<Psi>.FUN (y, x))"
using assms HomC.set_map HomD.set_map by auto
also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (\<Psi>.FUN (y, x)))"
using 1 calculation by argo
show "\<And>h. h \<in> HomD.set (y, G x) \<Longrightarrow>
\<Psi>.FUN (y, x) h = (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x)) h"
proof -
fix h
assume h: "h \<in> HomD.set (y, G x)"
hence "\<guillemotleft>\<psi>D (y, G x) h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
using assms HomD.\<psi>_mapsto [of y "G x"] by auto
hence "(\<phi>C (F y, x) o \<psi> x o HomD.\<psi> (y, G x)) h =
\<phi>C (F y, x) (\<psi>C (F y, x) (\<Psi>.FUN (y, x) (\<phi>D (y, G x) (\<psi>D (y, G x) h))))"
using h \<psi>_def by auto
also have "... = \<phi>C (F y, x) (\<psi>C (F y, x) (\<Psi>.FUN (y, x) h))"
using assms h HomD.\<phi>_\<psi> \<Psi>_Fun_mapsto by simp
also have "... = \<Psi>.FUN (y, x) h"
using assms h \<Psi>_Fun_mapsto HomD.\<psi>_mapsto [of y "G x"] HomC.\<phi>_\<psi> [of "F y" x]
C.ide_in_hom D.ide_in_hom
by blast
finally show "\<Psi>.FUN (y, x) h = (\<phi>C (F y, x) o \<psi> x o HomD.\<psi> (y, G x)) h" by auto
qed
qed
finally show "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
by force
qed
text\<open>
The length of the next proof stems from having to use properties of composition
of arrows in @{term[source=true] S} to infer properties of the composition of the
corresponding functions.
\<close>
interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
proof
fix y :: 'd and x :: 'c and h :: 'c
assume y: "D.ide y" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
have x: "C.ide x" using h by auto
show "\<guillemotleft>\<phi> y h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
proof -
have "\<Phi>.FUN (y, x) \<in> HomC.set (F y, x) \<rightarrow> HomD.set (y, G x)"
using y h \<Phi>_Fun_mapsto by blast
thus ?thesis
using x y h \<phi>_def HomD.\<psi>_mapsto [of y "G x"] HomC.\<phi>_mapsto [of "F y" x] by auto
qed
show "\<psi> x (\<phi> y h) = h"
proof -
have 0: "restrict (\<lambda>h. h) (HomC.set (F y, x))
= restrict (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (HomC.set (F y, x))"
proof -
have 1: "S.ide (\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x))"
using x y \<Phi>\<Psi>.inv [of "(y, x)"] by auto
hence 6: "S.seq (\<Psi> (y, x)) (\<Phi> (y, x))" by auto
have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) \<and>
\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
using x y \<Phi>_simp \<Psi>_simp by force
have 3: "S (\<Psi> (y, x)) (\<Phi> (y, x))
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))"
proof -
have 4: "S.arr (\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x))" using 1 by auto
hence "S (\<Psi> (y, x)) (\<Phi> (y, x))
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
using 1 2 S.ide_in_hom by force
also have "... = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
using 4 calculation by simp
show "\<And>h. h \<in> HomC.set (F y, x) \<Longrightarrow>
((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))) h =
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) h"
proof -
fix h
assume h: "h \<in> HomC.set (F y, x)"
hence 1: "\<guillemotleft>\<phi> y (\<psi>C (F y, x) h) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
using x y h HomC.\<psi>_mapsto [of "F y" x] \<phi>_mapsto by auto
show "((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))) h =
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) h"
using x y 1 \<phi>_mapsto HomD.\<psi>_\<phi> by simp
qed
qed
finally show ?thesis by simp
qed
moreover have "\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x)
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (\<lambda>h. h)"
proof -
have "\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x) = S.dom (S (\<Psi> (y, x)) (\<Phi> (y, x)))"
using 1 by auto
also have "... = S.dom (\<Phi> (y, x))"
using 1 S.dom_comp by blast
finally show ?thesis
using 2 6 S.mkIde_as_mkArr by (elim S.seqE, auto)
qed
ultimately have 4: "S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (\<lambda>h. h)"
by auto
have 5: "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)))"
proof -
have "S.seq (\<Psi> (y, x)) (\<Phi> (y, x))"
using 1 by fast
thus ?thesis using 3 by metis
qed
hence "restrict (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (HomC.set (F y, x))
= S.Fun (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)))"
by auto
also have "... = restrict (\<lambda>h. h) (HomC.set (F y, x))"
using 4 5 by auto
finally show ?thesis by auto
qed
moreover have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
using x y h HomC.\<phi>_mapsto [of "F y" x] by auto
ultimately have
"\<phi>C (F y, x) h = (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (\<phi>C (F y, x) h)"
using x y h HomC.\<phi>_mapsto [of "F y" x] by fast
hence "\<psi>C (F y, x) (\<phi>C (F y, x) h) =
\<psi>C (F y, x) ((\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (\<phi>C (F y, x) h))"
by simp
hence "h = \<psi>C (F y, x) (\<phi>C (F y, x) (\<psi> x (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h)))))"
using x y h HomC.\<psi>_\<phi> [of "F y" x] by simp
also have "... = \<psi> x (\<phi> y h)"
using x y h HomC.\<psi>_\<phi> HomC.\<psi>_\<phi> \<phi>_mapsto \<psi>_mapsto
by (metis PiE mem_Collect_eq)
finally show ?thesis by auto
qed
next
fix x :: 'c and h :: 'd and y :: 'd
assume x: "C.ide x" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
have y: "D.ide y" using h by auto
show "\<guillemotleft>\<psi> x h : F y \<rightarrow>\<^sub>C x\<guillemotright>" using x y h \<psi>_mapsto [of x y] by auto
show "\<phi> y (\<psi> x h) = h"
proof -
have 0: "restrict (\<lambda>h. h) (HomD.set (y, G x))
= restrict (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (HomD.set (y, G x))"
proof -
have 1: "S.ide (S (\<Phi> (y, x)) (\<Psi> (y, x)))"
using x y \<Phi>\<Psi>.inv by force
hence 6: "S.seq (\<Phi> (y, x)) (\<Psi> (y, x))" by auto
have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) \<and>
\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
using x h \<Phi>_simp \<Psi>_simp by auto
have 3: "S (\<Phi> (y, x)) (\<Psi> (y, x))
= S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))"
proof -
have 4: "S.seq (\<Phi> (y, x)) (\<Psi> (y, x))" using 1 by auto
hence "S (\<Phi> (y, x)) (\<Psi> (y, x))
= S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x)))"
using 1 2 6 S.ide_in_hom by force
also have "... = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))"
proof
show "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))))"
using 4 calculation by simp
show "\<And>h. h \<in> HomD.set (y, G x) \<Longrightarrow>
((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))) h =
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) h"
proof -
fix h
assume h: "h \<in> HomD.set (y, G x)"
hence "\<guillemotleft>\<psi> x (\<psi>D (y, G x) h) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
using x y HomD.\<psi>_mapsto [of y "G x"] \<psi>_mapsto by auto
thus "((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))) h =
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) h"
using x y HomC.\<psi>_\<phi> by simp
qed
qed
finally show ?thesis by auto
qed
moreover have "\<Phi> (y, x) \<cdot>\<^sub>S \<Psi> (y, x) =
S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (\<lambda>h. h)"
proof -
have "\<Phi> (y, x) \<cdot>\<^sub>S \<Psi> (y, x) = S.dom (\<Phi> (y, x) \<cdot>\<^sub>S \<Psi> (y, x))"
using 1 by auto
also have "... = S.dom (\<Psi> (y, x))"
using 1 S.dom_comp by blast
finally show ?thesis using 2 6 S.mkIde_as_mkArr by (elim S.seqE, auto)
qed
ultimately have 4: "S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))
= S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (\<lambda>h. h)"
by auto
have 5: "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)))"
using 1 3 by fastforce
hence "restrict (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (HomD.set (y, G x))
= S.Fun (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)))"
by auto
also have "... = restrict (\<lambda>h. h) (HomD.set (y, G x))"
using 4 5 by auto
finally show ?thesis by auto
qed
moreover have "\<phi>D (y, G x) h \<in> HomD.set (y, G x)"
using x y h HomD.\<phi>_mapsto [of y "G x"] by auto
ultimately have
"\<phi>D (y, G x) h = (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (\<phi>D (y, G x) h)"
by fast
hence "\<psi>D (y, G x) (\<phi>D (y, G x) h) =
\<psi>D (y, G x) ((\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (\<phi>D (y, G x) h))"
by simp
hence "h = \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi> x (\<psi>D (y, G x) (\<phi>D (y, G x) h)))))"
using x y h HomD.\<psi>_\<phi> by simp
also have "... = \<phi> y (\<psi> x h)"
using x y h HomD.\<psi>_\<phi> HomD.\<psi>_\<phi> [of "\<phi> y (\<psi> x h)" y "G x"] \<phi>_mapsto \<psi>_mapsto
by fastforce
finally show ?thesis by auto
qed
next
fix x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
and f :: 'c and g :: 'd and h :: 'c
assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
have x: "C.ide x" using f by auto
have y: "D.ide y" using g by auto
have x': "C.ide x'" using f by auto
have y': "D.ide y'" using g by auto
show "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
proof -
have 0: "restrict ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
(HomC.set (F y, x))
= restrict ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)) o \<psi>C (F y, x))
(HomC.set (F y, x))"
proof -
have 1: "S.arr (\<Phi> (y, x)) \<and>
\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
using x y \<Phi>_simp [of y x] by auto
have 2: "S.arr (\<Phi> (y', x')) \<and>
\<Phi> (y', x') = S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))"
using x' y' \<Phi>_simp [of y' x'] by auto
have 3: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))
\<and> S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
= S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
proof -
have 1: "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
proof -
have "S.arr (Hom_DopxG.map (g, f)) \<and>
Hom_DopxG.map (g, f)
= S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))"
using f g Hom_DopxG.preserves_arr Hom_DopxG_map_simp by fastforce
thus ?thesis
using 1 S.cod_mkArr S.dom_mkArr S.seqI by metis
qed
have "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
using 1 by (intro S.seqI', auto)
moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
= S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
using 1 by fastforce
ultimately show ?thesis by auto
qed
moreover have
4: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))))
\<and> S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
= S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
proof -
have 5: "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
proof -
have "S.arr (Hom_FopxC.map (g, f)) \<and>
Hom_FopxC.map (g, f)
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"
using f g Hom_FopxC.preserves_arr Hom_FopxC_map_simp by fastforce
thus ?thesis using 2 S.cod_mkArr S.dom_mkArr S.seqI by metis
qed
have "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
using 5 by (intro S.seqI', auto)
moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
= S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
using 5 by fastforce
ultimately show ?thesis by argo
qed
moreover have 2:
"S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
= S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
proof -
have
"S (Hom_DopxG.map (g, f)) (\<Phi> (y, x)) = S (\<Phi> (y', x')) (Hom_FopxC.map (g, f))"
using f g \<Phi>.is_natural_1 \<Phi>.is_natural_2 by fastforce
moreover have "Hom_DopxG.map (g, f)
= S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))"
using f g Hom_DopxG_map_simp [of "(g, f)"] by fastforce
moreover have "Hom_FopxC.map (g, f)
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"
using f g Hom_FopxC_map_simp [of "(g, f)"] by fastforce
ultimately show ?thesis using 1 2 3 4 by simp
qed
ultimately have 6: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
by fast
hence "restrict ((\<phi>D (y', G x') o (\<lambda>h. D (G f) (D h g)) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
(HomC.set (F y, x))
= S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
by simp
also have "... = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))))"
using 2 by argo
also have "... = restrict ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
(HomC.set (F y, x))"
using 4 S.Fun_mkArr by meson
finally show ?thesis by auto
qed
hence 5: "((\<phi>D (y', G x') \<circ> (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) \<circ> \<psi>D (y, G x))
\<circ> (\<phi>D (y, G x) \<circ> \<phi> y \<circ> \<psi>C (F y, x))) (\<phi>C (F y, x) h) =
(\<phi>D (y', G x') \<circ> \<phi> y' \<circ> \<psi>C (F y', x')
\<circ> (\<phi>C (F y', x') \<circ> (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)) \<circ> \<psi>C (F y, x)) (\<phi>C (F y, x) h)"
proof -
have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
using x y h HomC.\<phi>_mapsto [of "F y" x] by auto
thus ?thesis
using 0 h restr_eqE [of "(\<phi>D (y', G x') \<circ> (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) \<circ> \<psi>D (y, G x))
\<circ> (\<phi>D (y, G x) \<circ> \<phi> y \<circ> \<psi>C (F y, x))"
"HomC.set (F y, x)"
"(\<phi>D (y', G x') \<circ> \<phi> y' \<circ> \<psi>C (F y', x'))
\<circ> (\<phi>C (F y', x') \<circ> (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"]
by fast
qed
show ?thesis
proof -
have "\<phi> y' (C f (C h (F g))) =
\<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
(C f (C (\<psi>C (F y, x) (\<phi>C (F y, x) h)) (F g)))))))"
proof -
have "\<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
(C f (C (\<psi>C (F y, x) (\<phi>C (F y, x) h)) (F g)))))))
= \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
(C f (C h (F g)))))))"
using x y h HomC.\<psi>_\<phi> by simp
also have "... = \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (C f (C h (F g)))))"
using f g h HomC.\<psi>_\<phi> [of "C f (C h (F g))"] by fastforce
also have "... = \<phi> y' (C f (C h (F g)))"
proof -
have "\<guillemotleft>\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) : y' \<rightarrow>\<^sub>D G x'\<guillemotright>"
using f g h y' x' \<phi>_mapsto [of y' x'] by auto
thus ?thesis by simp
qed
finally show ?thesis by auto
qed
also have
"... = \<psi>D (y', G x')
(\<phi>D (y', G x')
(G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h))))
\<cdot>\<^sub>D g))"
using 5 by force
also have "... = D (G f) (D (\<phi> y h) g)"
proof -
have \<phi>yh: "\<guillemotleft>\<phi> y h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
using x y h \<phi>_mapsto by auto
have "\<psi>D (y', G x')
(\<phi>D (y', G x')
(G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h))))
\<cdot>\<^sub>D g)) =
\<psi>D (y', G x') (\<phi>D (y', G x') (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y h)) \<cdot>\<^sub>D g))"
using x y f g h by auto
also have "... = \<psi>D (y', G x') (\<phi>D (y', G x') (G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g))"
using \<phi>yh x' y' f g by simp
also have "... = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
proof -
have "\<guillemotleft>G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g : y' \<rightarrow>\<^sub>D G x'\<guillemotright>"
using x x' y' f g h \<phi>_mapsto \<phi>yh by blast
thus ?thesis
using x y f g h \<phi>yh HomD.\<psi>_\<phi> by auto
qed
finally show ?thesis by auto
qed
finally show ?thesis by auto
qed
qed
qed
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G \<phi> \<psi>" ..
end
section "Putting it All Together"
text\<open>
Combining the above results, an interpretation of any one of the locales:
\<open>left_adjoint_functor\<close>, \<open>right_adjoint_functor\<close>, \<open>meta_adjunction\<close>,
\<open>hom_adjunction\<close>, and \<open>unit_counit_adjunction\<close> extends to an interpretation
of \<open>adjunction\<close>.
\<close>
context meta_adjunction
begin
interpretation F: left_adjoint_functor D C F using has_left_adjoint_functor by auto
interpretation G: right_adjoint_functor C D G using has_right_adjoint_functor by auto
interpretation \<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon>
- using induces_unit_counit_adjunction by auto
+ using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
interpretation \<Phi>\<Psi>: hom_adjunction C D SetCat.comp \<phi>C \<phi>D F G \<Phi> \<Psi>
using induces_hom_adjunction by auto
theorem induces_adjunction:
shows "adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
apply (unfold_locales)
using \<epsilon>_map_simp \<eta>_map_simp \<phi>_in_terms_of_\<eta> \<phi>_in_terms_of_\<Phi>' \<psi>_in_terms_of_\<epsilon>
- \<psi>_in_terms_of_\<Psi>' \<Phi>_simp \<Psi>_simp
+ \<psi>_in_terms_of_\<Psi>' \<Phi>_simp \<Psi>_simp \<eta>_def \<epsilon>_def
by auto
end
sublocale meta_adjunction \<subseteq> adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>
using induces_adjunction by auto
context unit_counit_adjunction
begin
interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi> using induces_meta_adjunction by auto
interpretation F: left_adjoint_functor D C F using \<phi>\<psi>.has_left_adjoint_functor by auto
interpretation G: right_adjoint_functor C D G using \<phi>\<psi>.has_right_adjoint_functor by auto
abbreviation HomC where "HomC \<equiv> \<phi>\<psi>.HomC"
abbreviation \<phi>C where "\<phi>C \<equiv> \<phi>\<psi>.\<phi>C"
abbreviation HomD where "HomD \<equiv> \<phi>\<psi>.HomD"
abbreviation \<phi>D where "\<phi>D \<equiv> \<phi>\<psi>.\<phi>D"
abbreviation \<Phi> where "\<Phi> \<equiv> \<phi>\<psi>.\<Phi>"
abbreviation \<Psi> where "\<Psi> \<equiv> \<phi>\<psi>.\<Psi>"
interpretation \<Phi>\<Psi>: hom_adjunction C D SetCat.comp \<phi>C \<phi>D F G \<Phi> \<Psi>
using \<phi>\<psi>.induces_hom_adjunction by auto
theorem induces_adjunction:
shows "adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
using \<epsilon>_in_terms_of_\<psi> \<eta>_in_terms_of_\<phi> \<phi>\<psi>.\<phi>_in_terms_of_\<Phi>' \<psi>_def \<phi>\<psi>.\<psi>_in_terms_of_\<Psi>'
\<phi>\<psi>.\<Phi>_simp \<phi>\<psi>.\<Psi>_simp \<phi>_def
apply (unfold_locales)
by auto
end
text\<open>
The following fails, claiming ``roundup bound exceeded'':\\
@{theory_text
"sublocale unit_counit_adjunction \<subseteq> adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>
using induces_adjunction by auto"}
\<close>
context hom_adjunction
begin
interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
using induces_meta_adjunction by auto
interpretation F: left_adjoint_functor D C F using \<phi>\<psi>.has_left_adjoint_functor by auto
interpretation G: right_adjoint_functor C D G using \<phi>\<psi>.has_right_adjoint_functor by auto
abbreviation \<eta> where "\<eta> \<equiv> \<phi>\<psi>.\<eta>"
abbreviation \<epsilon> where "\<epsilon> \<equiv> \<phi>\<psi>.\<epsilon>"
interpretation \<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon>
- using \<phi>\<psi>.induces_unit_counit_adjunction by auto
+ using \<phi>\<psi>.induces_unit_counit_adjunction \<phi>\<psi>.\<eta>_def \<phi>\<psi>.\<epsilon>_def by auto
theorem induces_adjunction:
shows "adjunction C D S \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
proof
fix x
assume "C.ide x"
- thus "\<epsilon> x = \<psi> x (G x)" using \<phi>\<psi>.\<epsilon>_map_simp by blast
+ thus "\<epsilon> x = \<psi> x (G x)" using \<phi>\<psi>.\<epsilon>_map_simp \<phi>\<psi>.\<epsilon>_def by simp
next
fix y
assume "D.ide y"
- thus "\<eta> y = \<phi> y (F y)" using \<phi>\<psi>.\<eta>_map_simp by blast
+ thus "\<eta> y = \<phi> y (F y)" using \<phi>\<psi>.\<eta>_map_simp \<phi>\<psi>.\<eta>_def by simp
fix x y f
assume y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
- show "\<phi> y f = G f \<cdot>\<^sub>D \<eta> y" using y f \<phi>\<psi>.\<phi>_in_terms_of_\<eta> by blast
+ show "\<phi> y f = G f \<cdot>\<^sub>D \<eta> y" using y f \<phi>\<psi>.\<phi>_in_terms_of_\<eta> \<phi>\<psi>.\<eta>_def by simp
show "\<phi> y f = (\<psi>D (y, G x) \<circ> \<Phi>.FUN (y, x) \<circ> \<phi>C (F y, x)) f" using y f \<phi>_def by auto
next
fix x y g
assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
- show "\<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g" using x g \<phi>\<psi>.\<psi>_in_terms_of_\<epsilon> by blast
+ show "\<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g" using x g \<phi>\<psi>.\<psi>_in_terms_of_\<epsilon> \<phi>\<psi>.\<epsilon>_def by simp
show "\<psi> x g = (\<psi>C (F y, x) \<circ> \<Psi>.FUN (y, x) \<circ> \<phi>D (y, G x)) g" using x g \<psi>_def by fast
next
fix x y
assume x: "C.ide x" and y: "D.ide y"
show "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
using x y \<Phi>_simp by simp
show "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
using x y \<Psi>_simp by simp
qed
end
text\<open>
The following fails for unknown reasons:\\
@{theory_text
"sublocale hom_adjunction \<subseteq> adjunction C D S \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>
using induces_adjunction by auto"}
\<close>
context left_adjoint_functor
begin
interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
using induces_meta_adjunction by auto
abbreviation HomC where "HomC \<equiv> \<phi>\<psi>.HomC"
abbreviation \<phi>C where "\<phi>C \<equiv> \<phi>\<psi>.\<phi>C"
abbreviation HomD where "HomD \<equiv> \<phi>\<psi>.HomD"
abbreviation \<phi>D where "\<phi>D \<equiv> \<phi>\<psi>.\<phi>D"
abbreviation \<eta> where "\<eta> \<equiv> \<phi>\<psi>.\<eta>"
abbreviation \<epsilon> where "\<epsilon> \<equiv> \<phi>\<psi>.\<epsilon>"
abbreviation \<Phi> where "\<Phi> \<equiv> \<phi>\<psi>.\<Phi>"
abbreviation \<Psi> where "\<Psi> \<equiv> \<phi>\<psi>.\<Psi>"
theorem induces_adjunction:
shows "adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
using \<phi>\<psi>.induces_adjunction by auto
end
sublocale left_adjoint_functor \<subseteq> adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>
using induces_adjunction by auto
context right_adjoint_functor
begin
interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
using induces_meta_adjunction by auto
abbreviation HomC where "HomC \<equiv> \<phi>\<psi>.HomC"
abbreviation \<phi>C where "\<phi>C \<equiv> \<phi>\<psi>.\<phi>C"
abbreviation HomD where "HomD \<equiv> \<phi>\<psi>.HomD"
abbreviation \<phi>D where "\<phi>D \<equiv> \<phi>\<psi>.\<phi>D"
abbreviation \<eta> where "\<eta> \<equiv> \<phi>\<psi>.\<eta>"
abbreviation \<epsilon> where "\<epsilon> \<equiv> \<phi>\<psi>.\<epsilon>"
abbreviation \<Phi> where "\<Phi> \<equiv> \<phi>\<psi>.\<Phi>"
abbreviation \<Psi> where "\<Psi> \<equiv> \<phi>\<psi>.\<Psi>"
theorem induces_adjunction:
shows "adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
using \<phi>\<psi>.induces_adjunction by auto
end
text\<open>
The following fails, claiming ``roundup bound exceeded'':\\
@{theory_text
"sublocale right_adjoint_functor \<subseteq> adjunction C D SetCat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>
using induces_adjunction by auto"}
\<close>
definition adjoint_functors
where "adjoint_functors C D F G = (\<exists>\<phi> \<psi>. meta_adjunction C D F G \<phi> \<psi>)"
section "Composition of Adjunctions"
locale composite_adjunction =
A: category A +
B: category B +
C: category C +
F: "functor" B A F +
G: "functor" A B G +
F': "functor" C B F' +
G': "functor" B C G' +
FG: meta_adjunction A B F G \<phi> \<psi> +
F'G': meta_adjunction B C F' G' \<phi>' \<psi>'
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and F :: "'b \<Rightarrow> 'a"
and G :: "'a \<Rightarrow> 'b"
and F' :: "'c \<Rightarrow> 'b"
and G' :: "'b \<Rightarrow> 'c"
and \<phi> :: "'b \<Rightarrow> 'a \<Rightarrow> 'b"
and \<psi> :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
and \<phi>' :: "'c \<Rightarrow> 'b \<Rightarrow> 'c"
and \<psi>' :: "'b \<Rightarrow> 'c \<Rightarrow> 'b"
begin
(* Notation for C.in_hom is inherited here somehow, but I don't know from where. *)
lemma is_meta_adjunction:
shows "meta_adjunction A C (F o F') (G' o G) (\<lambda>z. \<phi>' z o \<phi> (F' z)) (\<lambda>x. \<psi> x o \<psi>' (G x))"
proof -
interpret G'oG: composite_functor A B C G G' ..
interpret FoF': composite_functor C B A F' F ..
show ?thesis
proof
fix y f x
assume y: "C.ide y" and f: "\<guillemotleft>f : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
show "\<guillemotleft>(\<phi>' y \<circ> \<phi> (F' y)) f : y \<rightarrow>\<^sub>C G'oG.map x\<guillemotright>"
using y f FG.\<phi>_in_hom F'G'.\<phi>_in_hom by simp
show "(\<psi> x \<circ> \<psi>' (G x)) ((\<phi>' y \<circ> \<phi> (F' y)) f) = f"
using y f FG.\<phi>_in_hom F'G'.\<phi>_in_hom FG.\<psi>_\<phi> F'G'.\<psi>_\<phi> by simp
next
fix x g y
assume x: "A.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>C G'oG.map x\<guillemotright>"
show "\<guillemotleft>(\<psi> x \<circ> \<psi>' (G x)) g : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
using x g FG.\<psi>_in_hom F'G'.\<psi>_in_hom by auto
show "(\<phi>' y \<circ> \<phi> (F' y)) ((\<psi> x \<circ> \<psi>' (G x)) g) = g"
using x g FG.\<psi>_in_hom F'G'.\<psi>_in_hom FG.\<phi>_\<psi> F'G'.\<phi>_\<psi> by simp
next
fix f x x' g y' y h
assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>A x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>C y\<guillemotright>" and h: "\<guillemotleft>h : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
show "(\<phi>' y' \<circ> \<phi> (F' y')) (f \<cdot>\<^sub>A h \<cdot>\<^sub>A FoF'.map g) =
G'oG.map f \<cdot>\<^sub>C (\<phi>' y \<circ> \<phi> (F' y)) h \<cdot>\<^sub>C g"
using f g h FG.\<phi>_naturality [of f x x' "F' g" "F' y'" "F' y" h]
F'G'.\<phi>_naturality [of "G f" "G x" "G x'" g y' y "\<phi> (F' y) h"]
FG.\<phi>_in_hom
by fastforce
qed
qed
- end
-
- sublocale composite_adjunction \<subseteq> meta_adjunction A C "F o F'" "G' o G"
- "\<lambda>z. \<phi>' z o \<phi> (F' z)" "\<lambda>x. \<psi> x o \<psi>' (G x)"
- using is_meta_adjunction by auto
-
- context composite_adjunction
- begin
-
- interpretation K\<eta>H: natural_transformation C C "G' o F'" "G' o G o F o F'" "G' o FG.\<eta> o F'"
+ interpretation K\<eta>H: natural_transformation C C \<open>G' o F'\<close> \<open>G' o G o F o F'\<close> \<open>G' o FG.\<eta> o F'\<close>
proof -
- interpret \<eta>F': horizontal_composite C B B F' F' B.map "G o F" F' FG.\<eta> ..
- interpret G'\<eta>F': horizontal_composite C B C "B.map o F'" "G o F o F'" G' G' \<eta>F'.map G' ..
- have "natural_transformation
- C C (G' o (B.map o F')) (G' o (G o F o F')) (G' o (FG.\<eta> o F'))" ..
- moreover have "G' o (B.map o F') = G' o F'"
- using F'.functor_axioms by auto
- moreover have "G' o (G o F o F') = G' o G o F o F'" by auto
- moreover have "G' o (FG.\<eta> o F') = G' o FG.\<eta> o F'" by auto
- ultimately show
- "natural_transformation C C (G' o F') (G' o G o F o F') (G' o FG.\<eta> o F')"
- by auto
+ interpret \<eta>F': natural_transformation C B F' \<open>(G o F) o F'\<close> \<open>FG.\<eta> o F'\<close>
+ using FG.\<eta>_is_natural_transformation F'.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ interpret G'\<eta>F': natural_transformation C C \<open>G' o F'\<close> \<open>G' o (G o F o F')\<close>
+ \<open>G' o (FG.\<eta> o F')\<close>
+ using \<eta>F'.natural_transformation_axioms G'.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ show "natural_transformation C C (G' o F') (G' o G o F o F') (G' o FG.\<eta> o F')"
+ using G'\<eta>F'.natural_transformation_axioms o_assoc by metis
qed
- interpretation G'\<eta>F'o\<eta>': vertical_composite C C C.map "G' o F'" "G' o G o F o F'"
- F'G'.\<eta> "G' o FG.\<eta> o F'" ..
+ interpretation G'\<eta>F'o\<eta>': vertical_composite C C C.map \<open>G' o F'\<close> \<open>G' o G o F o F'\<close>
+ F'G'.\<eta> \<open>G' o FG.\<eta> o F'\<close> ..
- interpretation F\<epsilon>G: natural_transformation A A "F o F' o G' o G" "F o G" "F o F'G'.\<epsilon> o G"
+ interpretation F\<epsilon>G: natural_transformation A A \<open>F o F' o G' o G\<close> \<open>F o G\<close> \<open>F o F'G'.\<epsilon> o G\<close>
proof -
- interpret F\<epsilon>': horizontal_composite B B A "F' o G'" B.map F F F'G'.\<epsilon> F ..
- interpret F\<epsilon>'G: horizontal_composite A B A G G "F o (F' o G')" "F o B.map" G F\<epsilon>'.map ..
- have "natural_transformation A A (F o (F' o G') o G) (F o B.map o G) F\<epsilon>'G.map" ..
- moreover have "F o B.map o G = F o G"
- proof -
- (* Here F.functor_axioms does not refer to functor F, why? *)
- have "functor B A F" ..
- thus ?thesis using comp_functor_identity by auto
- qed
- moreover have "F o (F' o G') o G = F o F' o G' o G" by auto
- ultimately show
- "natural_transformation A A (F o F' o G' o G) (F o G) (F o F'G'.\<epsilon> o G)"
- by auto
+ interpret F\<epsilon>': natural_transformation B A \<open>F o (F' o G')\<close> F \<open>F o F'G'.\<epsilon>\<close>
+ using F'G'.\<epsilon>.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ interpret F\<epsilon>'G: natural_transformation A A \<open>F o (F' o G') o G\<close> \<open>F o G\<close> \<open>F o F'G'.\<epsilon> o G\<close>
+ using F\<epsilon>'.natural_transformation_axioms G.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ show "natural_transformation A A (F o F' o G' o G) (F o G) (F o F'G'.\<epsilon> o G)"
+ using F\<epsilon>'G.natural_transformation_axioms o_assoc by metis
qed
- interpretation \<epsilon>oF\<epsilon>'G: vertical_composite A A "F \<circ> F' \<circ> G' \<circ> G" "F o G" A.map
- "F o F'G'.\<epsilon> o G" FG.\<epsilon> ..
+ interpretation \<epsilon>oF\<epsilon>'G: vertical_composite A A \<open>F \<circ> F' \<circ> G' \<circ> G\<close> \<open>F o G\<close> A.map
+ \<open>F o F'G'.\<epsilon> o G\<close> FG.\<epsilon> ..
+
+ interpretation meta_adjunction A C \<open>F o F'\<close> \<open>G' o G\<close>
+ \<open>\<lambda>z. \<phi>' z o \<phi> (F' z)\<close> \<open>\<lambda>x. \<psi> x o \<psi>' (G x)\<close>
+ using is_meta_adjunction by auto
lemma \<eta>_char:
shows "\<eta> = G'\<eta>F'o\<eta>'.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation C C C.map (G' o G o F o F') G'\<eta>F'o\<eta>'.map" ..
show "natural_transformation C C C.map (G' o G o F o F') \<eta>"
proof -
have "natural_transformation C C C.map ((G' \<circ> G) \<circ> (F \<circ> F')) \<eta>" ..
moreover have "(G' o G) o (F o F') = G' o G o F o F'" by auto
ultimately show ?thesis by metis
qed
fix a
assume a: "C.ide a"
show "\<eta> a = G'\<eta>F'o\<eta>'.map a"
+ unfolding \<eta>_def
using a G'\<eta>F'o\<eta>'.map_def FG.\<eta>.preserves_hom [of "F' a" "F' a" "F' a"]
- F'G'.\<phi>_in_terms_of_\<eta> FG.\<eta>_map_simp \<eta>_map_simp C.ide_in_hom
+ F'G'.\<phi>_in_terms_of_\<eta> FG.\<eta>_map_simp \<eta>_map_simp [of a] C.ide_in_hom
+ F'G'.\<eta>_def FG.\<eta>_def
by auto
qed
lemma \<epsilon>_char:
shows "\<epsilon> = \<epsilon>oF\<epsilon>'G.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation A A (F o F' o G' o G) A.map \<epsilon>"
proof -
have "natural_transformation A A ((F \<circ> F') \<circ> (G' \<circ> G)) A.map \<epsilon>" ..
moreover have "(F o F') o (G' o G) = F o F' o G' o G" by auto
ultimately show ?thesis by metis
qed
show "natural_transformation A A (F \<circ> F' \<circ> G' \<circ> G) A.map \<epsilon>oF\<epsilon>'G.map" ..
fix a
assume a: "A.ide a"
show "\<epsilon> a = \<epsilon>oF\<epsilon>'G.map a"
proof -
have "\<epsilon> a = \<psi> a (\<psi>' (G a) (G' (G a)))"
using a \<epsilon>_in_terms_of_\<psi> by simp
also have "... = FG.\<epsilon> a \<cdot>\<^sub>A F (F'G'.\<epsilon> (G a) \<cdot>\<^sub>B F' (G' (G a)))"
+ unfolding \<epsilon>_def
using a F'G'.\<psi>_in_terms_of_\<epsilon> [of "G a" "G' (G a)" "G' (G a)"]
F'G'.\<epsilon>.preserves_hom [of "G a" "G a" "G a"]
FG.\<psi>_in_terms_of_\<epsilon> [of a "F'G'.\<epsilon> (G a) \<cdot>\<^sub>B F' (G' (G a))" "(F'G'.FG.map (G a))"]
+ F'G'.\<epsilon>_def FG.\<epsilon>_def
by fastforce
also have "... = \<epsilon>oF\<epsilon>'G.map a"
using a B.comp_arr_dom \<epsilon>oF\<epsilon>'G.map_def by simp
finally show ?thesis by blast
qed
qed
end
section "Right Adjoints are Unique up to Natural Isomorphism"
text\<open>
As an example of the use of the of the foregoing development, we show that two right adjoints
to the same functor are naturally isomorphic.
\<close>
theorem two_right_adjoints_naturally_isomorphic:
assumes "adjoint_functors C D F G" and "adjoint_functors C D F G'"
shows "naturally_isomorphic C D G G'"
proof -
text\<open>
For any object @{term x} of @{term C}, we have that \<open>\<epsilon> x \<in> C.hom (F (G x)) x\<close>
is a terminal arrow from @{term F} to @{term x}, and similarly for \<open>\<epsilon>' x\<close>.
We may therefore obtain the unique coextension \<open>\<tau> x \<in> D.hom (G x) (G' x)\<close>
of \<open>\<epsilon> x\<close> along \<open>\<epsilon>' x\<close>.
An explicit formula for \<open>\<tau> x\<close> is \<open>D (G' (\<epsilon> x)) (\<eta>' (G x))\<close>.
Similarly, we obtain \<open>\<tau>' x = D (G (\<epsilon>' x)) (\<eta> (G' x)) \<in> D.hom (G' x) (G x)\<close>.
We show these are the components of inverse natural transformations between
@{term G} and @{term G'}.
\<close>
obtain \<phi> \<psi> where \<phi>\<psi>: "meta_adjunction C D F G \<phi> \<psi>"
using assms adjoint_functors_def by blast
obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D F G' \<phi>' \<psi>'"
using assms adjoint_functors_def by blast
interpret Adj: meta_adjunction C D F G \<phi> \<psi> using \<phi>\<psi> by auto
interpret
Adj: adjunction C D SetCat.comp Adj.\<phi>C Adj.\<phi>D F G \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
using Adj.induces_adjunction by auto
interpret Adj': meta_adjunction C D F G' \<phi>' \<psi>' using \<phi>'\<psi>' by auto
interpret Adj': adjunction C D SetCat.comp Adj'.\<phi>C Adj'.\<phi>D
F G' \<phi>' \<psi>' Adj'.\<eta> Adj'.\<epsilon> Adj'.\<Phi> Adj'.\<Psi>
using Adj'.induces_adjunction by auto
write C (infixr "\<cdot>\<^sub>C" 55)
write D (infixr "\<cdot>\<^sub>D" 55)
write Adj.C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
write Adj.D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
let ?\<tau>o = "\<lambda>a. G' (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G a)"
interpret \<tau>: transformation_by_components C D G G' ?\<tau>o
proof
show "\<And>a. Adj.C.ide a \<Longrightarrow> \<guillemotleft>G' (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G a) : G a \<rightarrow>\<^sub>D G' a\<guillemotright>"
by fastforce
show "\<And>f. Adj.C.arr f \<Longrightarrow>
(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
proof -
fix f
assume f: "Adj.C.arr f"
let ?x = "Adj.C.dom f"
let ?x' = "Adj.C.cod f"
have "(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
G' (Adj.\<epsilon> (Adj.C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
using f Adj'.\<eta>.naturality [of "G f"] Adj.D.comp_assoc by simp
also have "... = G' (f \<cdot>\<^sub>C Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
using f Adj.\<epsilon>.naturality by simp
also have "... = G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
using f Adj.D.comp_assoc by simp
finally show "(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
by auto
qed
qed
interpret natural_isomorphism C D G G' \<tau>.map
proof
fix a
assume a: "Adj.C.ide a"
show "Adj.D.iso (\<tau>.map a)"
proof
show "Adj.D.inverse_arrows (\<tau>.map a) (\<phi> (G' a) (Adj'.\<epsilon> a))"
proof
text\<open>
The proof that the two composites are identities is a modest diagram chase.
This is a good example of the inference rules for the \<open>category\<close>,
\<open>functor\<close>, and \<open>natural_transformation\<close> locales in action.
Isabelle is able to use the single hypothesis that \<open>a\<close> is an identity to
implicitly fill in all the details that the various quantities are in fact arrows
and that the indicated composites are all well-defined, as well as to apply
associativity of composition. In most cases, this is done by auto or simp without
even mentioning any of the rules that are used.
$$\xymatrix{
{G' a} \ar[dd]_{\eta'(G'a)} \ar[rr]^{\tau' a} \ar[dr]_{\eta(G'a)}
&& {G a} \ar[rr]^{\tau a} \ar[dr]_{\eta'(Ga)} && {G' a} \\
& {GFG'a} \rrtwocell\omit{\omit(2)} \ar[ur]_{G(\epsilon' a)} \ar[dr]_{\eta'(GFG'a)}
&& {G'FGa} \drtwocell\omit{\omit(3)} \ar[ur]_{G'(\epsilon a)} & \\
{G'FG'a} \urtwocell\omit{\omit(1)} \ar[rr]_{G'F\eta(G'a)} \ar@/_8ex/[rrrr]_{G'FG'a}
&& {G'FGFG'a} \dtwocell\omit{\omit(4)} \ar[ru]_{G'FG(\epsilon' a)} \ar[rr]_{G'(\epsilon(FG'a))}
&& {G'FG'a} \ar[uu]_{G'(\epsilon' a)} \\
&&&&
}$$
\<close>
show "Adj.D.ide (\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a))"
proof -
have "\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a) = G' a"
proof -
have "\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a) =
G' (Adj.\<epsilon> a) \<cdot>\<^sub>D (Adj'.\<eta> (G a) \<cdot>\<^sub>D G (Adj'.\<epsilon> a)) \<cdot>\<^sub>D Adj.\<eta> (G' a)"
using a \<tau>.map_simp_ide Adj.\<phi>_in_terms_of_\<eta> Adj'.\<phi>_in_terms_of_\<eta>
Adj'.\<epsilon>.preserves_hom [of a a a] Adj.C.ide_in_hom Adj.D.comp_assoc
- by auto
+ Adj.\<epsilon>_def Adj.\<eta>_def
+ by simp
also have "... = G' (Adj.\<epsilon> a) \<cdot>\<^sub>D (G' (F (G (Adj'.\<epsilon> a))) \<cdot>\<^sub>D Adj'.\<eta> (G (F (G' a)))) \<cdot>\<^sub>D
Adj.\<eta> (G' a)"
using a Adj'.\<eta>.naturality [of "G (Adj'.\<epsilon> a)"] by auto
also have "... = (G' (Adj.\<epsilon> a) \<cdot>\<^sub>D G' (F (G (Adj'.\<epsilon> a)))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) \<cdot>\<^sub>D
Adj'.\<eta> (G' a)"
using a Adj'.\<eta>.naturality [of "Adj.\<eta> (G' a)"] Adj.D.comp_assoc by auto
also have
"... = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D (G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a)))) \<cdot>\<^sub>D
Adj'.\<eta> (G' a)"
proof -
have
"G' (Adj.\<epsilon> a) \<cdot>\<^sub>D G' (F (G (Adj'.\<epsilon> a))) = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D G' (Adj.\<epsilon> (F (G' a)))"
proof -
have "G' (Adj.\<epsilon> a \<cdot>\<^sub>C F (G (Adj'.\<epsilon> a))) = G' (Adj'.\<epsilon> a \<cdot>\<^sub>C Adj.\<epsilon> (F (G' a)))"
using a Adj.\<epsilon>.naturality [of "Adj'.\<epsilon> a"] by auto
thus ?thesis using a by force
qed
thus ?thesis using Adj.D.comp_assoc by auto
qed
also have "... = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G' a)"
proof -
have "G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) = G' (F (G' a))"
proof -
have
"G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) = G' (Adj.\<epsilon>FoF\<eta>.map (G' a))"
using a Adj.\<epsilon>FoF\<eta>.map_simp_1 by auto
moreover have "Adj.\<epsilon>FoF\<eta>.map (G' a) = F (G' a)"
using a by (simp add: Adj.\<eta>\<epsilon>.triangle_F)
ultimately show ?thesis by auto
qed
thus ?thesis
using a Adj.D.comp_cod_arr [of "Adj'.\<eta> (G' a)"] by auto
qed
also have "... = G' a"
using a Adj'.\<eta>\<epsilon>.triangle_G Adj'.G\<epsilon>o\<eta>G.map_simp_1 [of a] by auto
finally show ?thesis by auto
qed
thus ?thesis using a by simp
qed
show "Adj.D.ide (\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a)"
proof -
have "\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a = G a"
proof -
have "\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a =
G (Adj'.\<epsilon> a) \<cdot>\<^sub>D (Adj.\<eta> (G' a) \<cdot>\<^sub>D G' (Adj.\<epsilon> a)) \<cdot>\<^sub>D Adj'.\<eta> (G a)"
using a \<tau>.map_simp_ide Adj.\<phi>_in_terms_of_\<eta> Adj'.\<epsilon>.preserves_hom [of a a a]
- Adj.C.ide_in_hom Adj.D.comp_assoc
+ Adj.C.ide_in_hom Adj.D.comp_assoc Adj.\<eta>_def
by auto
also have
"... = G (Adj'.\<epsilon> a) \<cdot>\<^sub>D (G (F (G' (Adj.\<epsilon> a))) \<cdot>\<^sub>D Adj.\<eta> (G' (F (G a)))) \<cdot>\<^sub>D
Adj'.\<eta> (G a)"
using a Adj.\<eta>.naturality [of "G' (Adj.\<epsilon> a)"] by auto
also have
"... = (G (Adj'.\<epsilon> a) \<cdot>\<^sub>D G (F (G' (Adj.\<epsilon> a)))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) \<cdot>\<^sub>D
Adj.\<eta> (G a)"
using a Adj.\<eta>.naturality [of "Adj'.\<eta> (G a)"] Adj.D.comp_assoc by auto
also have
"... = G (Adj.\<epsilon> a) \<cdot>\<^sub>D (G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a)))) \<cdot>\<^sub>D
Adj.\<eta> (G a)"
proof -
have "G (Adj'.\<epsilon> a) \<cdot>\<^sub>D G (F (G' (Adj.\<epsilon> a))) = G (Adj.\<epsilon> a) \<cdot>\<^sub>D G (Adj'.\<epsilon> (F (G a)))"
proof -
have "G (Adj'.\<epsilon> a \<cdot>\<^sub>C F (G' (Adj.\<epsilon> a))) = G (Adj.\<epsilon> a \<cdot>\<^sub>C Adj'.\<epsilon> (F (G a)))"
using a Adj'.\<epsilon>.naturality [of "Adj.\<epsilon> a"] by auto
thus ?thesis using a by force
qed
thus ?thesis using Adj.D.comp_assoc by auto
qed
also have "... = G (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj.\<eta> (G a)"
proof -
have "G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) = G (F (G a))"
proof -
have
"G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) = G (Adj'.\<epsilon>FoF\<eta>.map (G a))"
using a Adj'.\<epsilon>FoF\<eta>.map_simp_1 [of "G a"] by auto
moreover have "Adj'.\<epsilon>FoF\<eta>.map (G a) = F (G a)"
using a by (simp add: Adj'.\<eta>\<epsilon>.triangle_F)
ultimately show ?thesis by auto
qed
thus ?thesis
using a Adj.D.comp_cod_arr by auto
qed
also have "... = G a"
using a Adj.\<eta>\<epsilon>.triangle_G Adj.G\<epsilon>o\<eta>G.map_simp_1 [of a] by auto
finally show ?thesis by auto
qed
thus ?thesis using a by auto
qed
qed
qed
qed
have "natural_isomorphism C D G G' \<tau>.map" ..
thus "naturally_isomorphic C D G G'"
using naturally_isomorphic_def by blast
qed
end
diff --git a/thys/Category3/BinaryFunctor.thy b/thys/Category3/BinaryFunctor.thy
--- a/thys/Category3/BinaryFunctor.thy
+++ b/thys/Category3/BinaryFunctor.thy
@@ -1,318 +1,318 @@
(* Title: BinaryFunctor
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter BinaryFunctor
theory BinaryFunctor
imports ProductCategory NaturalTransformation
begin
text\<open>
This theory develops various properties of binary functors, which are functors
defined on product categories.
\<close>
locale binary_functor =
A1: category A1 +
A2: category A2 +
B: category B +
A1xA2: product_category A1 A2 +
"functor" A1xA2.comp B F
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a1 * 'a2 \<Rightarrow> 'b"
begin
notation A1.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1 _\<guillemotright>")
notation A2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>2 _\<guillemotright>")
end
text\<open>
A product functor is a binary functor obtained by placing two functors in parallel.
\<close>
locale product_functor =
A1: category A1 +
A2: category A2 +
B1: category B1 +
B2: category B2 +
F1: "functor" A1 B1 F1 +
F2: "functor" A2 B2 F2 +
A1xA2: product_category A1 A2 +
B1xB2: product_category B1 B2
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
and B1 :: "'b1 comp" (infixr "\<cdot>\<^sub>B\<^sub>1" 55)
and B2 :: "'b2 comp" (infixr "\<cdot>\<^sub>B\<^sub>2" 55)
and F1 :: "'a1 \<Rightarrow> 'b1"
and F2 :: "'a2 \<Rightarrow> 'b2"
begin
notation A1xA2.comp (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
notation B1xB2.comp (infixr "\<cdot>\<^sub>B\<^sub>1\<^sub>x\<^sub>B\<^sub>2" 55)
notation A1.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1 _\<guillemotright>")
notation A2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>2 _\<guillemotright>")
notation B1.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B\<^sub>1 _\<guillemotright>")
notation B2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B\<^sub>2 _\<guillemotright>")
notation A1xA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
notation B1xB2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B\<^sub>1\<^sub>x\<^sub>B\<^sub>2 _\<guillemotright>")
definition map
where "map f = (if A1.arr (fst f) \<and> A2.arr (snd f)
then (F1 (fst f), F2 (snd f)) else B1xB2.null)"
lemma map_simp [simp]:
assumes "A1xA2.arr f"
shows "map f = (F1 (fst f), F2 (snd f))"
using assms map_def by simp
lemma is_functor:
shows "functor A1xA2.comp B1xB2.comp map"
using B1xB2.dom_char B1xB2.cod_char
apply (unfold_locales)
using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
apply auto[4]
using A1xA2.seqE map_simp by fastforce
end
sublocale product_functor \<subseteq> "functor" A1xA2.comp B1xB2.comp map
using is_functor by auto
sublocale product_functor \<subseteq> binary_functor A1 A2 B1xB2.comp map ..
text\<open>
A symmetry functor is a binary functor that exchanges its two arguments.
\<close>
locale symmetry_functor =
A1: category A1 +
A2: category A2 +
A1xA2: product_category A1 A2 +
A2xA1: product_category A2 A1
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
begin
notation A1xA2.comp (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
notation A2xA1.comp (infixr "\<cdot>\<^sub>A\<^sub>2\<^sub>x\<^sub>A\<^sub>1" 55)
notation A1xA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
notation A2xA1.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>2\<^sub>x\<^sub>A\<^sub>1 _\<guillemotright>")
definition map :: "'a1 * 'a2 \<Rightarrow> 'a2 * 'a1"
where "map f = (if A1xA2.arr f then (snd f, fst f) else A2xA1.null)"
lemma map_simp [simp]:
assumes "A1xA2.arr f"
shows "map f = (snd f, fst f)"
using assms map_def by meson
lemma is_functor:
shows "functor A1xA2.comp A2xA1.comp map"
using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
apply (unfold_locales)
apply auto[4]
by force
end
sublocale symmetry_functor \<subseteq> "functor" A1xA2.comp A2xA1.comp map
using is_functor by auto
sublocale symmetry_functor \<subseteq> binary_functor A1 A2 A2xA1.comp map ..
context binary_functor
begin
abbreviation sym
where "sym \<equiv> (\<lambda>f. F (snd f, fst f))"
lemma sym_is_binary_functor:
shows "binary_functor A2 A1 B sym"
proof -
interpret A2xA1: product_category A2 A1 ..
interpret S: symmetry_functor A2 A1 ..
interpret SF: composite_functor A2xA1.comp A1xA2.comp B S.map F ..
have "binary_functor A2 A1 B (F o S.map)" ..
moreover have "F o S.map = (\<lambda>f. F (snd f, fst f))"
using is_extensional SF.is_extensional S.map_def by fastforce
ultimately show ?thesis using sym_def by auto
qed
text\<open>
Fixing one or the other argument of a binary functor to be an identity
yields a functor of the other argument.
\<close>
lemma fixing_ide_gives_functor_1:
assumes "A1.ide a1"
shows "functor A2 B (\<lambda>f2. F (a1, f2))"
using assms
apply unfold_locales
using is_extensional
apply auto[4]
by (metis A1.ideD(1) A1.comp_ide_self A1xA2.comp_simp A1xA2.seq_char fst_conv
preserves_comp_2 snd_conv)
lemma fixing_ide_gives_functor_2:
assumes "A2.ide a2"
shows "functor A1 B (\<lambda>f1. F (f1, a2))"
using assms
apply (unfold_locales)
using is_extensional
apply auto[4]
by (metis A1xA2.comp_simp A1xA2.seq_char A2.ideD(1) A2.comp_ide_self fst_conv
preserves_comp_2 snd_conv)
text\<open>
Fixing one or the other argument of a binary functor to be an arrow
yields a natural transformation.
\<close>
lemma fixing_arr_gives_natural_transformation_1:
assumes "A1.arr f1"
shows "natural_transformation A2 B (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2))
(\<lambda>f2. F (f1, f2))"
proof -
let ?Fdom = "\<lambda>f2. F (A1.dom f1, f2)"
interpret Fdom: "functor" A2 B ?Fdom using assms fixing_ide_gives_functor_1 by auto
let ?Fcod = "\<lambda>f2. F (A1.cod f1, f2)"
interpret Fcod: "functor" A2 B ?Fcod using assms fixing_ide_gives_functor_1 by auto
let ?\<tau> = "\<lambda>f2. F (f1, f2)"
show "natural_transformation A2 B ?Fdom ?Fcod ?\<tau>"
using assms
apply unfold_locales
using is_extensional
apply auto[3]
using A1xA2.arr_char preserves_comp A1.comp_cod_arr A1xA2.comp_char A2.comp_arr_dom
apply (metis fst_conv snd_conv)
using A1xA2.arr_char preserves_comp A2.comp_cod_arr A1xA2.comp_char A1.comp_arr_dom
by (metis fst_conv snd_conv)
qed
lemma fixing_arr_gives_natural_transformation_2:
assumes "A2.arr f2"
shows "natural_transformation A1 B (\<lambda>f1. F (f1, A2.dom f2)) (\<lambda>f1. F (f1, A2.cod f2))
(\<lambda>f1. F (f1, f2))"
proof -
interpret F': binary_functor A2 A1 B sym
using assms(1) sym_is_binary_functor by auto
have "natural_transformation A1 B (\<lambda>f1. sym (A2.dom f2, f1)) (\<lambda>f1. sym (A2.cod f2, f1))
(\<lambda>f1. sym (f2, f1))"
using assms F'.fixing_arr_gives_natural_transformation_1 by fast
thus ?thesis by simp
qed
text\<open>
Fixing one or the other argument of a binary functor to be a composite arrow
yields a natural transformation that is a vertical composite.
\<close>
lemma preserves_comp_1:
assumes "A1.seq f1' f1"
shows "(\<lambda>f2. F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2)) =
vertical_composite.map A2 B (\<lambda>f2. F (f1, f2)) (\<lambda>f2. F (f1', f2))"
proof -
- interpret \<tau>: natural_transformation A2 B "\<lambda>f2. F (A1.dom f1, f2)" "\<lambda>f2. F (A1.cod f1, f2)"
- "\<lambda>f2. F (f1, f2)"
+ interpret \<tau>: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
+ \<open>\<lambda>f2. F (f1, f2)\<close>
using assms fixing_arr_gives_natural_transformation_1 by blast
- interpret \<tau>': natural_transformation A2 B "\<lambda>f2. F (A1.cod f1, f2)" "\<lambda>f2. F (A1.cod f1', f2)"
- "\<lambda>f2. F (f1', f2)"
+ interpret \<tau>': natural_transformation A2 B \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1', f2)\<close>
+ \<open>\<lambda>f2. F (f1', f2)\<close>
using assms fixing_arr_gives_natural_transformation_1 A1.seqE by metis
interpret \<tau>'o\<tau>: vertical_composite A2 B
- "\<lambda>f2. F (A1.dom f1, f2)" "\<lambda>f2. F (A1.cod f1, f2)" "\<lambda>f2. F (A1.cod f1', f2)"
- "\<lambda>f2. F (f1, f2)" "\<lambda>f2. F (f1', f2)" ..
+ \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1', f2)\<close>
+ \<open>\<lambda>f2. F (f1, f2)\<close> \<open>\<lambda>f2. F (f1', f2)\<close> ..
show "(\<lambda>f2. F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2)) = \<tau>'o\<tau>.map"
proof
fix f2
have "\<not>A2.arr f2 \<Longrightarrow> F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2"
using \<tau>'o\<tau>.is_extensional is_extensional by simp
moreover have "A2.arr f2 \<Longrightarrow> F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2"
proof -
assume f2: "A2.arr f2"
have "F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = B (F (f1', f2)) (F (f1, A2.dom f2))"
using assms f2 preserves_comp A1xA2.arr_char A1xA2.comp_char A2.comp_arr_dom
by (metis fst_conv snd_conv)
also have "... = \<tau>'o\<tau>.map f2"
using f2 \<tau>'o\<tau>.map_simp_2 by simp
finally show "F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2" by auto
qed
ultimately show "F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2" by blast
qed
qed
lemma preserves_comp_2:
assumes "A2.seq f2' f2"
shows "(\<lambda>f1. F (f1, f2' \<cdot>\<^sub>A\<^sub>2 f2)) =
vertical_composite.map A1 B (\<lambda>f1. F (f1, f2)) (\<lambda>f1. F (f1, f2'))"
proof -
interpret F': binary_functor A2 A1 B sym
using assms(1) sym_is_binary_functor by auto
have "(\<lambda>f1. sym (f2' \<cdot>\<^sub>A\<^sub>2 f2, f1)) =
vertical_composite.map A1 B (\<lambda>f1. sym (f2, f1)) (\<lambda>f1. sym (f2', f1))"
using assms F'.preserves_comp_1 by fastforce
thus ?thesis by simp
qed
end
text\<open>
A binary functor transformation is a natural transformation between binary functors.
We need a certain property of such transformations; namely, that if one or the
other argument is fixed to be an identity, the result is a natural transformation.
\<close>
locale binary_functor_transformation =
A1: category A1 +
A2: category A2 +
B: category B +
A1xA2: product_category A1 A2 +
F: binary_functor A1 A2 B F +
G: binary_functor A1 A2 B G +
natural_transformation A1xA2.comp B F G \<tau>
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a1 * 'a2 \<Rightarrow> 'b"
and G :: "'a1 * 'a2 \<Rightarrow> 'b"
and \<tau> :: "'a1 * 'a2 \<Rightarrow> 'b"
begin
notation A1xA2.comp (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
notation A1xA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
lemma fixing_ide_gives_natural_transformation_1:
assumes "A1.ide a1"
shows "natural_transformation A2 B (\<lambda>f2. F (a1, f2)) (\<lambda>f2. G (a1, f2)) (\<lambda>f2. \<tau> (a1, f2))"
proof -
- interpret Fa1: "functor" A2 B "\<lambda>f2. F (a1, f2)"
+ interpret Fa1: "functor" A2 B \<open>\<lambda>f2. F (a1, f2)\<close>
using assms F.fixing_ide_gives_functor_1 by simp
- interpret Ga1: "functor" A2 B "\<lambda>f2. G (a1, f2)"
+ interpret Ga1: "functor" A2 B \<open>\<lambda>f2. G (a1, f2)\<close>
using assms "G.fixing_ide_gives_functor_1" by simp
show ?thesis
using assms is_extensional is_natural_1 is_natural_2
apply (unfold_locales, auto)
apply (metis A1.ide_char)
by (metis A1.ide_char)
qed
lemma fixing_ide_gives_natural_transformation_2:
assumes "A2.ide a2"
shows "natural_transformation A1 B (\<lambda>f1. F (f1, a2)) (\<lambda>f1. G (f1, a2)) (\<lambda>f1. \<tau> (f1, a2))"
proof -
- interpret Fa2: "functor" A1 B "\<lambda>f1. F (f1, a2)"
+ interpret Fa2: "functor" A1 B \<open>\<lambda>f1. F (f1, a2)\<close>
using assms F.fixing_ide_gives_functor_2 by simp
- interpret Ga2: "functor" A1 B "\<lambda>f1. G (f1, a2)"
+ interpret Ga2: "functor" A1 B \<open>\<lambda>f1. G (f1, a2)\<close>
using assms "G.fixing_ide_gives_functor_2" by simp
show ?thesis
using assms is_extensional is_natural_1 is_natural_2
apply (unfold_locales, auto)
apply (metis A2.ide_char)
by (metis A2.ide_char)
qed
end
end
diff --git a/thys/Category3/Category.thy b/thys/Category3/Category.thy
--- a/thys/Category3/Category.thy
+++ b/thys/Category3/Category.thy
@@ -1,893 +1,626 @@
(* Title: Category
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter "Category"
theory Category
imports Main "HOL-Library.FuncSet"
begin
text \<open>
This theory develops an ``object-free'' definition of category loosely following
\cite{AHS}, Sec. 3.52-3.53.
We define the notion ``category'' in terms of axioms that concern a single
partial binary operation on a type, some of whose elements are to be regarded
as the ``arrows'' of the category.
The nonstandard definition of category has some advantages and disadvantages.
An advantage is that only one piece of data (the composition operation) is required
to specify a category, so the use of records is not required to bundle up several
separate objects. A related advantage is the fact that functors and natural
transformations can be defined simply to be functions that satisfy certain axioms,
rather than more complex composite objects.
One disadvantage is that the notions of ``object'' and ``identity arrow'' are
conflated, though this is easy to get used to. Perhaps a more significant disadvantage
is that each arrow of a category must carry along the information about its domain
and codomain. This implies, for example, that the arrows of a category of sets and
functions cannot be directly identified with functions, but rather only with functions that
have been equipped with their domain and codomain sets.
To represent the partiality of the composition operation of a category, we assume that the
composition for a category has a unique zero element, which we call \<open>null\<close>,
and we consider arrows to be ``composable'' if and only if their composite is non-null.
Functors and natural transformations are required to map arrows to arrows and be
``extensional'' in the sense that they map non-arrows to null. This is so that
equality of functors and natural transformations coincides with their extensional equality
as functions in HOL.
The fact that we co-opt an element of the arrow type to serve as \<open>null\<close> means that
it is not possible to define a category whose arrows exhaust the elements of a given type.
This presents a disadvantage in some situations. For example, we cannot construct a
discrete category whose arrows are directly identified with the set of \emph{all}
elements of a given type @{typ 'a}; instead, we must pass to a larger type
(such as @{typ "'a option"}) so that there is an element available for use as \<open>null\<close>.
The presence of \<open>null\<close>, however, is crucial to our being able to define a
system of introduction and elimination rules that can be applied automatically to establish
that a given expression denotes an arrow. Without \<open>null\<close>, we would be able to
define an introduction rule to infer, say, that the composition of composable arrows
is composable, but not an elimination rule to infer that arrows are composable from
the fact that their composite is an arrow. Having the ability to do both is critical
to the usability of the theory.
\<close>
section "Partial Magmas"
text \<open>
A \emph{partial magma} is a partial binary operation \<open>C\<close> defined on the set
of elements at a type @{typ 'a}. As discussed above,
we assume the existence of a unique element \<open>null\<close> of type @{typ 'a}
that is a zero for \<open>C\<close>, and we use \<open>null\<close> to represent ``undefined''.
We think of the operation \<open>C\<close> as an operation of ``composition'', and
we regard elements \<open>f\<close> and \<open>g\<close> of type @{typ 'a} as \emph{composable}
if \<open>C g f \<noteq> null\<close>.
\<close>
type_synonym 'a comp = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
locale partial_magma =
fixes C :: "'a comp" (infixr "\<cdot>" 55)
assumes ex_un_null: "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
begin
definition null :: 'a
where "null = (THE n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n)"
lemma null_eqI:
assumes "\<And>f. n \<cdot> f = n \<and> f \<cdot> n = n"
shows "n = null"
using assms null_def ex_un_null the1_equality [of "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"]
by auto
lemma comp_null [simp]:
shows "null \<cdot> f = null" and "f \<cdot> null = null"
using null_def ex_un_null theI' [of "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"]
by auto
text \<open>
An \emph{identity} is a self-composable element \<open>a\<close> such that composition of
any other element \<open>f\<close> with \<open>a\<close> on either the left or the right results in
\<open>f\<close> whenever the composition is defined.
\<close>
definition ide
where "ide a \<equiv> a \<cdot> a \<noteq> null \<and>
(\<forall>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f))"
text \<open>
A \emph{domain} of an element \<open>f\<close> is an identity \<open>a\<close> for which composition of
\<open>f\<close> with \<open>a\<close> on the right is defined.
The notion \emph{codomain} is defined similarly, using composition on the left.
Note that, although these definitions are completely dual, the choice of terminology
implies that we will think of composition as being written in traditional order,
as opposed to diagram order. It is pretty much essential to do it this way, to maintain
compatibility with the notation for function application once we start working with
functors and natural transformations.
\<close>
definition domains
where "domains f \<equiv> {a. ide a \<and> f \<cdot> a \<noteq> null}"
definition codomains
where "codomains f \<equiv> {b. ide b \<and> b \<cdot> f \<noteq> null}"
lemma domains_null:
shows "domains null = {}"
by (simp add: domains_def)
lemma codomains_null:
shows "codomains null = {}"
by (simp add: codomains_def)
lemma self_domain_iff_ide:
shows "a \<in> domains a \<longleftrightarrow> ide a"
using ide_def domains_def by auto
lemma self_codomain_iff_ide:
shows "a \<in> codomains a \<longleftrightarrow> ide a"
using ide_def codomains_def by auto
text \<open>
An element \<open>f\<close> is an \emph{arrow} if either it has a domain or it has a codomain.
In an arbitrary partial magma it is possible for \<open>f\<close> to have one but not the other,
but the \<open>category\<close> locale will include assumptions to rule this out.
\<close>
definition arr
where "arr f \<equiv> domains f \<noteq> {} \<or> codomains f \<noteq> {}"
lemma not_arr_null [simp]:
shows "\<not> arr null"
by (simp add: arr_def domains_null codomains_null)
text \<open>
Using the notions of domain and codomain, we can define \emph{homs}.
The predicate @{term "in_hom f a b"} expresses ``@{term f} is an arrow from @{term a}
to @{term b},'' and the term @{term "hom a b"} denotes the set of all such arrows.
It is convenient to have both of these, though passing back and forth sometimes involves
extra work. We choose @{term "in_hom"} as the more fundamental notion.
\<close>
definition in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<equiv> a \<in> domains f \<and> b \<in> codomains f"
abbreviation hom
where "hom a b \<equiv> {f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>}"
lemma arrI:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
shows "arr f"
using assms arr_def in_hom_def by auto
lemma ide_in_hom [intro]:
shows "ide a \<longleftrightarrow> \<guillemotleft>a : a \<rightarrow> a\<guillemotright>"
using self_domain_iff_ide self_codomain_iff_ide in_hom_def ide_def by fastforce
text \<open>
Arrows @{term "f"} @{term "g"} for which the composite @{term "g \<cdot> f"} is defined
are \emph{sequential}.
\<close>
abbreviation seq
where "seq g f \<equiv> arr (g \<cdot> f)"
lemma comp_arr_ide:
assumes "ide a" and "seq f a"
shows "f \<cdot> a = f"
using assms ide_in_hom ide_def not_arr_null by metis
lemma comp_ide_arr:
assumes "ide b" and "seq b f"
shows "b \<cdot> f = f"
using assms ide_in_hom ide_def not_arr_null by metis
text \<open>
The \emph{domain} of an arrow @{term f} is an element chosen arbitrarily from the
set of domains of @{term f} and the \emph{codomain} of @{term f} is an element chosen
arbitrarily from the set of codomains.
\<close>
definition dom
where "dom f = (if domains f \<noteq> {} then (SOME a. a \<in> domains f) else null)"
definition cod
where "cod f = (if codomains f \<noteq> {} then (SOME b. b \<in> codomains f) else null)"
lemma dom_null [simp]:
shows "dom null = null"
by (simp add: dom_def domains_null)
lemma cod_null [simp]:
shows "cod null = null"
by (simp add: cod_def codomains_null)
lemma dom_in_domains:
assumes "domains f \<noteq> {}"
shows "dom f \<in> domains f"
using assms dom_def someI [of "\<lambda>a. a \<in> domains f"] by auto
lemma cod_in_codomains:
assumes "codomains f \<noteq> {}"
shows "cod f \<in> codomains f"
using assms cod_def someI [of "\<lambda>b. b \<in> codomains f"] by auto
end
section "Categories"
text\<open>
A \emph{category} is defined to be a partial magma whose composition satisfies an
extensionality condition, an associativity condition, and the requirement that every
arrow have both a domain and a codomain.
The associativity condition involves four ``matching conditions''
(\<open>match_1\<close>, \<open>match_2\<close>, \<open>match_3\<close>, and \<open>match_4\<close>)
which constrain the domain of definition of the composition, and a fifth condition
(\<open>comp_assoc'\<close>) which states that the results of the two ways of composing
three elements are equal. In the presence of the \<open>comp_assoc'\<close> axiom
\<open>match_4\<close> can be derived from \<open>match_3\<close> and vice versa.
\<close>
locale category = partial_magma +
assumes ext: "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
and has_domain_iff_has_codomain: "domains f \<noteq> {} \<longleftrightarrow> codomains f \<noteq> {}"
and match_1: "\<lbrakk> seq h g; seq (h \<cdot> g) f \<rbrakk> \<Longrightarrow> seq g f"
and match_2: "\<lbrakk> seq h (g \<cdot> f); seq g f \<rbrakk> \<Longrightarrow> seq h g"
and match_3: "\<lbrakk> seq g f; seq h g \<rbrakk> \<Longrightarrow> seq (h \<cdot> g) f"
and comp_assoc': "\<lbrakk> seq g f; seq h g \<rbrakk> \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
begin
text\<open>
Associativity of composition holds unconditionally. This was not the case in
previous, weaker versions of this theory, and I did not notice this for some
time after updating to the current axioms. It is obviously an advantage that
no additional hypotheses have to be verified in order to apply associativity,
but a disadvantage is that this fact is now ``too readily applicable,''
so that if it is made a default simplification it tends to get in the way of
applying other simplifications that we would also like to be able to apply automatically.
So, it now seems best not to make this fact a default simplification, but rather
to invoke it explicitly where it is required.
\<close>
lemma comp_assoc:
shows "(h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
- proof -
- have "seq g f \<and> seq h g \<Longrightarrow> ?thesis"
- using comp_assoc' by simp
- moreover have "\<not> (seq g f \<and> seq h g) \<Longrightarrow> ?thesis"
- using ext by (metis comp_null match_1 match_2)
- ultimately show ?thesis by blast
- qed
+ by (metis comp_assoc' ex_un_null ext match_1 match_2)
lemma match_4:
assumes "seq g f" and "seq h g"
shows "seq h (g \<cdot> f)"
using assms match_3 comp_assoc by auto
lemma domains_comp:
assumes "seq g f"
shows "domains (g \<cdot> f) = domains f"
proof -
have "domains (g \<cdot> f) = {a. ide a \<and> seq (g \<cdot> f) a}"
using domains_def ext by auto
also have "... = {a. ide a \<and> seq f a}"
using assms ide_def match_1 match_3 by meson
also have "... = domains f"
using domains_def ext by auto
finally show ?thesis by blast
qed
lemma codomains_comp:
assumes "seq g f"
shows "codomains (g \<cdot> f) = codomains g"
proof -
have "codomains (g \<cdot> f) = {b. ide b \<and> seq b (g \<cdot> f)}"
using codomains_def ext by auto
also have "... = {b. ide b \<and> seq b g}"
using assms ide_def match_2 match_4 by meson
also have "... = codomains g"
using codomains_def ext by auto
finally show ?thesis by blast
qed
lemma has_domain_iff_arr:
shows "domains f \<noteq> {} \<longleftrightarrow> arr f"
by (simp add: arr_def has_domain_iff_has_codomain)
lemma has_codomain_iff_arr:
shows "codomains f \<noteq> {} \<longleftrightarrow> arr f"
using has_domain_iff_arr has_domain_iff_has_codomain by auto
text\<open>
A consequence of the category axioms is that domains and codomains, if they exist,
are unique.
\<close>
lemma domain_unique:
assumes "a \<in> domains f" and "a' \<in> domains f"
shows "a = a'"
proof -
have "ide a \<and> seq f a \<and> ide a' \<and> seq f a'"
using assms domains_def ext by force
- then show ?thesis
+ thus ?thesis
using match_1 ide_def not_arr_null by metis
qed
lemma codomain_unique:
assumes "b \<in> codomains f" and "b' \<in> codomains f"
shows "b = b'"
proof -
have "ide b \<and> seq b f \<and> ide b' \<and> seq b' f"
using assms codomains_def ext by force
thus ?thesis
using match_2 ide_def not_arr_null by metis
qed
lemma domains_char:
assumes "arr f"
shows "domains f = {dom f}"
using assms dom_in_domains has_domain_iff_arr domain_unique by auto
lemma codomains_char:
assumes "arr f"
shows "codomains f = {cod f}"
using assms cod_in_codomains has_codomain_iff_arr codomain_unique by auto
text\<open>
A consequence of the following lemma is that the notion @{term "arr"} is redundant,
given @{term "in_hom"}, @{term "dom"}, and @{term "cod"}. However, I have retained it
because I have not been able to find a set of usefully powerful simplification rules
expressed only in terms of @{term "in_hom"} that does not result in looping in many
situations.
\<close>
lemma arr_iff_in_hom:
shows "arr f \<longleftrightarrow> \<guillemotleft>f : dom f \<rightarrow> cod f\<guillemotright>"
using cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr in_hom_def
by auto
lemma in_homI [intro]:
assumes "arr f" and "dom f = a" and "cod f = b"
shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
using assms cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr
in_hom_def
by auto
lemma in_homE [elim]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
and "arr f \<Longrightarrow> dom f = a \<Longrightarrow> cod f = b \<Longrightarrow> T"
shows "T"
using assms in_hom_def domains_char codomains_char has_domain_iff_arr
by (metis empty_iff singleton_iff)
text\<open>
To obtain the ``only if'' direction in the next two results and in similar results later
for composition and the application of functors and natural transformations,
is the reason for assuming the existence of @{term null} as a special element of the
arrow type, as opposed to, say, using option types to represent partiality.
The presence of @{term null} allows us not only to make the ``upward'' inference that
the domain of an arrow is again an arrow, but also to make the ``downward'' inference
that if @{term "dom f"} is an arrow then so is @{term f}. Similarly, we will be able
to infer not only that if @{term f} and @{term g} are composable arrows then
@{term "C g f"} is an arrow, but also that if @{term "C g f"} is an arrow then
\<open>f\<close> and \<open>g\<close> are composable arrows. These inferences allow most necessary
facts about what terms denote arrows to be deduced automatically from minimal
assumptions. Typically all that is required is to assume or establish that certain
terms denote arrows in particular homs at the point where those terms are first
introduced, and then similar facts about related terms can be derived automatically.
Without this feature, nearly every proof would involve many tedious additional steps
to establish that each of the terms appearing in the proof (including all its subterms)
in fact denote arrows.
\<close>
lemma arr_dom_iff_arr:
shows "arr (dom f) \<longleftrightarrow> arr f"
using dom_def dom_in_domains has_domain_iff_arr self_domain_iff_ide domains_def
by fastforce
lemma arr_cod_iff_arr:
shows "arr (cod f) \<longleftrightarrow> arr f"
using cod_def cod_in_codomains has_codomain_iff_arr self_codomain_iff_ide codomains_def
by fastforce
lemma arr_dom [simp]:
assumes "arr f"
shows "arr (dom f)"
using assms arr_dom_iff_arr by simp
lemma arr_cod [simp]:
assumes "arr f"
shows "arr (cod f)"
using assms arr_cod_iff_arr by simp
lemma seqI [simp]:
assumes "arr f" and "arr g" and "dom g = cod f"
shows "seq g f"
proof -
have "ide (cod f) \<and> seq (cod f) f"
using assms(1) has_codomain_iff_arr codomains_def cod_in_codomains ext by blast
moreover have "ide (cod f) \<and> seq g (cod f)"
- using assms(2) assms(3) domains_def domains_char ext by fastforce
+ using assms(2-3) domains_def domains_char ext by fastforce
ultimately show ?thesis
using match_4 ide_def ext by metis
qed
+ text \<open>
+ This version of \<open>seqI\<close> is useful as an introduction rule, but not as useful
+ as a simplification, because it requires finding the intermediary term \<open>b\<close>.
+ Sometimes \emph{auto} is able to do this, but other times it is more expedient
+ just to invoke this rule and fill in the missing terms manually, especially
+ when dealing with a chain of compositions.
+ \<close>
+
lemma seqI' [intro]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
shows "seq g f"
using assms by fastforce
lemma compatible_iff_seq:
shows "domains g \<inter> codomains f \<noteq> {} \<longleftrightarrow> seq g f"
proof
show "domains g \<inter> codomains f \<noteq> {} \<Longrightarrow> seq g f"
using cod_in_codomains dom_in_domains empty_iff has_domain_iff_arr has_codomain_iff_arr
domain_unique codomain_unique
by (metis Int_emptyI seqI)
show "seq g f \<Longrightarrow> domains g \<inter> codomains f \<noteq> {}"
proof -
assume gf: "seq g f"
have 1: "cod f \<in> codomains f"
using gf has_domain_iff_arr domains_comp cod_in_codomains codomains_char by blast
have "ide (cod f) \<and> seq (cod f) f"
using 1 codomains_def ext by auto
hence "seq g (cod f)"
using gf has_domain_iff_arr match_2 domains_null ide_def by metis
thus ?thesis
using domains_def 1 codomains_def by auto
qed
qed
text\<open>
The following is another example of a crucial ``downward'' rule that would not be possible
without a reserved @{term null} value.
\<close>
lemma seqE [elim]:
assumes "seq g f"
and "arr f \<Longrightarrow> arr g \<Longrightarrow> dom g = cod f \<Longrightarrow> T"
shows "T"
using assms cod_in_codomains compatible_iff_seq has_domain_iff_arr has_codomain_iff_arr
domains_comp codomains_comp domains_char codomain_unique
by (metis Int_emptyI singletonD)
lemma comp_in_homI [intro]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
proof
show 1: "seq g f" using assms compatible_iff_seq by blast
show "dom (g \<cdot> f) = a"
using assms 1 domains_comp domains_char by blast
show "cod (g \<cdot> f) = c"
using assms 1 codomains_comp codomains_char by blast
qed
lemma comp_in_homE [elim]:
assumes "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
obtains b where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
using assms in_hom_def domains_comp codomains_comp
by (metis arrI in_homI seqE)
lemma comp_in_hom_simp [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> cod f\<guillemotright>" and "\<guillemotleft>g : cod f \<rightarrow> c\<guillemotright>"
shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
using assms by auto
lemma comp_in_hom_simp' [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> dom g\<guillemotright>" and "\<guillemotleft>g : dom g \<rightarrow> c\<guillemotright>"
shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
using assms by auto
+ text \<open>
+ The next two rules are useful as simplifications, but they slow down the
+ simplifier too much to use them by default. So it is necessary to guess when
+ they are needed and cite them explicitly. This is usually not too difficult.
+ \<close>
+
lemma comp_arr_dom:
assumes "arr f" and "dom f = a"
shows "f \<cdot> a = f"
using assms dom_in_domains has_domain_iff_arr domains_def ide_def by auto
lemma comp_cod_arr:
assumes "arr f" and "cod f = b"
shows "b \<cdot> f = f"
using assms cod_in_codomains has_codomain_iff_arr ide_def codomains_def by auto
lemma ide_char:
shows "ide a \<longleftrightarrow> arr a \<and> dom a = a \<and> cod a = a"
using ide_in_hom by auto
+ text \<open>
+ In some contexts, this rule causes the simplifier to loop, but it is too useful
+ not to have as a default simplification. In cases where it is a problem, usually
+ a method like \emph{blast} or \emph{force} will succeed if this rule is cited
+ explicitly.
+ \<close>
+
lemma ideD [simp]:
assumes "ide a"
shows "arr a" and "dom a = a" and "cod a = a"
using assms ide_char by auto
lemma ide_dom [simp]:
assumes "arr f"
shows "ide (dom f)"
using assms dom_in_domains has_domain_iff_arr domains_def by auto
lemma ide_cod [simp]:
assumes "arr f"
shows "ide (cod f)"
using assms cod_in_codomains has_codomain_iff_arr codomains_def by auto
lemma dom_eqI:
assumes "ide a" and "seq f a"
shows "dom f = a"
using assms cod_in_codomains codomain_unique ide_char
by (metis seqE)
lemma cod_eqI:
assumes "ide b" and "seq b f"
shows "cod f = b"
using assms dom_in_domains domain_unique ide_char
by (metis seqE)
lemma ide_char':
shows "ide a \<longleftrightarrow> arr a \<and> (dom a = a \<or> cod a = a)"
- proof -
- have "arr a \<and> dom a = a \<Longrightarrow> ide a"
- using ide_dom [of a] by simp
- moreover have "arr a \<and> cod a = a \<Longrightarrow> ide a"
- using ide_cod [of a] by simp
- ultimately show ?thesis by fastforce
- qed
+ using ide_dom ide_cod ide_char by metis
- lemma dom_dom [simp]:
+ lemma dom_dom:
assumes "arr f"
shows "dom (dom f) = dom f"
- proof -
- have "ide (dom f)" using assms by simp
- thus ?thesis by auto
- qed
+ using assms by simp
- lemma cod_cod [simp]:
+ lemma cod_cod:
assumes "arr f"
shows "cod (cod f) = cod f"
- proof -
- have "ide (cod f)" using assms by simp
- thus ?thesis by auto
- qed
+ using assms by simp
- lemma dom_cod [simp]:
+ lemma dom_cod:
assumes "arr f"
shows "dom (cod f) = cod f"
- proof -
- have "ide (cod f)" using assms by simp
- thus ?thesis by auto
- qed
+ using assms by simp
- lemma cod_dom [simp]:
+ lemma cod_dom:
assumes "arr f"
shows "cod (dom f) = dom f"
- proof -
- have "ide (dom f)" using assms by simp
- thus ?thesis by auto
- qed
+ using assms by simp
lemma dom_comp [simp]:
assumes "seq g f"
shows "dom (g \<cdot> f) = dom f"
using assms by (simp add: dom_def domains_comp)
lemma cod_comp [simp]:
assumes "seq g f"
shows "cod (g \<cdot> f) = cod g"
using assms by (simp add: cod_def codomains_comp)
lemma comp_ide_self [simp]:
assumes "ide a"
shows "a \<cdot> a = a"
using assms comp_arr_ide arrI by auto
lemma ide_compE [elim]:
assumes "ide (g \<cdot> f)"
and "seq g f \<Longrightarrow> seq f g \<Longrightarrow> g \<cdot> f = dom f \<Longrightarrow> g \<cdot> f = cod g \<Longrightarrow> T"
shows "T"
- proof -
- have "g \<cdot> f = dom f \<and> g \<cdot> f = cod g"
- using assms by (metis dom_comp cod_comp ide_char)
- thus ?thesis
- using assms ide_in_hom using seqI' by blast
- qed
+ using assms dom_comp cod_comp ide_char ide_in_hom
+ by (metis seqE seqI)
text \<open>
The next two results are sometimes useful for performing manipulations at the
head of a chain of composed arrows. I have adopted the convention that such
chains are canonically represented in right-associated form. This makes it
easy to perform manipulations at the ``tail'' of a chain, but more difficult
to perform them at the ``head''. These results take care of the rote manipulations
using associativity that are needed to either permute or combine arrows at the
head of a chain.
\<close>
lemma comp_permute:
assumes "f \<cdot> g = k \<cdot> l" and "seq f g" and "seq g h"
shows "f \<cdot> g \<cdot> h = k \<cdot> l \<cdot> h"
using assms by (metis comp_assoc)
lemma comp_reduce:
assumes "f \<cdot> g = k" and "seq f g" and "seq g h"
shows "f \<cdot> g \<cdot> h = k \<cdot> h"
using assms comp_assoc by auto
text\<open>
Here we define some common configurations of arrows.
These are defined as abbreviations, because we want all ``diagrammatic'' assumptions
in a theorem to reduce readily to a conjunction of assertions of the basic forms
@{term "arr f"}, @{term "dom f = X"}, @{term "cod f = Y"}, and @{term "in_hom f a b"}.
\<close>
abbreviation endo
where "endo f \<equiv> seq f f"
abbreviation antipar
where "antipar f g \<equiv> seq g f \<and> seq f g"
abbreviation span
where "span f g \<equiv> arr f \<and> arr g \<and> dom f = dom g"
abbreviation cospan
where "cospan f g \<equiv> arr f \<and> arr g \<and> cod f = cod g"
abbreviation par
where "par f g \<equiv> arr f \<and> arr g \<and> dom f = dom g \<and> cod f = cod g"
end
- section "Classical Categories"
-
- text\<open>
- In this section we define a secondary axiomatization of categories, \<open>classical_category\<close>,
- which is a more traditional one, except that in view of the totality of functions in HOL
- we need to introduce predicates \<open>Obj\<close> and \<open>Arr\<close> that characterize the bona fide
- objects and arrows among the elements of their respective types.
- A category defined this way is not ``extensional'', in the sense that there
- will in general be categories with the same sets of objects and arrows,
- such that \<open>Dom\<close>, \<open>Cod\<close>, \<open>Id\<close>, and \<open>Comp\<close> agree on these
- objects and arrows, but they do not necessarily agree on other values of the corresponding
- types.
-
- We show below that an interpretation of the \<open>category\<close> induces an interpretation
- of the \<open>classical_category\<close> locale.
- Conversely, we show that if \<open>Obj\<close>, \<open>Arr\<close>, \<open>Dom\<close>, \<open>Cod\<close>,
- \<open>Id\<close>, and \<open>Comp\<close> comprise an interpretation of \<open>classical_category\<close>,
- then we can define from them a partial composition that interprets the \<open>category\<close> locale.
- Moreover, the predicate derived \<open>arr\<close> derived from this partial composition agrees
- with the originally given predicate \<open>Arr\<close>, the notions \<open>dom\<close>, \<open>cod\<close>,
- and \<open>comp\<close> derived from the partial composition agree with the originally given
- \<open>Dom\<close>, \<open>Cod\<close>, and \<open>Comp\<close> on arguments that satisfy \<open>arr\<close>,
- and the identities derived from the partial composition are in bijective correspondence with
- the elements that satisfy the originally given predicate \<open>Obj\<close>.
-
- In some cases, rather than defining a construction on categories directly
- in terms of the partial-composition-based axioms, it can be simpler to
- define the construction in classical terms in a convenient way, and then
- extract a partial composition via the construction given here.
-\<close>
-
- locale classical_category =
- fixes Obj :: "'obj \<Rightarrow> bool"
- and Arr :: "'arr \<Rightarrow> bool"
- and Dom :: "'arr \<Rightarrow> 'obj"
- and Cod :: "'arr \<Rightarrow> 'obj"
- and Id :: "'obj \<Rightarrow> 'arr"
- and Comp :: "'arr \<Rightarrow> 'arr \<Rightarrow> 'arr"
- assumes Obj_Dom: "Arr f \<Longrightarrow> Obj (Dom f)"
- and Obj_Cod: "Arr f \<Longrightarrow> Obj (Cod f)"
- and Arr_Id [simp]: "Obj a \<Longrightarrow> Arr (Id a)"
- and Dom_Id [simp]: "Obj a \<Longrightarrow> Dom (Id a) = a"
- and Cod_Id [simp]: "Obj a \<Longrightarrow> Cod (Id a) = a"
- and Arr_Comp [simp]: "\<lbrakk> Arr f; Arr g; Cod f = Dom g \<rbrakk> \<Longrightarrow> Arr (Comp g f)"
- and Comp_assoc [simp]: "\<lbrakk> Arr f; Arr g; Arr h; Cod f = Dom g; Cod g = Dom h \<rbrakk>
- \<Longrightarrow> Comp (Comp h g) f = Comp h (Comp g f)"
- and Dom_Comp [simp]: "\<lbrakk> Arr f; Arr g; Cod f = Dom g \<rbrakk> \<Longrightarrow> Dom (Comp g f) = Dom f"
- and Cod_Comp [simp]: "\<lbrakk> Arr f; Arr g; Cod f = Dom g \<rbrakk> \<Longrightarrow> Cod (Comp g f) = Cod g"
- and Comp_Arr_Id_Dom [simp]: "Arr f \<Longrightarrow> Comp f (Id (Dom f)) = f"
- and Comp_Id_Cod_Arr [simp]: "Arr f \<Longrightarrow> Comp (Id (Cod f)) f = f"
- begin
-
- abbreviation Seq
- where "Seq g f \<equiv> (Arr f \<and> Arr g \<and> Cod f = Dom g)"
-
- text\<open>
- Because @{term Arr} might be the universal predicate for type @{typ 'arr},
- it is necessary to pass to type @{typ "'arr option"} in order to have a value
- available to serve as \<open>null\<close>.
-\<close>
-
- definition comp :: "'arr option \<Rightarrow> 'arr option \<Rightarrow> 'arr option"
- where "comp g f = (if f \<noteq> None \<and> g \<noteq> None \<and> Seq (the g) (the f)
- then Some (Comp (the g) (the f)) else None)"
-
- interpretation C: partial_magma comp
- proof
- show "\<exists>!n. \<forall>f. comp n f = n \<and> comp f n = n"
- proof
- show "\<forall>f. comp None f = None \<and> comp f None = None"
- using comp_def by auto
- show "\<And>n. \<forall>f. comp n f = n \<and> comp f n = n \<Longrightarrow> n = None"
- by (metis comp_def)
- qed
- qed
-
- lemma null_char:
- shows "C.null = None"
- proof -
- let ?P = "\<lambda>n. \<forall>f. comp n f = n \<and> comp f n = n"
- have "?P None" using comp_def by auto
- hence "(THE n. ?P n) = None"
- using C.ex_un_null the1_equality [of ?P] by simp
- thus ?thesis using C.null_def by auto
- qed
-
- lemma ide_Some_Id:
- assumes "Obj A"
- shows "C.ide (Some (Id A))"
- proof -
- have "\<And>f. comp f (Some (Id A)) \<noteq> C.null \<Longrightarrow> comp f (Some (Id A)) = f"
- using assms comp_def null_char by auto
- moreover have "\<And>f. comp (Some (Id A)) f \<noteq> C.null \<Longrightarrow> comp (Some (Id A)) f = f"
- using assms comp_def null_char by auto
- ultimately show ?thesis
- using assms C.ide_def comp_def null_char by auto
- qed
-
- lemma has_domain_char:
- shows "C.domains f \<noteq> {} \<longleftrightarrow> f \<noteq> None \<and> Arr (the f)"
- proof
- assume f: "C.domains f \<noteq> {}"
- show "f \<noteq> None \<and> Arr (the f)"
- using f Collect_empty_eq comp_def null_char C.domains_def by fastforce
- next
- assume f: "f \<noteq> None \<and> Arr (the f)"
- have "Some (Id (Dom (the f))) \<in> C.domains f"
- using f C.domains_def Obj_Dom comp_def null_char ide_Some_Id by auto
- thus "C.domains f \<noteq> {}" by blast
- qed
-
- lemma has_codomain_char:
- shows "C.codomains f \<noteq> {} \<longleftrightarrow> f \<noteq> None \<and> Arr (the f)"
- proof
- assume f: "C.codomains f \<noteq> {}"
- show "f \<noteq> None \<and> Arr (the f)"
- using f Collect_empty_eq comp_def null_char C.codomains_def by fastforce
- next
- assume f: "f \<noteq> None \<and> Arr (the f)"
- have "Some (Id (Cod (the f))) \<in> C.codomains f"
- using f C.codomains_def Obj_Cod comp_def null_char ide_Some_Id by auto
- thus "C.codomains f \<noteq> {}" by blast
- qed
-
- lemma arr_char:
- shows "C.arr f \<longleftrightarrow> f \<noteq> None \<and> Arr (the f)"
- using has_domain_char has_codomain_char
- by (simp add: C.arr_def)
-
- lemma comp_simp:
- assumes "comp g f \<noteq> C.null"
- shows "comp g f = Some (Comp (the g) (the f))"
- using assms by (metis comp_def null_char)
-
- interpretation C: category comp
- proof
- fix f g h
- show 1: "C.domains f \<noteq> {} \<longleftrightarrow> C.codomains f \<noteq> {}"
- proof
- assume f: "C.domains f \<noteq> {}"
- obtain a where a: "a \<in> C.domains f" using f by blast
- have "Some (Id (Cod (the f))) \<in> C.codomains f"
- using a f C.codomains_def Obj_Cod has_domain_char comp_def null_char ide_Some_Id
- by auto
- thus "C.codomains f \<noteq> {}" by blast
- next
- assume f: "C.codomains f \<noteq> {}"
- obtain b where b: "b \<in> C.codomains f" using f by blast
- have "Some (Id (Dom (the f))) \<in> C.domains f"
- using b f C.domains_def Obj_Dom has_codomain_char comp_def null_char ide_Some_Id
- by auto
- thus "C.domains f \<noteq> {}" by blast
- qed
- show "comp g f \<noteq> C.null \<Longrightarrow> C.seq g f"
- using has_codomain_char null_char comp_def C.arr_def C.not_arr_null by auto
- show "C.seq h g \<Longrightarrow> C.seq (comp h g) f \<Longrightarrow> C.seq g f"
- by (metis Arr_Comp C.arr_def Dom_Comp has_codomain_char comp_def option.sel
- option.simps(3))
- show "C.seq h (comp g f) \<Longrightarrow> C.seq g f \<Longrightarrow> C.seq h g"
- by (metis Arr_Comp C.arr_def Cod_Comp has_domain_char comp_def option.sel
- option.simps(3))
- show "C.seq g f \<Longrightarrow> C.seq h g \<Longrightarrow> C.seq (comp h g) f"
- by (metis Arr_Comp C.arr_def Dom_Comp has_codomain_char comp_def option.sel
- option.simps(3))
- thus "C.seq g f \<Longrightarrow> C.seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
- by (metis (no_types, lifting) C.arr_def Cod_Comp Comp_assoc has_domain_char
- has_codomain_char comp_def option.sel)
- qed
-
- theorem induces_category:
- shows "category comp" ..
-
- text\<open>
- The arrows of the classical category are in bijective correspondence with the
- arrows of the category defined by @{term comp}, and the originally given
- @{term Dom}, @{term Cod}, and @{term Comp} coincide along this bijection with
- @{term C.dom}, @{term C.cod}, and @{term comp}.
-\<close>
-
- lemma bij_betw_Arr_arr:
- shows "bij_betw Some (Collect Arr) (Collect C.arr)"
- using C.has_codomain_iff_arr has_codomain_char C.not_arr_null null_char
- apply (intro bij_betwI) apply auto
- apply fastforce
- by (metis option.collapse)
-
- lemma dom_char:
- shows "C.dom f = (if C.arr f then Some (Id (Dom (the f))) else None)"
- proof (cases "C.arr f")
- assume f: "C.arr f"
- hence "C.dom f = Some (Id (Dom (the f)))"
- using Obj_Dom arr_char ide_Some_Id arr_char comp_def
- by (intro C.dom_eqI, auto)
- thus ?thesis using f by auto
- next
- assume "\<not>C.arr f"
- thus ?thesis
- using C.dom_def null_char C.has_domain_iff_arr by metis
- qed
-
- lemma cod_char:
- shows "C.cod f = (if C.arr f then Some (Id (Cod (the f))) else None)"
- proof (cases "C.arr f")
- assume f: "C.arr f"
- hence "C.cod f = Some (Id (Cod (the f)))"
- using dom_char C.has_domain_iff_arr has_domain_char comp_def
- by (metis C.comp_cod_arr C.dom_cod)
- thus ?thesis using f by auto
- next
- assume "\<not>C.arr f"
- thus ?thesis
- using C.cod_def null_char C.has_codomain_iff_arr by metis
- qed
-
- lemma comp_char:
- shows "comp g f = (if f \<noteq> None \<and> g \<noteq> None \<and> Seq (the g) (the f)
- then Some (Comp (the g) (the f)) else None)"
- using comp_def by simp
-
- lemma ide_char:
- shows "C.ide a \<longleftrightarrow> Arr (the a) \<and> a = Some (Id (Dom (the a)))"
- using C.ide_dom arr_char dom_char C.ide_in_hom by fastforce
-
- text\<open>
- The objects of the classical category are in bijective correspondence with
- the identities of the category defined by comp.
-\<close>
-
- lemma bij_betw_Obj_ide:
- shows "bij_betw (Some o Id) (Collect Obj) (Collect C.ide)"
- using ide_char Obj_Dom by (intro bij_betwI, auto)
-
- end
-
- sublocale classical_category \<subseteq> category comp
- using induces_category by auto
-
- text\<open>
- A category defined using the nonstandard, partial-composition-based axiomatization
- admits an interpretation of the classical axioms, and the composition derived
- from this interpretation coincides with the originally given one.
-\<close>
-
- context category
- begin
-
- theorem is_classical_category:
- shows "classical_category ide arr dom cod dom C"
- using comp_arr_dom comp_cod_arr comp_assoc by (unfold_locales, auto)
-
- interpretation CC: classical_category ide arr dom cod dom C
- using is_classical_category by auto
-
- lemma comp_agreement:
- assumes "seq g f"
- shows "g \<cdot> f = the (CC.comp (Some g) (Some f))"
- using assms CC.comp_def seqE by fastforce
-
- end
-
end
diff --git a/thys/Category3/ConcreteCategory.thy b/thys/Category3/ConcreteCategory.thy
new file mode 100644
--- /dev/null
+++ b/thys/Category3/ConcreteCategory.thy
@@ -0,0 +1,452 @@
+(* Title: ConcreteCategory
+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
+*)
+
+chapter "Concrete Categories"
+
+text \<open>
+ In this section we define a locale \<open>concrete_category\<close>, which provides a uniform
+ (and more traditional) way to construct a category from specified sets of objects and arrows,
+ with specified identity objects and composition of arrows.
+ We prove that the identities and arrows of the constructed category are appropriately
+ in bijective correspondence with the given sets and that domains, codomains, and composition
+ in the constructed category are as expected according to this correspondence.
+ In the later theory \<open>Functor\<close>, once we have defined functors and isomorphisms of categories,
+ we will show a stronger property of this construction: if \<open>C\<close> is any category,
+ then \<open>C\<close> is isomorphic to the concrete category formed from it in the obvious way by taking
+ the identities of \<open>C\<close> as objects, the set of arrows of \<open>C\<close> as arrows, the identities of
+ \<open>C\<close> as identity objects, and defining composition of arrows using the composition of \<open>C\<close>.
+ Thus no information about \<open>C\<close> is lost by extracting its objects, arrows, identities, and
+ composition and rebuilding it as a concrete category.
+ We note, however, that we do not assume that the composition function given as parameter
+ to the concrete category construction is ``extensional'', so in general it will contain
+ incidental information about composition of non-composable arrows, and this information
+ is not preserved by the concrete category construction.
+\<close>
+
+theory ConcreteCategory
+imports Category
+begin
+
+ locale concrete_category =
+ fixes Obj :: "'o set"
+ and Hom :: "'o \<Rightarrow> 'o \<Rightarrow> 'a set"
+ and Id :: "'o \<Rightarrow> 'a"
+ and Comp :: "'o \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>'a"
+ assumes Id_in_Hom: "A \<in> Obj \<Longrightarrow> Id A \<in> Hom A A"
+ and Comp_in_Hom: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; f \<in> Hom A B; g \<in> Hom B C \<rbrakk>
+ \<Longrightarrow> Comp C B A g f \<in> Hom A C"
+ and Comp_Hom_Id: "\<lbrakk> A \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B A A f (Id A) = f"
+ and Comp_Id_Hom: "\<lbrakk> B \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B B A (Id B) f = f"
+ and Comp_assoc: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; D \<in> Obj;
+ f \<in> Hom A B; g \<in> Hom B C; h \<in> Hom C D \<rbrakk> \<Longrightarrow>
+ Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
+ begin
+
+ datatype ('oo, 'aa) arr =
+ Null
+ | MkArr 'oo 'oo 'aa
+
+ abbreviation MkIde :: "'o \<Rightarrow> ('o, 'a) arr"
+ where "MkIde A \<equiv> MkArr A A (Id A)"
+
+ fun Dom :: "('o, 'a) arr \<Rightarrow> 'o"
+ where "Dom (MkArr A _ _) = A"
+ | "Dom _ = undefined"
+
+ fun Cod
+ where "Cod (MkArr _ B _) = B"
+ | "Cod _ = undefined"
+
+ fun Map
+ where "Map (MkArr _ _ F) = F"
+ | "Map _ = undefined"
+
+ abbreviation Arr
+ where "Arr f \<equiv> f \<noteq> Null \<and> Dom f \<in> Obj \<and> Cod f \<in> Obj \<and> Map f \<in> Hom (Dom f) (Cod f)"
+
+ abbreviation Ide
+ where "Ide a \<equiv> a \<noteq> Null \<and> Dom a \<in> Obj \<and> Cod a = Dom a \<and> Map a = Id (Dom a)"
+
+ (*
+ * Here we use COMP in order that uses of this locale can declare themselves as
+ * sublocales and then define the abbreviation comp \<equiv> COMP.
+ *)
+ definition COMP :: "('o, 'a) arr comp"
+ where "COMP g f \<equiv> if Arr f \<and> Arr g \<and> Dom g = Cod f then
+ MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
+ else
+ Null"
+
+ interpretation partial_magma COMP
+ using COMP_def by (unfold_locales, metis)
+
+ lemma null_char:
+ shows "null = Null"
+ proof -
+ let ?P = "\<lambda>n. \<forall>f. COMP n f = n \<and> COMP f n = n"
+ have "Null = null"
+ using COMP_def null_def the1_equality [of ?P] by metis
+ thus ?thesis by simp
+ qed
+
+ lemma ide_char:
+ shows "ide f \<longleftrightarrow> Ide f"
+ proof
+ assume f: "Ide f"
+ show "ide f"
+ proof -
+ have "COMP f f \<noteq> null"
+ using f COMP_def null_char Id_in_Hom by auto
+ moreover have "\<forall>g. (COMP g f \<noteq> null \<longrightarrow> COMP g f = g) \<and>
+ (COMP f g \<noteq> null \<longrightarrow> COMP f g = g)"
+ proof (intro allI conjI)
+ fix g
+ show "COMP g f \<noteq> null \<longrightarrow> COMP g f = g"
+ using f COMP_def null_char Comp_Hom_Id Id_in_Hom
+ by (cases g, auto)
+ show "COMP f g \<noteq> null \<longrightarrow> COMP f g = g"
+ using f COMP_def null_char Comp_Id_Hom Id_in_Hom
+ by (cases g, auto)
+ qed
+ ultimately show ?thesis
+ using ide_def by blast
+ qed
+ next
+ assume f: "ide f"
+ have 1: "Arr f \<and> Dom f = Cod f"
+ using f ide_def COMP_def null_char by metis
+ moreover have "Map f = Id (Dom f)"
+ proof -
+ let ?g = "MkIde (Dom f)"
+ have g: "Arr f \<and> Arr ?g \<and> Dom ?g = Cod f"
+ using 1 Id_in_Hom
+ by (intro conjI, simp_all)
+ have "COMP ?g f = MkArr (Dom f) (Dom f) (Map f)"
+ using g COMP_def Comp_Id_Hom by auto
+ moreover have "COMP ?g f = ?g"
+ proof -
+ have "COMP ?g f \<noteq> null"
+ using g 1 COMP_def null_char by simp
+ thus ?thesis
+ using f ide_def by blast
+ qed
+ ultimately show ?thesis by simp
+ qed
+ ultimately show "Ide f" by auto
+ qed
+
+ lemma ide_MkIde [simp]:
+ assumes "A \<in> Obj"
+ shows "ide (MkIde A)"
+ using assms ide_char Id_in_Hom by simp
+
+ lemma in_domains_char:
+ shows "a \<in> domains f \<longleftrightarrow> Arr f \<and> a = MkIde (Dom f)"
+ proof
+ assume a: "a \<in> domains f"
+ have "Ide a"
+ using a domains_def ide_char COMP_def null_char by auto
+ moreover have "Arr f \<and> Dom f = Cod a"
+ proof -
+ have "COMP f a \<noteq> null"
+ using a domains_def by simp
+ thus ?thesis
+ using a domains_def COMP_def [of f a] null_char by metis
+ qed
+ ultimately show "Arr f \<and> a = MkIde (Dom f)"
+ by (cases a, auto)
+ next
+ assume a: "Arr f \<and> a = MkIde (Dom f)"
+ show "a \<in> domains f"
+ using a Id_in_Hom COMP_def null_char domains_def by auto
+ qed
+
+ lemma in_codomains_char:
+ shows "b \<in> codomains f \<longleftrightarrow> Arr f \<and> b = MkIde (Cod f)"
+ proof
+ assume b: "b \<in> codomains f"
+ have "Ide b"
+ using b codomains_def ide_char COMP_def null_char by auto
+ moreover have "Arr f \<and> Dom b = Cod f"
+ proof -
+ have "COMP b f \<noteq> null"
+ using b codomains_def by simp
+ thus ?thesis
+ using b codomains_def COMP_def [of b f] null_char by metis
+ qed
+ ultimately show "Arr f \<and> b = MkIde (Cod f)"
+ by (cases b, auto)
+ next
+ assume b: "Arr f \<and> b = MkIde (Cod f)"
+ show "b \<in> codomains f"
+ using b Id_in_Hom COMP_def null_char codomains_def by auto
+ qed
+
+ lemma arr_char:
+ shows "arr f \<longleftrightarrow> Arr f"
+ using arr_def in_domains_char in_codomains_char by auto
+
+ lemma arrI:
+ assumes "f \<noteq> Null" and "Dom f \<in> Obj" "Cod f \<in> Obj" "Map f \<in> Hom (Dom f) (Cod f)"
+ shows "arr f"
+ using assms arr_char by blast
+
+ lemma arrE:
+ assumes "arr f"
+ and "\<lbrakk> f \<noteq> Null; Dom f \<in> Obj; Cod f \<in> Obj; Map f \<in> Hom (Dom f) (Cod f) \<rbrakk> \<Longrightarrow> T"
+ shows T
+ using assms arr_char by simp
+
+ lemma arr_MkArr [simp]:
+ assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
+ shows "arr (MkArr A B f)"
+ using assms arr_char by simp
+
+ lemma MkArr_Map:
+ assumes "arr f"
+ shows "MkArr (Dom f) (Cod f) (Map f) = f"
+ using assms arr_char by (cases f, auto)
+
+ lemma Arr_comp:
+ assumes "arr f" and "arr g" and "Dom g = Cod f"
+ shows "Arr (COMP g f)"
+ unfolding COMP_def
+ using assms arr_char Comp_in_Hom by simp
+
+ lemma Dom_comp [simp]:
+ assumes "arr f" and "arr g" and "Dom g = Cod f"
+ shows "Dom (COMP g f) = Dom f"
+ unfolding COMP_def
+ using assms arr_char by simp
+
+ lemma Cod_comp [simp]:
+ assumes "arr f" and "arr g" and "Dom g = Cod f"
+ shows "Cod (COMP g f) = Cod g"
+ unfolding COMP_def
+ using assms arr_char by simp
+
+ lemma Map_comp [simp]:
+ assumes "arr f" and "arr g" and "Dom g = Cod f"
+ shows "Map (COMP g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
+ unfolding COMP_def
+ using assms arr_char by simp
+
+ lemma seq_char:
+ shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> Dom g = Cod f"
+ using arr_char not_arr_null null_char COMP_def Arr_comp by metis
+
+ interpretation category COMP
+ proof
+ show "\<And>g f. COMP g f \<noteq> null \<Longrightarrow> seq g f"
+ using arr_char COMP_def null_char Comp_in_Hom by auto
+ show 1: "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
+ using in_domains_char in_codomains_char by auto
+ show "\<And>f g h. seq h g \<Longrightarrow> seq (COMP h g) f \<Longrightarrow> seq g f"
+ by (auto simp add: seq_char)
+ show "\<And>f g h. seq h (COMP g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
+ using seq_char COMP_def Comp_in_Hom by (metis Cod_comp)
+ show "\<And>f g h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (COMP h g) f"
+ using Comp_in_Hom
+ by (auto simp add: COMP_def seq_char)
+ show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> COMP (COMP h g) f = COMP h (COMP g f)"
+ using seq_char COMP_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
+ by auto
+ qed
+
+ proposition is_category:
+ shows "category COMP"
+ ..
+
+ text \<open>
+ Functions \<open>Dom\<close>, \<open>Cod\<close>, and \<open>Map\<close> establish a correspondence between the
+ arrows of the constructed category and the elements of the originally given
+ parameters \<open>Obj\<close> and \<open>Hom\<close>.
+ \<close>
+
+ lemma Dom_in_Obj:
+ assumes "arr f"
+ shows "Dom f \<in> Obj"
+ using assms arr_char by simp
+
+ lemma Cod_in_Obj:
+ assumes "arr f"
+ shows "Cod f \<in> Obj"
+ using assms arr_char by simp
+
+ lemma Map_in_Hom:
+ assumes "arr f"
+ shows "Map f \<in> Hom (Dom f) (Cod f)"
+ using assms arr_char by simp
+
+ lemma MkArr_in_hom:
+ assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
+ shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
+ using assms arr_char ide_MkIde
+ by (simp add: in_codomains_char in_domains_char in_hom_def)
+
+ text \<open>
+ The next few results show that domains, codomains, and composition in the constructed
+ category are as expected according to the just-given correspondence.
+ \<close>
+
+ lemma dom_char:
+ shows "dom f = (if arr f then MkIde (Dom f) else null)"
+ using dom_def in_domains_char dom_in_domains has_domain_iff_arr by auto
+
+ lemma cod_char:
+ shows "cod f = (if arr f then MkIde (Cod f) else null)"
+ using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto
+
+ lemma comp_char:
+ shows "COMP g f = (if seq g f then
+ MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
+ else
+ null)"
+ using COMP_def seq_char arr_char null_char by auto
+
+ lemma in_hom_char:
+ shows "in_hom f a b \<longleftrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
+ proof
+ show "in_hom f a b \<Longrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
+ using arr_char dom_char cod_char by auto
+ show "arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b \<Longrightarrow> in_hom f a b"
+ using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
+ qed
+
+ lemma Dom_dom [simp]:
+ assumes "arr f"
+ shows "Dom (dom f) = Dom f"
+ using assms MkArr_Map dom_char by simp
+
+ lemma Cod_dom [simp]:
+ assumes "arr f"
+ shows "Cod (dom f) = Dom f"
+ using assms MkArr_Map dom_char by simp
+
+ lemma Dom_cod [simp]:
+ assumes "arr f"
+ shows "Dom (cod f) = Cod f"
+ using assms MkArr_Map cod_char by simp
+
+ lemma Cod_cod [simp]:
+ assumes "arr f"
+ shows "Cod (cod f) = Cod f"
+ using assms MkArr_Map cod_char by simp
+
+ lemma Map_dom [simp]:
+ assumes "arr f"
+ shows "Map (dom f) = Id (Dom f)"
+ using assms MkArr_Map dom_char by simp
+
+ lemma Map_cod [simp]:
+ assumes "arr f"
+ shows "Map (cod f) = Id (Cod f)"
+ using assms MkArr_Map cod_char by simp
+
+ lemma Map_ide:
+ assumes "ide a"
+ shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
+ using assms ide_char dom_char [of a] Map_dom Map_cod ideD(1) by metis+
+
+ (*
+ * TODO: The next two ought to be simps, but they cause looping when they find themselves
+ * in combination with dom_char and cod_char.
+ *)
+ lemma MkIde_Dom:
+ assumes "arr a"
+ shows "MkIde (Dom a) = dom a"
+ using assms arr_char dom_char by (cases a, auto)
+
+ lemma MkIde_Cod:
+ assumes "arr a"
+ shows "MkIde (Cod a) = cod a"
+ using assms arr_char cod_char by (cases a, auto)
+
+ lemma MkIde_Dom' [simp]:
+ assumes "ide a"
+ shows "MkIde (Dom a) = a"
+ using assms MkIde_Dom by simp
+
+ lemma MkIde_Cod' [simp]:
+ assumes "ide a"
+ shows "MkIde (Cod a) = a"
+ using assms MkIde_Cod by simp
+
+ lemma dom_MkArr [simp]:
+ assumes "arr (MkArr A B F)"
+ shows "dom (MkArr A B F) = MkIde A"
+ using assms dom_char by simp
+
+ lemma cod_MkArr [simp]:
+ assumes "arr (MkArr A B F)"
+ shows "cod (MkArr A B F) = MkIde B"
+ using assms cod_char by simp
+
+ lemma comp_MkArr [simp]:
+ assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
+ shows "COMP (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
+ using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp
+
+ text \<open>
+ The set \<open>Obj\<close> of ``objects'' given as a parameter is in bijective correspondence
+ (via function \<open>MkIde\<close>) with the set of identities of the resulting category.
+ \<close>
+
+ proposition bij_betw_ide_Obj:
+ shows "MkIde \<in> Obj \<rightarrow> Collect ide"
+ and "Dom \<in> Collect ide \<rightarrow> Obj"
+ and "A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
+ and "a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
+ and "bij_betw Dom (Collect ide) Obj"
+ proof -
+ show "MkIde \<in> Obj \<rightarrow> Collect ide"
+ using ide_MkIde by simp
+ moreover show "Dom \<in> Collect ide \<rightarrow> Obj"
+ using arr_char ideD(1) by simp
+ moreover show "\<And>A. A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
+ by simp
+ moreover show "\<And>a. a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
+ using MkIde_Dom by simp
+ ultimately show "bij_betw Dom (Collect ide) Obj"
+ using bij_betwI by blast
+ qed
+
+ text \<open>
+ For each pair of identities \<open>a\<close> and \<open>b\<close>, the set \<open>Hom (Dom a) (Dom b)\<close> is in
+ bijective correspondence (via function \<open>MkArr (Dom a) (Dom b)\<close>) with the
+ ``hom-set'' \<open>hom a b\<close> of the resulting category.
+ \<close>
+
+ proposition bij_betw_hom_Hom:
+ assumes "ide a" and "ide b"
+ shows "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
+ and "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
+ and "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
+ and "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
+ and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
+ proof -
+ show "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
+ using Map_in_Hom cod_char dom_char in_hom_char by fastforce
+ moreover show "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
+ using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
+ moreover show "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
+ using MkArr_Map by auto
+ moreover show "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
+ by simp
+ ultimately show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
+ using bij_betwI by blast
+ qed
+
+ lemma arr_eqI:
+ assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
+ shows "t = t'"
+ using assms MkArr_Map by metis
+
+ end
+
+ sublocale concrete_category \<subseteq> category COMP
+ using is_category by auto
+
+end
diff --git a/thys/Category3/DiscreteCategory.thy b/thys/Category3/DiscreteCategory.thy
--- a/thys/Category3/DiscreteCategory.thy
+++ b/thys/Category3/DiscreteCategory.thy
@@ -1,98 +1,92 @@
(* Title: DiscreteCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter DiscreteCategory
theory DiscreteCategory
imports Category
begin
text\<open>
The locale defined here permits us to construct a discrete category having
a specified set of objects, assuming that the set does not exhaust the elements
of its type. In that case, we have the convenient situation that the arrows of
the category can be directly identified with the elements of the given set,
rather than having to pass between the two via tedious coercion maps.
If it cannot be guaranteed that the given set is not the universal set at its type,
then the more general discrete category construction defined (using coercions)
in \<open>FreeCategory\<close> can be used.
\<close>
locale discrete_category =
fixes Obj :: "'a set"
and Null :: 'a
assumes Null_not_in_Obj: "Null \<notin> Obj"
begin
definition comp :: "'a comp" (infixr "\<cdot>" 55)
where "y \<cdot> x \<equiv> (if x \<in> Obj \<and> x = y then x else Null)"
interpretation partial_magma comp
apply unfold_locales
using comp_def by metis
lemma null_char:
shows "null = Null"
using comp_def null_def by auto
lemma ide_char [iff]:
shows "ide f \<longleftrightarrow> f \<in> Obj"
using comp_def null_char ide_def Null_not_in_Obj by auto
lemma domains_char:
shows "domains f = {x. x \<in> Obj \<and> x = f}"
- proof
- show "{x. x \<in> Obj \<and> x = f} \<subseteq> domains f"
- unfolding domains_def
- using ide_char ide_def by fastforce
- show "domains f \<subseteq> {x. x \<in> Obj \<and> x = f}"
- unfolding domains_def
- using ide_char by (simp add: Collect_mono comp_def null_char)
- qed
+ unfolding domains_def
+ using ide_char ide_def comp_def null_char by metis
theorem is_category:
shows "category comp"
using comp_def
apply unfold_locales
using arr_def null_char self_domain_iff_ide ide_char
apply fastforce
using null_char self_codomain_iff_ide domains_char codomains_def ide_char
apply fastforce
apply (metis not_arr_null null_char)
apply (metis not_arr_null null_char)
by auto
end
sublocale discrete_category \<subseteq> category comp
using is_category by auto
context discrete_category
begin
lemma arr_char [iff]:
shows "arr f \<longleftrightarrow> f \<in> Obj"
using comp_def comp_cod_arr
by (metis empty_iff has_codomain_iff_arr not_arr_null null_char self_codomain_iff_ide ide_char)
lemma dom_char [simp]:
shows "dom f = (if f \<in> Obj then f else null)"
using arr_def dom_def arr_char ideD(2) by auto
lemma cod_char [simp]:
shows "cod f = (if f \<in> Obj then f else null)"
using arr_def in_homE cod_def ideD(3) by auto
lemma comp_char [simp]:
shows "comp g f = (if f \<in> Obj \<and> f = g then f else null)"
using comp_def null_char by auto
lemma is_discrete:
shows "ide = arr"
using arr_char ide_char by auto
end
end
diff --git a/thys/Category3/EpiMonoIso.thy b/thys/Category3/EpiMonoIso.thy
--- a/thys/Category3/EpiMonoIso.thy
+++ b/thys/Category3/EpiMonoIso.thy
@@ -1,461 +1,425 @@
(* Title: EpiMonoIso
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter EpiMonoIso
theory EpiMonoIso
imports Category
begin
text\<open>
This theory defines and develops properties of epimorphisms, monomorphisms,
isomorphisms, sections, and retractions.
\<close>
context category
begin
definition epi
where "epi f = (arr f \<and> inj_on (\<lambda>g. g \<cdot> f) {g. seq g f})"
definition mono
where "mono f = (arr f \<and> inj_on (\<lambda>g. f \<cdot> g) {g. seq f g})"
lemma epiI [intro]:
assumes "arr f" and "\<And>g g'. seq g f \<and> seq g' f \<and> g \<cdot> f = g' \<cdot> f \<Longrightarrow> g = g'"
shows "epi f"
using assms epi_def inj_on_def by blast
lemma epi_implies_arr:
assumes "epi f"
shows "arr f"
using assms epi_def by auto
lemma epiE [elim]:
assumes "epi f"
and "seq g f" and "seq g' f" and "g \<cdot> f = g' \<cdot> f"
shows "g = g'"
using assms unfolding epi_def inj_on_def by blast
lemma monoI [intro]:
assumes "arr g" and "\<And>f f'. seq g f \<and> seq g f' \<and> g \<cdot> f = g \<cdot> f' \<Longrightarrow> f = f'"
shows "mono g"
using assms mono_def inj_on_def by blast
lemma mono_implies_arr:
assumes "mono f"
shows "arr f"
using assms mono_def by auto
lemma monoE [elim]:
assumes "mono g"
and "seq g f" and "seq g f'" and "g \<cdot> f = g \<cdot> f'"
shows "f' = f"
using assms unfolding mono_def inj_on_def by blast
definition inverse_arrows
where "inverse_arrows f g \<equiv> ide (g \<cdot> f) \<and> ide (f \<cdot> g)"
lemma inverse_arrowsI [intro]:
assumes "ide (g \<cdot> f)" and "ide (f \<cdot> g)"
shows "inverse_arrows f g"
using assms inverse_arrows_def by blast
lemma inverse_arrowsE [elim]:
assumes "inverse_arrows f g"
and "\<lbrakk> ide (g \<cdot> f); ide (f \<cdot> g) \<rbrakk> \<Longrightarrow> T"
shows "T"
using assms inverse_arrows_def by blast
lemma inverse_arrows_sym:
shows "inverse_arrows f g \<longleftrightarrow> inverse_arrows g f"
using inverse_arrows_def by auto
lemma ide_self_inverse:
assumes "ide a"
shows "inverse_arrows a a"
using assms by auto
lemma inverse_arrow_unique:
assumes "inverse_arrows f g" and "inverse_arrows f g'"
shows "g = g'"
using assms apply (elim inverse_arrowsE)
by (metis comp_cod_arr ide_compE comp_assoc seqE)
lemma inverse_arrows_compose:
assumes "seq g f" and "inverse_arrows f f'" and "inverse_arrows g g'"
shows "inverse_arrows (g \<cdot> f) (f' \<cdot> g')"
using assms apply (elim inverse_arrowsE, intro inverse_arrowsI)
apply (metis seqE comp_arr_dom ide_compE comp_assoc)
by (metis seqE comp_arr_dom ide_compE comp_assoc)
definition "section"
where "section f \<equiv> \<exists>g. ide (g \<cdot> f)"
lemma sectionI [intro]:
assumes "ide (g \<cdot> f)"
shows "section f"
using assms section_def by auto
lemma sectionE [elim]:
assumes "section f"
obtains g where "ide (g \<cdot> f)"
using assms section_def by blast
definition retraction
where "retraction g \<equiv> \<exists>f. ide (g \<cdot> f)"
lemma retractionI [intro]:
assumes "ide (g \<cdot> f)"
shows "retraction g"
using assms retraction_def by auto
lemma retractionE [elim]:
assumes "retraction g"
obtains f where "ide (g \<cdot> f)"
using assms retraction_def by blast
lemma section_is_mono:
assumes "section g"
shows "mono g"
proof
show "arr g" using assms section_def by blast
from assms obtain h where h: "ide (h \<cdot> g)" by blast
have hg: "seq h g" using h by auto
fix f f'
assume "seq g f \<and> seq g f' \<and> g \<cdot> f = g \<cdot> f'"
thus "f = f'"
using hg h ide_compE seqE comp_assoc comp_cod_arr by metis
qed
lemma retraction_is_epi:
assumes "retraction g"
shows "epi g"
proof
show "arr g" using assms retraction_def by blast
from assms obtain f where f: "ide (g \<cdot> f)" by blast
have gf: "seq g f" using f by auto
fix h h'
assume "seq h g \<and> seq h' g \<and> h \<cdot> g = h' \<cdot> g"
thus "h = h'"
using gf f ide_compE seqE comp_assoc comp_arr_dom by metis
qed
lemma section_retraction_compose:
assumes "ide (e \<cdot> m)" and "ide (e' \<cdot> m')" and "seq m' m"
shows "ide ((e \<cdot> e') \<cdot> (m' \<cdot> m))"
using assms seqI seqE ide_compE comp_assoc comp_arr_dom by metis
lemma sections_compose [intro]:
assumes "section m" and "section m'" and "seq m' m"
shows "section (m' \<cdot> m)"
using assms section_def section_retraction_compose by metis
lemma retractions_compose [intro]:
assumes "retraction e" and "retraction e'" and "seq e' e"
shows "retraction (e' \<cdot> e)"
proof -
- from assms(1) assms(2) obtain m m'
+ from assms(1-2) obtain m m'
where *: "ide (e \<cdot> m) \<and> ide (e' \<cdot> m')"
using retraction_def by auto
hence "seq m m'"
using assms(3) by (metis seqE seqI ide_compE)
with * show ?thesis
using section_retraction_compose retractionI by blast
qed
lemma monos_compose [intro]:
assumes "mono m" and "mono m'" and "seq m' m"
shows "mono (m' \<cdot> m)"
proof -
have "inj_on (\<lambda>f. (m' \<cdot> m) \<cdot> f) {f. seq (m' \<cdot> m) f}"
unfolding inj_on_def
using assms
by (metis CollectD seqE monoE comp_assoc)
thus ?thesis using assms(3) mono_def by force
qed
lemma epis_compose [intro]:
assumes "epi e" and "epi e'" and "seq e' e"
shows "epi (e' \<cdot> e)"
proof -
have "inj_on (\<lambda>g. g \<cdot> (e' \<cdot> e)) {g. seq g (e' \<cdot> e)}"
unfolding inj_on_def
- using assms
- by (metis CollectD seqI seqE cod_comp epiE comp_assoc')
+ using assms by (metis CollectD epiE match_2 comp_assoc)
thus ?thesis using assms(3) epi_def by force
qed
definition iso
where "iso f \<equiv> \<exists>g. inverse_arrows f g"
lemma isoI [intro]:
assumes "inverse_arrows f g"
shows "iso f"
using assms iso_def by auto
lemma isoE [elim]:
assumes "iso f"
obtains g where "inverse_arrows f g"
using assms iso_def by blast
lemma ide_is_iso [simp]:
assumes "ide a"
shows "iso a"
using assms ide_self_inverse by auto
lemma iso_is_arr:
assumes "iso f"
shows "arr f"
using assms by blast
lemma iso_is_section:
assumes "iso f"
shows "section f"
using assms inverse_arrows_def by blast
lemma iso_is_retraction:
assumes "iso f"
shows "retraction f"
using assms inverse_arrows_def by blast
lemma iso_iff_mono_and_retraction:
shows "iso f \<longleftrightarrow> mono f \<and> retraction f"
proof
show "iso f \<Longrightarrow> mono f \<and> retraction f"
by (simp add: iso_is_retraction iso_is_section section_is_mono)
show "mono f \<and> retraction f \<Longrightarrow> iso f"
proof -
assume f: "mono f \<and> retraction f"
from f obtain g where g: "ide (f \<cdot> g)" by blast
have "inverse_arrows f g"
- proof
- show "ide (f \<cdot> g)" by fact
- show "ide (g \<cdot> f)"
- proof -
- have "f \<cdot> g \<cdot> f = f \<cdot> dom f"
- using f g comp_arr_dom comp_cod_arr
- by (metis comp_assoc ide_compE mono_implies_arr)
- hence "g \<cdot> f = dom f"
- using f g monoE
- by (metis (full_types) comp_arr_dom ide_compE seqE)
- thus ?thesis using f by force
- qed
- qed
+ using f g comp_arr_dom comp_cod_arr comp_assoc inverse_arrowsI
+ by (metis ide_char' ide_compE monoE mono_implies_arr)
thus "iso f" by auto
qed
qed
lemma iso_iff_section_and_epi:
shows "iso f \<longleftrightarrow> section f \<and> epi f"
proof
show "iso f \<Longrightarrow> section f \<and> epi f"
by (simp add: iso_is_retraction iso_is_section retraction_is_epi)
show "section f \<and> epi f \<Longrightarrow> iso f"
proof -
assume f: "section f \<and> epi f"
from f obtain g where g: "ide (g \<cdot> f)" by blast
have "inverse_arrows f g"
- proof
- show "ide (g \<cdot> f)" by fact
- show "ide (f \<cdot> g)"
- proof -
- have "f \<cdot> g \<cdot> f = cod f \<cdot> f"
- using f g comp_arr_dom comp_cod_arr epi_implies_arr by auto
- hence "f \<cdot> g = cod f"
- using f g epiE
- by (metis comp_assoc comp_cod_arr epi_implies_arr ide_compE)
- thus ?thesis using f by force
- qed
- qed
+ using f g comp_arr_dom comp_cod_arr epi_implies_arr
+ comp_assoc ide_compE inverse_arrowsI epiE ide_char'
+ by metis
thus "iso f" by auto
qed
qed
lemma iso_iff_section_and_retraction:
shows "iso f \<longleftrightarrow> section f \<and> retraction f"
- proof
- show "iso f \<Longrightarrow> section f \<and> retraction f"
- by (simp add: iso_is_retraction iso_is_section)
- show "section f \<and> retraction f \<Longrightarrow> iso f"
- using iso_iff_mono_and_retraction section_is_mono by simp
- qed
+ using iso_is_retraction iso_is_section iso_iff_mono_and_retraction section_is_mono
+ by auto
lemma isos_compose [intro]:
assumes "iso f" and "iso f'" and "seq f' f"
shows "iso (f' \<cdot> f)"
proof -
from assms(1) obtain g where g: "inverse_arrows f g" by blast
from assms(2) obtain g' where g': "inverse_arrows f' g'" by blast
have "inverse_arrows (f' \<cdot> f) (g \<cdot> g')"
- proof
- show "ide ((f' \<cdot> f) \<cdot> (g \<cdot> g'))"
- using assms g g'
- by (meson seqE ide_compE inverse_arrows_def section_retraction_compose)
- show "ide ((g \<cdot> g') \<cdot> (f' \<cdot> f))"
- using assms g g' inverse_arrows_def section_retraction_compose by simp
- qed
+ using assms g g inverse_arrowsI inverse_arrowsE section_retraction_compose
+ by (simp add: g' inverse_arrows_compose)
thus ?thesis using iso_def by auto
qed
definition isomorphic
where "isomorphic a a' = (\<exists>f. \<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> iso f)"
lemma isomorphicI [intro]:
assumes "iso f"
shows "isomorphic (dom f) (cod f)"
using assms isomorphic_def iso_is_arr by blast
lemma isomorphicE [elim]:
assumes "isomorphic a a'"
obtains f where "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> iso f"
using assms isomorphic_def by meson
definition inv
where "inv f = (SOME g. inverse_arrows f g)"
lemma inv_is_inverse:
assumes "iso f"
shows "inverse_arrows f (inv f)"
using assms inv_def someI [of "inverse_arrows f"] by auto
lemma iso_inv_iso:
assumes "iso f"
shows "iso (inv f)"
using assms inv_is_inverse inverse_arrows_sym by blast
lemma inverse_unique:
assumes "inverse_arrows f g"
shows "inv f = g"
using assms inv_is_inverse inverse_arrow_unique isoI by auto
lemma inv_ide [simp]:
assumes "ide a"
shows "inv a = a"
using assms by (simp add: inverse_arrowsI inverse_unique)
lemma inv_inv [simp]:
assumes "iso f"
shows "inv (inv f) = f"
using assms inverse_arrows_sym inverse_unique by blast
lemma comp_arr_inv:
assumes "inverse_arrows f g"
shows "f \<cdot> g = dom g"
using assms by auto
lemma comp_inv_arr:
assumes "inverse_arrows f g"
shows "g \<cdot> f = dom f"
using assms by auto
lemma comp_arr_inv':
assumes "iso f"
shows "f \<cdot> inv f = cod f"
using assms inv_is_inverse by blast
lemma comp_inv_arr':
assumes "iso f"
shows "inv f \<cdot> f = dom f"
using assms inv_is_inverse by blast
lemma inv_in_hom [simp]:
assumes "iso f" and "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
shows "\<guillemotleft>inv f : b \<rightarrow> a\<guillemotright>"
using assms inv_is_inverse seqE inverse_arrowsE
by (metis ide_compE in_homE in_homI)
lemma arr_inv [simp]:
assumes "iso f"
shows "arr (inv f)"
using assms inv_in_hom by blast
lemma dom_inv [simp]:
assumes "iso f"
shows "dom (inv f) = cod f"
using assms inv_in_hom by blast
lemma cod_inv [simp]:
assumes "iso f"
shows "cod (inv f) = dom f"
using assms inv_in_hom by blast
lemma inv_comp:
assumes "iso f" and "iso g" and "seq g f"
shows "inv (g \<cdot> f) = inv f \<cdot> inv g"
using assms inv_is_inverse inverse_unique inverse_arrows_compose inverse_arrows_def
by meson
lemma isomorphic_reflexive:
assumes "ide f"
shows "isomorphic f f"
unfolding isomorphic_def
using assms ide_is_iso ide_in_hom by blast
lemma isomorphic_symmetric:
assumes "isomorphic f g"
shows "isomorphic g f"
using assms iso_inv_iso inv_in_hom by blast
- lemma isomorphic_transitive:
+ lemma isomorphic_transitive [trans]:
assumes "isomorphic f g" and "isomorphic g h"
shows "isomorphic f h"
- proof -
- obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : f \<rightarrow> g\<guillemotright>" using assms isomorphic_def by blast
- obtain \<psi> where \<psi>: "iso \<psi> \<and> \<guillemotleft>\<psi> : g \<rightarrow> h\<guillemotright>" using assms isomorphic_def by blast
- have "iso (\<psi> \<cdot> \<phi>) \<and> \<guillemotleft>\<psi> \<cdot> \<phi> : f \<rightarrow> h\<guillemotright>" using \<phi> \<psi> isos_compose by blast
- thus "isomorphic f h" using isomorphic_def by auto
- qed
+ using assms isomorphic_def isos_compose by auto
text \<open>
A section or retraction of an isomorphism is in fact an inverse.
\<close>
lemma section_retraction_of_iso:
assumes "iso f"
shows "ide (g \<cdot> f) \<Longrightarrow> inverse_arrows f g"
and "ide (f \<cdot> g) \<Longrightarrow> inverse_arrows f g"
proof -
show "ide (g \<cdot> f) \<Longrightarrow> inverse_arrows f g"
- using assms iso_is_retraction retraction_is_epi epiE inv_is_inverse inverse_arrowsE
- ide_compE
- by metis
+ using assms
+ by (metis comp_inv_arr' epiE ide_compE inv_is_inverse iso_iff_section_and_epi)
show "ide (f \<cdot> g) \<Longrightarrow> inverse_arrows f g"
- using assms iso_is_section section_is_mono monoE inv_is_inverse inverse_arrowsE ide_compE
- by metis
+ using assms
+ by (metis ide_compE comp_arr_inv' inv_is_inverse iso_iff_mono_and_retraction monoE)
qed
text \<open>
A situation that occurs frequently is that we have a commuting triangle,
but we need the triangle obtained by inverting one side that is an isomorphism.
The following fact streamlines this derivation.
\<close>
lemma invert_side_of_triangle:
assumes "arr h" and "f \<cdot> g = h"
shows "iso f \<Longrightarrow> seq (inv f) h \<and> g = inv f \<cdot> h"
and "iso g \<Longrightarrow> seq h (inv g) \<and> f = h \<cdot> inv g"
proof -
show "iso f \<Longrightarrow> seq (inv f) h \<and> g = inv f \<cdot> h"
by (metis assms seqE inv_is_inverse comp_cod_arr comp_inv_arr comp_assoc)
show "iso g \<Longrightarrow> seq h (inv g) \<and> f = h \<cdot> inv g"
by (metis assms seqE inv_is_inverse comp_arr_dom comp_arr_inv dom_inv comp_assoc)
qed
text \<open>
A similar situation is where we have a commuting square and we want to
invert two opposite sides.
\<close>
lemma invert_opposite_sides_of_square:
assumes "seq f g" and "f \<cdot> g = h \<cdot> k"
shows "\<lbrakk> iso f; iso k \<rbrakk> \<Longrightarrow> seq g (inv k) \<and> seq (inv f) h \<and> g \<cdot> inv k = inv f \<cdot> h"
by (metis assms invert_side_of_triangle comp_assoc)
end
end
diff --git a/thys/Category3/EquivalenceOfCategories.thy b/thys/Category3/EquivalenceOfCategories.thy
--- a/thys/Category3/EquivalenceOfCategories.thy
+++ b/thys/Category3/EquivalenceOfCategories.thy
@@ -1,641 +1,643 @@
(* Title: EquivalenceOfCategories
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter "Equivalence of Categories"
text \<open>
In this chapter we define the notions of equivalence and adjoint equivalence of categories
and establish some properties of functors that are part of an equivalence.
\<close>
theory EquivalenceOfCategories
imports Adjunction
begin
locale equivalence_of_categories =
C: category C +
D: category D +
F: "functor" D C F +
G: "functor" C D G +
\<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
\<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and F :: "'d \<Rightarrow> 'c"
and G :: "'c \<Rightarrow> 'd"
and \<eta> :: "'d \<Rightarrow> 'd"
and \<epsilon> :: "'c \<Rightarrow> 'c"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
lemma C_arr_expansion:
assumes "C.arr f"
shows "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f"
and "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
proof -
have \<epsilon>_dom: "C.inverse_arrows (\<epsilon> (C.dom f)) (C.inv (\<epsilon> (C.dom f)))"
using assms C.inv_is_inverse by auto
have \<epsilon>_cod: "C.inverse_arrows (\<epsilon> (C.cod f)) (C.inv (\<epsilon> (C.cod f)))"
using assms C.inv_is_inverse by auto
have "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) =
(\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
using C.comp_assoc by force
also have 1: "... = (f \<cdot>\<^sub>C \<epsilon> (C.dom f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
using assms \<epsilon>.naturality by simp
also have 2: "... = f"
using assms \<epsilon>_dom C.comp_arr_inv C.comp_arr_dom C.comp_assoc by force
finally show "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f" by blast
show "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
using assms 1 2 \<epsilon>_dom \<epsilon>_cod C.invert_side_of_triangle C.isoI C.iso_inv_iso
by metis
qed
lemma G_is_faithful:
shows "faithful_functor C D G"
proof
fix f f'
assume par: "C.par f f'" and eq: "G f = G f'"
show "f = f'"
proof -
have "C.inv (\<epsilon> (C.cod f)) \<in> C.hom (C.cod f) (F (G (C.cod f))) \<and>
C.iso (C.inv (\<epsilon> (C.cod f)))"
using par C.iso_inv_iso by auto
moreover have 1: "\<epsilon> (C.dom f) \<in> C.hom (F (G (C.dom f))) (C.dom f) \<and>
C.iso (\<epsilon> (C.dom f))"
using par by auto
ultimately have 2: "f \<cdot>\<^sub>C \<epsilon> (C.dom f) = f' \<cdot>\<^sub>C \<epsilon> (C.dom f)"
using par C_arr_expansion eq C.iso_is_section C.section_is_mono
by (metis C_arr_expansion(1) eq)
show ?thesis
proof -
have "C.epi (\<epsilon> (C.dom f))"
using 1 par C.iso_is_retraction C.retraction_is_epi by blast
thus ?thesis using 2 par by auto
qed
qed
qed
lemma G_is_essentially_surjective:
shows "essentially_surjective_functor C D G"
proof
fix b
assume b: "D.ide b"
have "C.ide (F b) \<and> D.isomorphic (G (F b)) b"
proof
show "C.ide (F b)" using b by simp
show "D.isomorphic (G (F b)) b"
proof (unfold D.isomorphic_def)
have "\<guillemotleft>D.inv (\<eta> b) : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso (D.inv (\<eta> b))"
using b D.iso_inv_iso by auto
thus "\<exists>f. \<guillemotleft>f : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso f" by blast
qed
qed
thus "\<exists>a. C.ide a \<and> D.isomorphic (G a) b"
by blast
qed
- interpretation \<epsilon>_inv: inverse_transformation C C "F o G" C.map \<epsilon> ..
- interpretation \<eta>_inv: inverse_transformation D D D.map "G o F" \<eta> ..
+ interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
+ interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..
lemma F_is_faithful:
shows "faithful_functor D C F"
using GF.G_is_faithful by simp
lemma F_is_essentially_surjective:
shows "essentially_surjective_functor D C F"
using GF.G_is_essentially_surjective by simp
lemma G_is_full:
shows "full_functor C D G"
proof
fix a a' g
assume a: "C.ide a" and a': "C.ide a'"
assume g: "\<guillemotleft>g : G a \<rightarrow>\<^sub>D G a'\<guillemotright>"
show "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G f = g"
proof
have \<epsilon>a: "C.inverse_arrows (\<epsilon> a) (C.inv (\<epsilon> a))"
using a C.inv_is_inverse by auto
have \<epsilon>a': "C.inverse_arrows (\<epsilon> a') (C.inv (\<epsilon> a'))"
using a' C.inv_is_inverse by auto
let ?f = "\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a)"
have f: "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright>"
using a a' g \<epsilon>a \<epsilon>a' \<epsilon>.preserves_hom [of a' a' a'] \<epsilon>_inv.preserves_hom [of a a a]
by fastforce
moreover have "G ?f = g"
proof -
interpret F: faithful_functor D C F
using F_is_faithful by auto
have "F (G ?f) = F g"
proof -
have "F (G ?f) = C.inv (\<epsilon> a') \<cdot>\<^sub>C ?f \<cdot>\<^sub>C \<epsilon> a"
using f C_arr_expansion(2) [of "?f"] by auto
also have "... = (C.inv (\<epsilon> a') \<cdot>\<^sub>C \<epsilon> a') \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a) \<cdot>\<^sub>C \<epsilon> a"
using a a' f g C.comp_assoc by fastforce
also have "... = F g"
using a a' g \<epsilon>a \<epsilon>a' C.comp_inv_arr C.comp_arr_dom C.comp_cod_arr by auto
finally show ?thesis by blast
qed
moreover have "D.par (G (\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a))) g"
using f g by fastforce
ultimately show ?thesis using f g F.is_faithful by blast
qed
ultimately show "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G ?f = g" by blast
qed
qed
end
(* I'm not sure why I had to close and re-open the context here in order to
* get the G_is_full fact in the interpretation GF. *)
context equivalence_of_categories
begin
- interpretation \<epsilon>_inv: inverse_transformation C C "F o G" C.map \<epsilon> ..
- interpretation \<eta>_inv: inverse_transformation D D D.map "G o F" \<eta> ..
+ interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
+ interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..
lemma F_is_full:
shows "full_functor D C F"
using GF.G_is_full by simp
end
text \<open>
Traditionally the term "equivalence of categories" is also used for a functor
that is part of an equivalence of categories. However, it seems best to use
that term for a situation in which all of the structure of an equivalence is
explicitly given, and to have a different term for one of the functors involved.
\<close>
locale equivalence_functor =
C: category C +
D: category D +
"functor" C D G
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and G :: "'c \<Rightarrow> 'd" +
assumes induces_equivalence: "\<exists>F \<eta> \<epsilon>. equivalence_of_categories C D F G \<eta> \<epsilon>"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
end
sublocale equivalence_of_categories \<subseteq> equivalence_functor C D G
using equivalence_of_categories_axioms by (unfold_locales, blast)
text \<open>
An equivalence functor is fully faithful and essentially surjective.
\<close>
sublocale equivalence_functor \<subseteq> fully_faithful_functor C D G
proof -
obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
using induces_equivalence by blast
interpret equivalence_of_categories C D F G \<eta> \<epsilon>
using 1 by auto
show "fully_faithful_functor C D G"
using G_is_full G_is_faithful fully_faithful_functor.intro by auto
qed
sublocale equivalence_functor \<subseteq> essentially_surjective_functor C D G
proof -
obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
using induces_equivalence by blast
interpret equivalence_of_categories C D F G \<eta> \<epsilon>
using 1 by auto
show "essentially_surjective_functor C D G"
using G_is_essentially_surjective by auto
qed
text \<open>
A special case of an equivalence functor is an endofunctor \<open>F\<close> equipped with
a natural isomorphism from \<open>F\<close> to the identity functor.
\<close>
context endofunctor
begin
lemma isomorphic_to_identity_is_equivalence:
assumes "natural_isomorphism A A F A.map \<phi>"
shows "equivalence_functor A A F"
proof -
interpret \<phi>: natural_isomorphism A A F A.map \<phi>
using assms by auto
interpret \<phi>': inverse_transformation A A F A.map \<phi> ..
- interpret F\<phi>': natural_isomorphism A A F "F o F" "F o \<phi>'.map"
+ interpret F\<phi>': natural_isomorphism A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
proof -
- interpret \<tau>: horizontal_composite A A A A.map F F F \<phi>'.map F ..
- interpret F\<phi>': natural_transformation A A F "F o F" "F o \<phi>'.map"
- using comp_identity_functor functor_axioms \<tau>.natural_transformation_axioms by simp
+ interpret F\<phi>': natural_transformation A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
+ using \<phi>'.natural_transformation_axioms functor_axioms
+ horizontal_composite [of A A A.map F \<phi>'.map A F F F]
+ by simp
show "natural_isomorphism A A F (F o F) (F o \<phi>'.map)"
apply unfold_locales
using \<phi>'.components_are_iso by fastforce
qed
- interpret F\<phi>'o\<phi>': vertical_composite A A A.map F "F o F" \<phi>'.map "F o \<phi>'.map" ..
- interpret F\<phi>'o\<phi>': natural_isomorphism A A A.map "F o F" F\<phi>'o\<phi>'.map
+ interpret F\<phi>'o\<phi>': vertical_composite A A A.map F \<open>F o F\<close> \<phi>'.map \<open>F o \<phi>'.map\<close> ..
+ interpret F\<phi>'o\<phi>': natural_isomorphism A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map
using \<phi>'.natural_isomorphism_axioms F\<phi>'.natural_isomorphism_axioms
natural_isomorphisms_compose
by fast
- interpret inv_F\<phi>'o\<phi>': inverse_transformation A A A.map "F o F" F\<phi>'o\<phi>'.map ..
+ interpret inv_F\<phi>'o\<phi>': inverse_transformation A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map ..
interpret F: equivalence_of_categories A A F F F\<phi>'o\<phi>'.map inv_F\<phi>'o\<phi>'.map ..
show ?thesis ..
qed
end
text \<open>
An adjoint equivalence is an equivalence of categories that is also an adjunction.
\<close>
locale adjoint_equivalence =
unit_counit_adjunction C D F G \<eta> \<epsilon> +
\<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
\<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and F :: "'d \<Rightarrow> 'c"
and G :: "'c \<Rightarrow> 'd"
and \<eta> :: "'d \<Rightarrow> 'd"
and \<epsilon> :: "'c \<Rightarrow> 'c"
text \<open>
An adjoint equivalence is clearly an equivalence of categories.
\<close>
sublocale adjoint_equivalence \<subseteq> equivalence_of_categories ..
context adjoint_equivalence
begin
text \<open>
The triangle identities for an adjunction reduce to inverse relations when
\<open>\<eta>\<close> and \<open>\<epsilon>\<close> are natural isomorphisms.
\<close>
lemma triangle_G':
assumes "C.ide a"
shows "D.inverse_arrows (\<eta> (G a)) (G (\<epsilon> a))"
proof
show "D.ide (G (\<epsilon> a) \<cdot>\<^sub>D \<eta> (G a))"
using assms triangle_G G\<epsilon>o\<eta>G.map_simp_ide by fastforce
thus "D.ide (\<eta> (G a) \<cdot>\<^sub>D G (\<epsilon> a))"
using assms D.section_retraction_of_iso [of "G (\<epsilon> a)" "\<eta> (G a)"] by auto
qed
lemma triangle_F':
assumes "D.ide b"
shows "C.inverse_arrows (F (\<eta> b)) (\<epsilon> (F b))"
proof
show "C.ide (\<epsilon> (F b) \<cdot>\<^sub>C F (\<eta> b))"
using assms triangle_F \<epsilon>FoF\<eta>.map_simp_ide by auto
thus "C.ide (F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b))"
using assms C.section_retraction_of_iso [of "\<epsilon> (F b)" "F (\<eta> b)"] by auto
qed
text \<open>
An adjoint equivalence can be dualized by interchanging the two functors and inverting
the natural isomorphisms. This is somewhat awkward to prove, but probably useful to have
done it once and for all.
\<close>
lemma dual_equivalence:
assumes "adjoint_equivalence C D F G \<eta> \<epsilon>"
shows "adjoint_equivalence D C G F (inverse_transformation.map C C (C.map) \<epsilon>)
(inverse_transformation.map D D (G o F) \<eta>)"
proof -
interpret adjoint_equivalence C D F G \<eta> \<epsilon> using assms by auto
- interpret \<epsilon>': inverse_transformation C C "F o G" C.map \<epsilon> ..
- interpret \<eta>': inverse_transformation D D D.map "G o F" \<eta> ..
- have 1: "G o (F o G) = (G o F) o G \<and> F o (G o F) = (F o G) o F" by auto
- interpret G\<epsilon>': natural_transformation C D G "(G o F) o G" "G o \<epsilon>'.map"
- proof -
- interpret G\<epsilon>': horizontal_composite C C D C.map "F o G" G G \<epsilon>'.map G ..
- show "natural_transformation C D G ((G o F) o G) (G o \<epsilon>'.map)"
- using 1 G\<epsilon>'.natural_transformation_axioms G.natural_transformation_axioms by auto
- qed
- interpret \<eta>'G: natural_transformation C D "(G o F) o G" G "\<eta>'.map o G"
+ interpret \<epsilon>': inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
+ interpret \<eta>': inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
+ interpret G\<epsilon>': natural_transformation C D G \<open>G o F o G\<close> \<open>G o \<epsilon>'.map\<close>
proof -
- interpret \<eta>'G: horizontal_composite C D D G G "G o F" D.map G \<eta>'.map ..
- show "natural_transformation C D ((G o F) o G) G (\<eta>'.map o G)"
- using 1 \<eta>'G.natural_transformation_axioms G.natural_transformation_axioms by auto
+ have "natural_transformation C D G (G o (F o G)) (G o \<epsilon>'.map)"
+ using G.natural_transformation_axioms \<epsilon>'.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ thus "natural_transformation C D G (G o F o G) (G o \<epsilon>'.map)"
+ using o_assoc by metis
qed
- interpret \<epsilon>'F: natural_transformation D C F "((F o G) o F)" "\<epsilon>'.map o F"
+ interpret \<eta>'G: natural_transformation C D \<open>G o F o G\<close> G \<open>\<eta>'.map o G\<close>
+ using \<eta>'.natural_transformation_axioms G.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ interpret \<epsilon>'F: natural_transformation D C F \<open>F o G o F\<close> \<open>\<epsilon>'.map o F\<close>
+ using \<epsilon>'.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ interpret F\<eta>': natural_transformation D C \<open>F o G o F\<close> F \<open>F o \<eta>'.map\<close>
proof -
- interpret \<epsilon>'F: horizontal_composite D C C F F C.map "F o G" F \<epsilon>'.map ..
- show "natural_transformation D C F ((F o G) o F) (\<epsilon>'.map o F)"
- using 1 \<epsilon>'F.natural_transformation_axioms F.natural_transformation_axioms by auto
+ have "natural_transformation D C (F o (G o F)) F (F o \<eta>'.map)"
+ using \<eta>'.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by fastforce
+ thus "natural_transformation D C (F o G o F) F (F o \<eta>'.map)"
+ using o_assoc by metis
qed
- interpret F\<eta>': natural_transformation D C "(F o G) o F" F "F o \<eta>'.map"
- proof -
- interpret F\<eta>': horizontal_composite D D C "G o F" D.map F F \<eta>'.map F ..
- show "natural_transformation D C ((F o G) o F) F (F o \<eta>'.map)"
- using 1 F\<eta>'.natural_transformation_axioms F.natural_transformation_axioms by auto
- qed
- interpret F\<eta>'o\<epsilon>'F: vertical_composite D C F "(F o G) o F" F "\<epsilon>'.map o F" "F o \<eta>'.map" ..
- interpret \<eta>'GoG\<epsilon>': vertical_composite C D G "G o F o G" G "G o \<epsilon>'.map" "\<eta>'.map o G" ..
+ interpret F\<eta>'o\<epsilon>'F: vertical_composite D C F \<open>(F o G) o F\<close> F \<open>\<epsilon>'.map o F\<close> \<open>F o \<eta>'.map\<close> ..
+ interpret \<eta>'GoG\<epsilon>': vertical_composite C D G \<open>G o F o G\<close> G \<open>G o \<epsilon>'.map\<close> \<open>\<eta>'.map o G\<close> ..
show ?thesis
proof
show "\<eta>'GoG\<epsilon>'.map = G"
proof (intro NaturalTransformation.eqI)
show "natural_transformation C D G G G"
using G.natural_transformation_axioms by auto
show "natural_transformation C D G G \<eta>'GoG\<epsilon>'.map"
using \<eta>'GoG\<epsilon>'.natural_transformation_axioms by auto
show "\<And>a. C.ide a \<Longrightarrow> \<eta>'GoG\<epsilon>'.map a = G a"
proof -
fix a
assume a: "C.ide a"
show "\<eta>'GoG\<epsilon>'.map a = G a"
using a \<eta>'GoG\<epsilon>'.map_simp_ide triangle_G'
\<eta>.components_are_iso \<epsilon>.components_are_iso G.preserves_ide
\<eta>'.inverts_components \<epsilon>'.inverts_components
D.inverse_unique G.preserves_inverse_arrows G\<epsilon>o\<eta>G.map_simp_ide
D.inverse_arrows_sym triangle_G
by (metis o_apply)
qed
qed
show "F\<eta>'o\<epsilon>'F.map = F"
proof (intro NaturalTransformation.eqI)
show "natural_transformation D C F F F"
using F.natural_transformation_axioms by auto
show "natural_transformation D C F F F\<eta>'o\<epsilon>'F.map"
using F\<eta>'o\<epsilon>'F.natural_transformation_axioms by auto
show "\<And>b. D.ide b \<Longrightarrow> F\<eta>'o\<epsilon>'F.map b = F b"
proof -
fix b
assume b: "D.ide b"
show "F\<eta>'o\<epsilon>'F.map b = F b"
using b F\<eta>'o\<epsilon>'F.map_simp_ide \<epsilon>FoF\<eta>.map_simp_ide triangle_F triangle_F'
\<eta>.components_are_iso \<epsilon>.components_are_iso G.preserves_ide
\<eta>'.inverts_components \<epsilon>'.inverts_components F.preserves_ide
C.inverse_unique F.preserves_inverse_arrows C.inverse_arrows_sym
by (metis o_apply)
qed
qed
qed
qed
end
text \<open>
Every fully faithful and essentially surjective functor underlies an adjoint equivalence.
To prove this without repeating things that were already proved in @{theory Category3.Adjunction},
we first show that a fully faithful and essentially surjective functor is a left adjoint
functor, and then we show that if the left adjoint in a unit-counit adjunction is
fully faithful and essentially surjective, then the unit and counit are natural isomorphisms;
hence the adjunction is in fact an adjoint equivalence.
\<close>
locale fully_faithful_and_essentially_surjective_functor =
C: category C +
D: category D +
fully_faithful_functor D C F +
essentially_surjective_functor D C F
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and F :: "'d \<Rightarrow> 'c"
begin
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
lemma is_left_adjoint_functor:
shows "left_adjoint_functor D C F"
proof
fix y
assume y: "C.ide y"
let ?x = "SOME x. D.ide x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>)"
let ?e = "SOME e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>"
have "\<exists>x e. C.iso e \<and> terminal_arrow_from_functor D C F x y e"
proof -
have "\<exists>x. C.iso ?e \<and> terminal_arrow_from_functor D C F x y ?e"
proof -
have x: "D.ide ?x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>)"
proof -
obtain x where x: "D.ide x \<and> C.isomorphic (F x) y"
using y essentially_surjective D.isomorphic_def by blast
obtain e where e: "C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>"
using y x by auto
hence "\<exists>x. D.ide x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>)"
using x by auto
thus "D.ide ?x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>)"
using someI_ex [of "\<lambda>x. D.ide x \<and> (\<exists>e. C.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>C y\<guillemotright>)"] by blast
qed
hence e: "C.iso ?e \<and> \<guillemotleft>?e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>"
using someI_ex [of "\<lambda>e. C.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>C y\<guillemotright>"] by blast
interpret arrow_from_functor D C F ?x y ?e
using x e by (unfold_locales, simp)
interpret terminal_arrow_from_functor D C F ?x y ?e
proof
fix x' f
assume 1: "arrow_from_functor D C F x' y f"
interpret f: arrow_from_functor D C F x' y f
using 1 by simp
have f: "\<guillemotleft>f: F x' \<rightarrow>\<^sub>C y\<guillemotright>"
by (meson f.arrow)
show "\<exists>!g. is_coext x' f g"
proof
let ?g = "SOME g. \<guillemotleft>g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F g = C.inv ?e \<cdot>\<^sub>C f"
have g: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F ?g = C.inv ?e \<cdot>\<^sub>C f"
proof -
have "\<exists>g. \<guillemotleft>g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F g = C.inv ?e \<cdot>\<^sub>C f"
using f e x f.arrow
by (meson C.comp_in_homI C.inv_in_hom is_full)
thus ?thesis
using someI_ex [of "\<lambda>g. \<guillemotleft>g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> F g = C.inv ?e \<cdot>\<^sub>C f"] by blast
qed
show 1: "is_coext x' f ?g"
proof -
have "\<guillemotleft>?g : x' \<rightarrow>\<^sub>D ?x\<guillemotright>"
using g by simp
moreover have "?e \<cdot>\<^sub>C F ?g = f"
proof -
have "?e \<cdot>\<^sub>C F ?g = ?e \<cdot>\<^sub>C C.inv ?e \<cdot>\<^sub>C f"
using g by simp
also have "... = (?e \<cdot>\<^sub>C C.inv ?e) \<cdot>\<^sub>C f"
using e f C.inv_in_hom by (metis C.comp_assoc)
also have "... = f"
proof -
have "?e \<cdot>\<^sub>C C.inv ?e = y"
using e C.comp_arr_inv [of ?e] C.inv_is_inverse by auto
thus ?thesis
using f C.comp_cod_arr by auto
qed
finally show ?thesis by blast
qed
ultimately show ?thesis
unfolding is_coext_def by simp
qed
show "\<And>g'. is_coext x' f g' \<Longrightarrow> g' = ?g"
proof -
fix g'
assume g': "is_coext x' f g'"
have 2: "\<guillemotleft>g' : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>C F g' = f" using g' is_coext_def by simp
have 3: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>D ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>C F ?g = f" using 1 is_coext_def by simp
have "F g' = F ?g"
using e 2 3 C.iso_is_section C.section_is_mono C.monoE by blast
moreover have "D.par g' ?g"
using 2 3 by fastforce
ultimately show "g' = ?g"
using is_faithful [of g' ?g] by simp
qed
qed
qed
show ?thesis
using e terminal_arrow_from_functor_axioms by auto
qed
thus ?thesis by auto
qed
thus "\<exists>x e. terminal_arrow_from_functor D C F x y e" by blast
qed
lemma is_equivalence_functor:
shows "equivalence_functor D C F"
proof
interpret left_adjoint_functor D C F
using is_left_adjoint_functor by blast
interpret equivalence_of_categories C D F G \<eta> \<epsilon>
proof
show 1: "\<And>a. C.ide a \<Longrightarrow> C.iso (\<epsilon> a)"
proof -
fix a
assume a: "C.ide a"
- interpret \<epsilon>a: terminal_arrow_from_functor D C F "G a" a "\<epsilon> a"
+ interpret \<epsilon>a: terminal_arrow_from_functor D C F \<open>G a\<close> a \<open>\<epsilon> a\<close>
using a \<phi>\<psi>.has_terminal_arrows_from_functor [of a] by blast
have "C.retraction (\<epsilon> a)"
proof -
obtain b \<phi> where \<phi>: "D.ide b \<and> C.iso \<phi> \<and> \<guillemotleft>\<phi>: F b \<rightarrow>\<^sub>C a\<guillemotright>"
using a essentially_surjective by blast
interpret \<phi>: arrow_from_functor D C F b a \<phi>
using \<phi> by (unfold_locales, simp)
let ?g = "\<epsilon>a.the_coext b \<phi>"
have 1: "\<guillemotleft>?g : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> \<epsilon> a \<cdot>\<^sub>C F ?g = \<phi>"
using \<phi>.arrow_from_functor_axioms \<epsilon>a.the_coext_prop [of b \<phi>] by simp
have "a = (\<epsilon> a \<cdot>\<^sub>C F ?g) \<cdot>\<^sub>C C.inv \<phi>"
using a 1 \<phi> C.comp_cod_arr \<epsilon>.preserves_hom [of a a a]
C.invert_side_of_triangle(2) [of "\<epsilon> a \<cdot>\<^sub>C F ?g" a \<phi>]
by auto
also have "... = \<epsilon> a \<cdot>\<^sub>C F ?g \<cdot>\<^sub>C C.inv \<phi>"
proof -
have "C.seq (\<epsilon> a) (F ?g)"
using a 1 \<epsilon>.preserves_hom [of a a a] by fastforce
moreover have "C.seq (F ?g) (C.inv \<phi>)"
using a 1 \<phi> C.inv_in_hom [of \<phi> "F b" a] by blast
ultimately show ?thesis using C.comp_assoc by auto
qed
finally have "\<exists>f. C.ide (\<epsilon> a \<cdot>\<^sub>C f)"
using a by metis
thus ?thesis
unfolding C.retraction_def by blast
qed
moreover have "C.mono (\<epsilon> a)"
proof
show "C.arr (\<epsilon> a)"
using a by simp
show "\<And>f f'. C.seq (\<epsilon> a) f \<and> C.seq (\<epsilon> a) f' \<and> \<epsilon> a \<cdot>\<^sub>C f = \<epsilon> a \<cdot>\<^sub>C f' \<Longrightarrow> f = f'"
proof -
fix f f'
assume ff': "C.seq (\<epsilon> a) f \<and> C.seq (\<epsilon> a) f' \<and> \<epsilon> a \<cdot>\<^sub>C f = \<epsilon> a \<cdot>\<^sub>C f'"
have f: "\<guillemotleft>f : C.dom f \<rightarrow>\<^sub>C F (G a)\<guillemotright>"
using a ff' \<epsilon>.preserves_hom [of a a a] by fastforce
have f': "\<guillemotleft>f' : C.dom f' \<rightarrow>\<^sub>C F (G a)\<guillemotright>"
using a ff' \<epsilon>.preserves_hom [of a a a] by fastforce
have par: "C.par f f'"
using f f' ff' C.dom_comp [of "\<epsilon> a" f] by force
obtain b' \<phi> where \<phi>: "D.ide b' \<and> C.iso \<phi> \<and> \<guillemotleft>\<phi>: F b' \<rightarrow>\<^sub>C C.dom f\<guillemotright>"
using par essentially_surjective C.ide_dom [of f] by blast
have 1: "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi> = \<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>"
proof -
have "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi> = (\<epsilon> a \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<phi>"
proof -
have "C.seq f \<phi>" using par \<phi> by auto
moreover have "C.seq (\<epsilon> a) f" using ff' by blast
ultimately show ?thesis using C.comp_assoc by auto
qed
also have "... = (\<epsilon> a \<cdot>\<^sub>C f') \<cdot>\<^sub>C \<phi>"
using ff' by argo
also have "... = \<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>"
proof -
have "C.seq f' \<phi>" using par \<phi> by auto
moreover have "C.seq (\<epsilon> a) f'" using ff' by blast
ultimately show ?thesis using C.comp_assoc by auto
qed
finally show ?thesis by blast
qed
obtain g where g: "\<guillemotleft>g : b' \<rightarrow>\<^sub>D G a\<guillemotright> \<and> F g = f \<cdot>\<^sub>C \<phi>"
using a f \<phi> is_full [of "G a" b' "f \<cdot>\<^sub>C \<phi>"] by auto
obtain g' where g': "\<guillemotleft>g' : b' \<rightarrow>\<^sub>D G a\<guillemotright> \<and> F g' = f' \<cdot>\<^sub>C \<phi>"
using a f' par \<phi> is_full [of "G a" b' "f' \<cdot>\<^sub>C \<phi>"] by auto
- interpret f\<phi>: arrow_from_functor D C F b' a "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>"
+ interpret f\<phi>: arrow_from_functor D C F b' a \<open>\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>\<close>
using a \<phi> f \<epsilon>.preserves_hom [of a a a]
by (unfold_locales, fastforce)
- interpret f'\<phi>: arrow_from_functor D C F b' a "\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>"
+ interpret f'\<phi>: arrow_from_functor D C F b' a \<open>\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>\<close>
using a \<phi> f' par \<epsilon>.preserves_hom [of a a a]
by (unfold_locales, fastforce)
have "\<epsilon>a.is_coext b' (\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>) g"
unfolding \<epsilon>a.is_coext_def using g 1 by auto
moreover have "\<epsilon>a.is_coext b' (\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>) g'"
unfolding \<epsilon>a.is_coext_def using g' 1 by auto
ultimately have "g = g'"
using 1 f\<phi>.arrow_from_functor_axioms f'\<phi>.arrow_from_functor_axioms
\<epsilon>a.the_coext_unique [of b' "\<epsilon> a \<cdot>\<^sub>C f \<cdot>\<^sub>C \<phi>" g]
\<epsilon>a.the_coext_unique [of b' "\<epsilon> a \<cdot>\<^sub>C f' \<cdot>\<^sub>C \<phi>" g']
by auto
hence "f \<cdot>\<^sub>C \<phi> = f' \<cdot>\<^sub>C \<phi>"
using g g' is_faithful by argo
thus "f = f'"
using \<phi> f f' par C.iso_is_retraction C.retraction_is_epi
C.epiE [of \<phi> f f']
by auto
qed
qed
ultimately show "C.iso (\<epsilon> a)"
using C.iso_iff_mono_and_retraction by simp
qed
- interpret \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
+ interpret \<epsilon>: natural_isomorphism C C \<open>F o G\<close> C.map \<epsilon>
using 1 by (unfold_locales, auto)
- interpret \<epsilon>F: natural_isomorphism D C "F o G o F" F "\<epsilon>F.map"
+ interpret \<epsilon>F: natural_isomorphism D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close>
using \<epsilon>.components_are_iso by (unfold_locales, simp)
show "\<And>a. D.ide a \<Longrightarrow> D.iso (\<eta> a)"
proof -
fix a
assume a: "D.ide a"
- have 1: "C.iso (\<epsilon>F.map a)"
+ have 1: "C.iso ((\<epsilon> o F) a)"
using a \<epsilon>.components_are_iso by simp
- moreover have "\<epsilon>F.map a \<cdot>\<^sub>C F\<eta>.map a = F a"
+ moreover have "(\<epsilon> o F) a \<cdot>\<^sub>C (F o \<eta>) a = F a"
using a \<eta>\<epsilon>.triangle_F \<epsilon>FoF\<eta>.map_simp_ide by simp
- ultimately have "C.inverse_arrows (\<epsilon>F.map a) (F\<eta>.map a)"
+ ultimately have "C.inverse_arrows ((\<epsilon> o F) a) ((F o \<eta>) a)"
using a C.section_retraction_of_iso by simp
- hence "C.iso (F\<eta>.map a)"
+ hence "C.iso ((F o \<eta>) a)"
using C.iso_inv_iso by blast
thus "D.iso (\<eta> a)"
using a reflects_iso [of "\<eta> a"] by fastforce
qed
qed
(*
* Uggh, I should have started with "right_adjoint_functor C D G" so that the
* following would come out right. Instead, another step is needed to dualize.
* TODO: Maybe re-work this later.
*)
interpret adjoint_equivalence C D F G \<eta> \<epsilon> ..
- interpret \<epsilon>': inverse_transformation C C "F o G" C.map \<epsilon> ..
- interpret \<eta>': inverse_transformation D D D.map "G o F" \<eta> ..
+ interpret \<epsilon>': inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
+ interpret \<eta>': inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
interpret E: adjoint_equivalence D C G F \<epsilon>'.map \<eta>'.map
using adjoint_equivalence_axioms dual_equivalence by blast
have "equivalence_of_categories D C G F \<epsilon>'.map \<eta>'.map" ..
thus "\<exists>G \<eta> \<epsilon>. equivalence_of_categories D C G F \<eta> \<epsilon>" by blast
qed
end
sublocale fully_faithful_and_essentially_surjective_functor \<subseteq> equivalence_functor D C F
using is_equivalence_functor by blast
end
diff --git a/thys/Category3/FreeCategory.thy b/thys/Category3/FreeCategory.thy
--- a/thys/Category3/FreeCategory.thy
+++ b/thys/Category3/FreeCategory.thy
@@ -1,1049 +1,569 @@
(* Title: FreeCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter FreeCategory
theory FreeCategory
-imports Category AbstractedCategory
+imports Category ConcreteCategory
begin
text\<open>
This theory defines locales for constructing the free category generated by
a graph, as well as some special cases, including the discrete category generated
by a set of objects, the ``quiver'' generated by a set of arrows, and a ``parallel pair''
of arrows, which is the diagram shape required for equalizers.
Other diagram shapes can be constructed in a similar fashion.
- The development looks more complicated that it really is, for two reasons:
- first, for each particular construction once the desired category is obtained it is
- necessary to establish facts that completely characterize its structure and allow it to be
- used in applications; and second, for each construction we define an opaque arrow type
- to ensure that client theories depend only on the explicit characterizing facts and
- not on any properties implicit in the particular construction.
\<close>
section Graphs
text\<open>
The following locale gives a definition of graphs in a traditional style.
\<close>
locale graph =
fixes Obj :: "'obj set"
and Arr :: "'arr set"
and Dom :: "'arr \<Rightarrow> 'obj"
and Cod :: "'arr \<Rightarrow> 'obj"
assumes dom_is_obj: "x \<in> Arr \<Longrightarrow> Dom x \<in> Obj"
and cod_is_obj: "x \<in> Arr \<Longrightarrow> Cod x \<in> Obj"
begin
text\<open>
The list of arrows @{term p} forms a path from object @{term x} to object @{term y}
if the domains and codomains of the arrows match up in the expected way.
\<close>
definition path
where "path x y p \<equiv> (p = [] \<and> x = y \<and> x \<in> Obj) \<or>
(p \<noteq> [] \<and> x = Dom (hd p) \<and> y = Cod (last p) \<and>
(\<forall>n. n \<ge> 0 \<and> n < length p \<longrightarrow> nth p n \<in> Arr) \<and>
(\<forall>n. n \<ge> 0 \<and> n < (length p)-1 \<longrightarrow> Cod (nth p n) = Dom (nth p (n+1))))"
lemma path_Obj:
assumes "x \<in> Obj"
shows "path x x []"
using assms path_def by simp
lemma path_single_Arr:
assumes "x \<in> Arr"
shows "path (Dom x) (Cod x) [x]"
using assms path_def by simp
lemma path_concat:
assumes "path x y p" and "path y z q"
shows "path x z (p @ q)"
proof -
have "p = [] \<or> q = [] \<Longrightarrow> ?thesis"
using assms path_def by auto
moreover have "p \<noteq> [] \<and> q \<noteq> [] \<Longrightarrow> ?thesis"
proof -
assume pq: "p \<noteq> [] \<and> q \<noteq> []"
have Cod_last: "Cod (last p) = Cod (nth (p @ q) ((length p)-1))"
using assms pq by (simp add: last_conv_nth nth_append)
moreover have Dom_hd: "Dom (hd q) = Dom (nth (p @ q) (length p))"
using assms pq by (simp add: hd_conv_nth less_not_refl2 nth_append)
show ?thesis
proof -
have 1: "\<And>n. n \<ge> 0 \<and> n < length (p @ q) \<Longrightarrow> nth (p @ q) n \<in> Arr"
proof -
fix n
assume n: "n \<ge> 0 \<and> n < length (p @ q)"
have "(n \<ge> 0 \<and> n < length p) \<or> (n \<ge> length p \<and> n < length (p @ q))"
using n by auto
thus "nth (p @ q) n \<in> Arr"
using assms pq nth_append path_def le_add_diff_inverse length_append
less_eq_nat.simps(1) nat_add_left_cancel_less
by metis
qed
have 2: "\<And>n. n \<ge> 0 \<and> n < length (p @ q) - 1 \<Longrightarrow>
Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
proof -
fix n
assume n: "n \<ge> 0 \<and> n < length (p @ q) - 1"
have 1: "(n \<ge> 0 \<and> n < (length p) - 1) \<or> (n \<ge> length p \<and> n < length (p @ q) - 1)
\<or> n = (length p) - 1"
using n by auto
thus "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
proof -
have "n \<ge> 0 \<and> n < (length p) - 1 \<Longrightarrow> ?thesis"
using assms pq nth_append path_def by (metis add_lessD1 less_diff_conv)
moreover have "n = (length p) - 1 \<Longrightarrow> ?thesis"
using assms pq nth_append path_def Dom_hd Cod_last by simp
moreover have "n \<ge> length p \<and> n < length (p @ q) - 1 \<Longrightarrow> ?thesis"
proof -
assume 1: "n \<ge> length p \<and> n < length (p @ q) - 1"
have "Cod (nth (p @ q) n) = Cod (nth q (n - length p))"
using 1 nth_append leD by metis
also have "... = Dom (nth q (n - length p + 1))"
using 1 assms(2) path_def by auto
also have "... = Dom (nth (p @ q) (n + 1))"
using 1 nth_append
by (metis Nat.add_diff_assoc2 ex_least_nat_le le_0_eq le_add1 le_neq_implies_less
le_refl le_trans length_0_conv pq)
finally show "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n + 1))" by auto
qed
ultimately show ?thesis using 1 by auto
qed
qed
show ?thesis
unfolding path_def using assms pq path_def hd_append2 Cod_last Dom_hd 1 2
by simp
qed
qed
ultimately show ?thesis by auto
qed
end
section "Free Categories"
text\<open>
- The free category generated by a graph has as its arrows all triples @{term "(x, y, p)"},
+ The free category generated by a graph has as its arrows all triples @{term "MkArr x y p"},
where @{term x} and @{term y} are objects and @{term p} is a path from @{term x} to @{term y}.
- We use an option type to provide a value to be used for @{term null}.
+ We construct it here an instance of the general construction given by the
+ @{locale concrete_category} locale.
\<close>
locale free_category =
G: graph Obj Arr D C
for Obj :: "'obj set"
and Arr :: "'arr set"
and D :: "'arr \<Rightarrow> 'obj"
and C :: "'arr \<Rightarrow> 'obj"
begin
- typedef ('o, 'a) arr = "UNIV :: ('o * 'o * 'a list) option set" ..
-
- definition Null
- where "Null = Abs_arr None"
-
- definition Dom
- where "Dom f = fst (the (Rep_arr f))"
-
- definition Cod
- where "Cod f = fst (snd (the (Rep_arr f)))"
-
- definition Path
- where "Path f = snd (snd (the (Rep_arr f)))"
-
- definition mkArr
- where "mkArr x y p \<equiv> if G.path x y p then Abs_arr (Some (x, y, p)) else Null"
-
- abbreviation isArr
- where "isArr f \<equiv> f \<noteq> Null \<and> G.path (Dom f) (Cod f) (Path f)"
-
- lemma mkArr_not_Null:
- shows "mkArr x y p \<noteq> Null \<longleftrightarrow> G.path x y p"
- using mkArr_def
- by (metis Abs_arr_inverse Null_def UNIV_I option.distinct(1))
-
- lemma Dom_mkArr [simp]:
- assumes "mkArr x y p \<noteq> Null"
- shows "Dom (mkArr x y p) = x"
- using assms mkArr_def Dom_def
- by (metis Abs_arr_inverse UNIV_I fst_conv option.sel)
-
- lemma Cod_mkArr [simp]:
- assumes "mkArr x y p \<noteq> Null"
- shows "Cod (mkArr x y p) = y"
- using assms mkArr_def Cod_def
- by (metis Abs_arr_inverse UNIV_I fst_conv snd_conv option.sel)
+ type_synonym ('o, 'a) arr = "('o, 'a list) concrete_category.arr"
- lemma Path_mkArr [simp]:
- assumes "mkArr x y p \<noteq> Null"
- shows "Path (mkArr x y p) = p"
- using assms mkArr_def Path_def
- by (metis Abs_arr_inverse UNIV_I snd_conv option.sel)
-
- lemma mkArr_Path [simp]:
- assumes "isArr f"
- shows "mkArr (Dom f) (Cod f) (Path f) = f"
- by (metis Cod_def Dom_def Null_def Path_def Rep_arr_inverse assms mkArr_def
- option.exhaust_sel surjective_pairing)
-
- lemma Dom_in_Obj:
- assumes "isArr f"
- shows "Dom f \<in> Obj"
- using assms G.path_def G.dom_is_obj hd_conv_nth leI length_greater_0_conv
- less_numeral_extra(3)
- by fastforce
+ sublocale concrete_category \<open>Obj :: 'obj set\<close> \<open>\<lambda>x y. Collect (G.path x y)\<close>
+ \<open>\<lambda>_. []\<close> \<open>\<lambda>_ _ _ g f. f @ g\<close>
+ using G.path_Obj G.path_concat
+ by (unfold_locales, simp_all)
- lemma Cod_in_Obj:
- assumes "isArr f"
- shows "Cod f \<in> Obj"
- using assms G.path_def G.cod_is_obj
- by (metis diff_less last_conv_nth leI length_greater_0_conv less_imp_le_nat neq0_conv
- not_one_le_zero)
-
- text\<open>
- Composition is concatenation of paths.
-\<close>
-
- definition comp (infixr "\<cdot>" 55)
- where "g \<cdot> f \<equiv> if isArr g \<and> isArr f \<and> Dom g = Cod f
- then mkArr (Dom f) (Cod g) (Path f @ Path g)
- else Null"
-
- interpretation partial_magma comp
- using comp_def by (unfold_locales, metis)
-
+ abbreviation comp (infixr "\<cdot>" 55)
+ where "comp \<equiv> COMP"
notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
- lemma null_char:
- shows "null = Null"
- by (metis comp_null(1) comp_def)
-
- lemma in_Obj_implies_ide:
- assumes "x \<in> Obj"
- shows "ide (mkArr x x [])"
- unfolding ide_def
- using assms comp_def null_char Cod_mkArr Dom_mkArr Path_mkArr append_Nil append_Nil2
- mkArr_Path G.path_Obj mkArr_not_Null
- by fastforce
-
- lemma has_domain_char:
- shows "domains f \<noteq> {} \<longleftrightarrow> isArr f"
- proof
- show "domains f \<noteq> {} \<Longrightarrow> isArr f"
- unfolding domains_def
- using Collect_empty_eq comp_def null_char by fastforce
- show "isArr f \<Longrightarrow> domains f \<noteq> {}"
- proof (unfold domains_def)
- assume 1: "f \<noteq> Null \<and> G.path (Dom f) (Cod f) (Path f)"
- hence 2: "Dom f \<in> Obj"
- using Dom_in_Obj by force
- hence "comp f (mkArr (Dom f) (Dom f) []) \<noteq> null"
- using 1 by (simp add: G.path_Obj comp_def mkArr_not_Null null_char)
- thus "{a. ide a \<and> comp f a \<noteq> null} \<noteq> {}"
- using 2 in_Obj_implies_ide by auto
- qed
- qed
-
- lemma has_codomain_char:
- shows "codomains f \<noteq> {} \<longleftrightarrow> isArr f"
- proof
- show "codomains f \<noteq> {} \<Longrightarrow> isArr f"
- unfolding codomains_def
- using Collect_empty_eq comp_def null_char by fastforce
- show "isArr f \<Longrightarrow> codomains f \<noteq> {}"
- proof (unfold codomains_def)
- assume 1: "f \<noteq> Null \<and> G.path (Dom f) (Cod f) (Path f)"
- hence 2: "Cod f \<in> Obj"
- using Cod_in_Obj by force
- hence "comp (mkArr (Cod f) (Cod f) []) f \<noteq> null"
- using 1 G.path_Obj comp_def mkArr_not_Null null_char by auto
- thus "{b. ide b \<and> comp b f \<noteq> null} \<noteq> {}"
- using 2 in_Obj_implies_ide by auto
- qed
- qed
-
- interpretation category comp
- proof
- fix f g h
- show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
- using comp_def arr_def G.path_concat Path_mkArr has_codomain_char null_char
- by auto
- show "(domains f \<noteq> {}) = (codomains f \<noteq> {})"
- by (simp add: has_domain_char has_codomain_char)
- assume gf: "seq g f" and hgf: "seq h (g \<cdot> f)"
- have isArr: "isArr h \<and> isArr g"
- using gf hgf by (metis comp_def not_arr_null null_char)
- then have "Dom h = Cod g"
- using gf hgf Cod_mkArr [of "Dom g" "Cod g" "Path g"]
- by (metis Cod_mkArr comp_null(2) comp_def not_arr_null)
- with isArr show "seq h g"
- using comp_def null_char mkArr_not_Null G.path_concat
- using arr_def has_domain_char by auto
- next
- fix f g h
- assume hg: "seq h g" and hgf: "seq (h \<cdot> g) f"
- have isArr: "isArr g \<and> isArr f"
- using hg hgf by (metis comp_def not_arr_null null_char)
- then have "Dom g = Cod f"
- using hg hgf Dom_mkArr [of "Dom g" "Cod g" "Path g"]
- by (metis Dom_mkArr comp_null(2) comp_def not_arr_null)
- with isArr show "seq g f"
- using comp_def null_char mkArr_not_Null G.path_concat
- using arr_def has_domain_char by auto
- next
- fix f g h
- assume gf: "seq g f" and hg: "seq h g"
- have 1: "isArr h \<and> isArr g \<and> isArr f \<and> Dom h = Cod g \<and> Dom g = Cod f"
- using gf hg comp_def null_char by (metis not_arr_null)
- show "seq (h \<cdot> g) f"
- using 1 comp_def null_char Dom_mkArr Cod_mkArr Path_mkArr mkArr_not_Null G.path_concat
- arr_def has_codomain_char
- by fastforce
- show "(h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
- using 1 comp_def null_char Dom_mkArr Cod_mkArr Path_mkArr mkArr_not_Null G.path_concat
- append_assoc
- by force
- qed
-
- lemma is_category:
- shows "category comp" ..
-
- end
-
- sublocale free_category \<subseteq> category comp
- using is_category by auto
-
- context free_category
- begin
-
- lemma arr_char:
- shows "arr f \<longleftrightarrow> isArr f"
- using has_codomain_char has_codomain_iff_arr by auto
-
- lemma dom_char:
- shows "dom f = (if arr f then mkArr (Dom f) (Dom f) [] else null)"
- proof -
- have "\<not>arr f \<Longrightarrow> dom f = null"
- by (simp add: has_domain_iff_arr dom_def)
- moreover have "arr f \<Longrightarrow> dom f = mkArr (Dom f) (Dom f) []"
- apply (intro dom_eqI)
- using Dom_in_Obj arr_char in_Obj_implies_ide
- apply auto[1]
- by (simp add: Dom_in_Obj G.path_Obj arr_char mkArr_not_Null comp_def)
- ultimately show ?thesis by auto
- qed
-
- lemma cod_char:
- shows "cod f = (if arr f then mkArr (Cod f) (Cod f) [] else null)"
- proof -
- have "\<not>arr f \<Longrightarrow> cod f = null"
- by (simp add: has_codomain_iff_arr cod_def)
- moreover have "arr f \<Longrightarrow> cod f = mkArr (Cod f) (Cod f) []"
- apply (intro cod_eqI)
- using Cod_in_Obj arr_char in_Obj_implies_ide
- apply auto[1]
- by (simp add: Cod_in_Obj G.path_Obj arr_char mkArr_not_Null comp_def)
- ultimately show ?thesis by auto
- qed
-
- lemma ide_char:
- shows "ide f \<longleftrightarrow> f \<in> (\<lambda>x. mkArr x x []) ` Obj"
- proof
- show "ide f \<Longrightarrow> f \<in> (\<lambda>x. mkArr x x []) ` Obj"
- by (metis (no_types, lifting) Dom_in_Obj ide_in_hom arr_char dom_char in_homE image_iff)
- show "f \<in> (\<lambda>x. mkArr x x []) ` Obj \<Longrightarrow> ide f"
- using in_Obj_implies_ide by auto
- qed
-
- lemma arr_empty [simp]:
- assumes "x \<in> Obj"
- shows "arr (mkArr x x [])"
- using assms by (simp add: G.path_Obj arr_char mkArr_not_Null)
+ abbreviation Path
+ where "Path \<equiv> Map"
lemma arr_single [simp]:
assumes "x \<in> Arr"
- shows "arr (mkArr (D x) (C x) [x])"
- using assms by (simp add: G.path_single_Arr arr_char mkArr_not_Null)
-
- lemma dom_mkArr [simp]:
- assumes "arr (mkArr x y p)"
- shows "dom (mkArr x y p) = mkArr x x []"
- using assms dom_char arr_char by auto
-
- lemma cod_mkArr [simp]:
- assumes "arr (mkArr x y p)"
- shows "cod (mkArr x y p) = mkArr y y []"
- using assms cod_char arr_char by auto
-
- lemma comp_mkArr [simp]:
- assumes "seq (mkArr y z q) (mkArr x y p)"
- shows "comp (mkArr y z q) (mkArr x y p) = mkArr x z (p @ q)"
- using assms arr_char comp_def by auto
-
- lemma mkArr_eqI:
- assumes "arr (mkArr a b p)"
- shows "mkArr a b p = mkArr a b p' \<longleftrightarrow> p = p'"
- using assms arr_char Path_mkArr by metis
+ shows "arr (MkArr (D x) (C x) [x])"
+ using assms
+ by (simp add: G.cod_is_obj G.dom_is_obj G.path_single_Arr)
end
section "Discrete Categories"
text\<open>
- A discrete category is a free category generated by a graph with no arrows.
+ A discrete category is a category in which every arrow is an identity.
+ We could construct it as the free category generated by a graph with no
+ arrows, but it is simpler just to apply the @{locale concrete_category}
+ construction directly.
\<close>
locale discrete_category =
- FC: free_category Obj "{} :: unit set" "\<lambda>_. undefined" "\<lambda>_. undefined"
- for Obj :: "'obj set"
+ fixes Obj :: "'obj set"
begin
- lemma FC_arr_char:
- shows "FC.arr f \<longleftrightarrow> f \<in> (\<lambda>x. FC.mkArr x x []) ` Obj"
- proof
- show "FC.arr f \<Longrightarrow> f \<in> (\<lambda>x. FC.mkArr x x []) ` Obj"
- using FC.arr_char FC.ide_char FC.mkArr_Path FC.G.path_def length_greater_0_conv
- by (metis (no_types, lifting) FC.cod_char FC.ide_cod empty_iff le_eq_less_or_eq)
- show "f \<in> (\<lambda>x. FC.mkArr x x []) ` Obj \<Longrightarrow> FC.arr f"
- using FC.ide_char by auto
- qed
-
- lemma FC_in_hom_char:
- shows "FC.in_hom f a b \<longleftrightarrow> FC.arr f \<and> f = a \<and> f = b"
- using FC.ide_char FC_arr_char by auto
-
- typedef 'a arr = "UNIV :: ('a, unit) free_category.arr set" ..
+ type_synonym 'o arr = "('o, unit) concrete_category.arr"
- interpretation AC: abstracted_category FC.comp Abs_arr Rep_arr UNIV
- using Rep_arr_inverse Abs_arr_inverse by (unfold_locales, auto)
-
- definition comp (infixr "\<cdot>" 55)
- where "comp \<equiv> AC.comp"
-
- lemma is_category:
- shows "category comp"
- using AC.category_axioms comp_def by auto
+ sublocale concrete_category \<open>Obj :: 'obj set\<close> \<open>\<lambda>x y. if x = y then {x} else {}\<close>
+ \<open>\<lambda>x. x\<close> \<open>\<lambda>_ _ x _ _. x\<close>
+ apply unfold_locales
+ apply simp_all
+ apply (metis empty_iff)
+ apply (metis empty_iff singletonD)
+ by (metis empty_iff singletonD)
- interpretation category comp
- using is_category by auto
-
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
+ abbreviation comp (infixr "\<cdot>" 55)
+ where "comp \<equiv> COMP"
+ notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
- definition mkIde
- where "mkIde x \<equiv> if x \<in> Obj then Abs_arr (FC.mkArr x x []) else null"
-
- definition toObj
- where "toObj f \<equiv> FC.Dom (Rep_arr f)"
+ lemma is_discrete:
+ shows "arr f \<longleftrightarrow> ide f"
+ using ide_char arr_char by simp
lemma arr_char:
- shows "arr f \<longleftrightarrow> f \<in> mkIde ` Obj"
- proof
- show "arr f \<Longrightarrow> f \<in> mkIde ` Obj"
- proof -
- assume f: "arr f"
- obtain A where A: "A \<in> Obj \<and> Rep_arr f = FC.mkArr A A []"
- using f AC.arr_char FC_arr_char FC.ide_char FC_in_hom_char FC.Dom_in_Obj
- FC.arr_char FC.dom_char comp_def
- by auto
- then have "f = mkIde A"
- by (metis Rep_arr_inverse mkIde_def)
- with A show ?thesis by auto
- qed
- show "f \<in> mkIde ` Obj \<Longrightarrow> arr f"
- using FC_arr_char mkIde_def AC.arr_char AC.domain_closed AC.rep_abs FC.arr_empty
- f_inv_into_f inv_into_into comp_def
- by auto
- qed
+ shows "arr f \<longleftrightarrow> Dom f \<in> Obj \<and> f = MkIde (Dom f)"
+ using is_discrete
+ by (metis (no_types, lifting) cod_char dom_char ide_MkIde ide_char ide_char')
+
+ lemma arr_char':
+ shows "arr f \<longleftrightarrow> f \<in> MkIde ` Obj"
+ using arr_char image_iff by auto
lemma dom_char:
shows "dom f = (if arr f then f else null)"
- using AC.dom_char arr_char comp_def AC.arr_char FC.ide_char FC_arr_char
- by (simp add: Rep_arr_inverse)
+ using dom_char is_discrete by simp
lemma cod_char:
shows "cod f = (if arr f then f else null)"
- using AC.cod_char comp_def Rep_arr_inverse cod_dom dom_char
- by auto
-
- lemma dom_simp [simp]:
- assumes "arr f"
- shows "dom f = f"
- using assms dom_char by simp
-
- lemma cod_simp [simp]:
- assumes "arr f"
- shows "cod f = f"
- using assms cod_char by simp
+ using cod_char is_discrete by simp
lemma in_hom_char:
shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> arr f \<and> f = a \<and> f = b"
- by auto
+ using is_discrete by auto
+ lemma seq_char:
+ shows "seq g f \<longleftrightarrow> arr f \<and> f = g"
+ using is_discrete
+ by (metis (no_types, lifting) comp_arr_dom seqE dom_char)
+
lemma comp_char:
shows "g \<cdot> f = (if seq g f then f else null)"
- using AC.comp_char comp_def comp_cod_arr in_hom_char dom_char
- by (metis (no_types, lifting) seqE)
-
- lemma comp_simp [simp]:
- assumes "seq g f"
- shows "g \<cdot> f = f"
- using assms comp_char by meson
-
- lemma is_discrete:
- shows "ide f \<longleftrightarrow> arr f"
- using arr_char dom_char in_hom_char ide_in_hom by metis
-
- lemma ide_mkIde:
- assumes "x \<in> Obj"
- shows "ide (mkIde x)"
- using assms mkIde_def arr_char image_iff is_discrete by auto
-
- lemma toObj_in_Obj:
- assumes "arr a"
- shows "toObj a \<in> Obj"
- using assms toObj_def
- by (metis AC.arr_char FC.Dom_in_Obj FC.arr_char comp_def)
-
- lemma toObj_mkIde [simp]:
- assumes "x \<in> Obj"
- shows "toObj (mkIde x) = x"
- using assms toObj_def mkIde_def Abs_arr_inverse
- by (metis FC.Dom_mkArr FC.arr_empty FC.not_arr_null FC.null_char UNIV_I)
-
- lemma mkIde_toObj [simp]:
- assumes "arr a"
- shows "mkIde (toObj a) = a"
- using assms mkIde_def
- by (metis (no_types, lifting) arr_char imageE toObj_mkIde)
+ proof -
+ have "\<not> seq g f \<Longrightarrow> ?thesis"
+ using comp_char by presburger
+ moreover have "seq g f \<Longrightarrow> ?thesis"
+ using seq_char comp_char comp_arr_ide is_discrete
+ by (metis (no_types, lifting))
+ ultimately show ?thesis by blast
+ qed
end
- sublocale discrete_category \<subseteq> category comp
- using is_category by auto
-
text\<open>
The empty category is the discrete category generated by an empty set of objects.
\<close>
locale empty_category =
discrete_category "{} :: unit set"
begin
lemma is_empty:
shows "\<not>arr f"
using arr_char by simp
end
section "Quivers"
text\<open>
A quiver is a two-object category whose non-identity arrows all point in the
same direction. A quiver is specified by giving the set of these non-identity arrows.
\<close>
locale quiver =
- FC: free_category "{False, True}" Arr "\<lambda>_. False" "\<lambda>_. True"
- for Arr :: "'arr set"
+ fixes Arr :: "'arr set"
begin
- lemma FC_ide_char:
- shows "FC.ide f \<longleftrightarrow> f = FC.mkArr False False [] \<or> f = FC.mkArr True True []"
- by (simp add: FC.ide_char)
+ type_synonym 'a arr = "(unit, 'a) concrete_category.arr"
- lemma FC_arr_char:
- shows "FC.arr f \<longleftrightarrow> f = FC.mkArr False False [] \<or> f = FC.mkArr True True [] \<or>
- f \<in> (\<lambda>x. FC.mkArr False True [x]) ` Arr"
+ sublocale free_category "{False, True}" Arr "\<lambda>_. False" "\<lambda>_. True"
+ by (unfold_locales, simp_all)
+
+ notation comp (infixr "\<cdot>" 55)
+ notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
+
+ definition Zero
+ where "Zero \<equiv> MkIde False"
+
+ definition One
+ where "One \<equiv> MkIde True"
+
+ definition fromArr
+ where "fromArr x \<equiv> if x \<in> Arr then MkArr False True [x] else null"
+
+ definition toArr
+ where "toArr f \<equiv> hd (Path f)"
+
+ lemma ide_char:
+ shows "ide f \<longleftrightarrow> f = Zero \<or> f = One"
+ proof -
+ have "ide f \<longleftrightarrow> f = MkIde False \<or> f = MkIde True"
+ using ide_char concrete_category.MkIde_Dom' concrete_category_axioms by fastforce
+ thus ?thesis
+ using comp_def Zero_def One_def by simp
+ qed
+
+ lemma arr_char':
+ shows "arr f \<longleftrightarrow> f =
+ MkIde False \<or> f = MkIde True \<or> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
proof
- assume f: "f = FC.mkArr False False [] \<or> f = FC.mkArr True True [] \<or>
- f \<in> (\<lambda>x. FC.mkArr False True [x]) ` Arr"
- show "FC.arr f" using f by auto
+ assume f: "f = MkIde False \<or> f = MkIde True \<or> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
+ show "arr f" using f by auto
next
- assume f: "FC.arr f"
- have "\<not>(f = FC.mkArr False False [] \<or> f = FC.mkArr True True [])
- \<Longrightarrow> f \<in> (\<lambda>x. FC.mkArr False True [x]) ` Arr"
+ assume f: "arr f"
+ have "\<not>(f = MkIde False \<or> f = MkIde True) \<Longrightarrow> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
proof -
- assume f': "\<not>(f = FC.mkArr False False [] \<or> f = FC.mkArr True True [])"
- have 0: "FC.Dom f = False \<and> FC.Cod f = True"
+ assume f': "\<not>(f = MkIde False \<or> f = MkIde True)"
+ have 0: "Dom f = False \<and> Cod f = True"
+ using f f' arr_char G.path_def MkArr_Map by fastforce
+ have 1: "f = MkArr False True (Path f)"
+ using f 0 arr_char MkArr_Map by force
+ moreover have "length (Path f) = 1"
proof -
- have "f \<noteq> FC.Null \<and> FC.G.path (FC.Dom f) (FC.Cod f) (FC.Path f)"
- using FC.arr_char f by blast
- then show ?thesis
- by (metis (full_types) FC.G.path_def FC.mkArr_Path f')
- qed
- hence 1: "f = FC.mkArr False True (FC.Path f)"
- proof -
- have "FC.mkArr (FC.Dom f) (FC.Cod f) (FC.Path f) = f"
- using FC.arr_char FC.mkArr_Path f by meson
- then show ?thesis
- by (simp add: 0)
- qed
- moreover have "length (FC.Path f) = 1"
- proof -
- have 2: "length (FC.Path f) \<noteq> 0"
- using f f' FC_ide_char FC.arr_char FC.mkArr_Path FC.G.path_def length_0_conv
- by (metis (full_types))
- moreover have "\<And>x y p. length p > 1 \<Longrightarrow> \<not>FC.G.path x y p"
- using FC.G.path_def less_diff_conv by auto
- thus ?thesis by (metis FC.arr_char 2 f less_one linorder_neqE_nat)
+ have "length (Path f) \<noteq> 0"
+ using f f' 0 arr_char G.path_def by simp
+ moreover have "\<And>x y p. length p > 1 \<Longrightarrow> \<not> G.path x y p"
+ using G.path_def less_diff_conv by fastforce
+ ultimately show ?thesis
+ using f arr_char
+ by (metis less_one linorder_neqE_nat mem_Collect_eq)
qed
moreover have "\<And>p. length p = 1 \<longleftrightarrow> (\<exists>x. p = [x])"
- by(auto simp: length_Suc_conv)
- ultimately have "\<exists>x. x \<in> Arr \<and> FC.Path f = [x]"
- by (metis FC.G.path_def FC.arr_char f FC.mkArr_def less_or_eq_imp_le nth_Cons_0
- zero_less_one)
- thus "f \<in> (\<lambda>x. FC.mkArr False True [x]) ` Arr"
+ by (auto simp: length_Suc_conv)
+ ultimately have "\<exists>x. x \<in> Arr \<and> Path f = [x]"
+ using f G.path_def arr_char
+ by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) le_eq_less_or_eq
+ less_numeral_extra(1) mem_Collect_eq nth_Cons_0)
+ thus "f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
using 1 by auto
qed
- thus "f = FC.mkArr False False [] \<or> f = FC.mkArr True True [] \<or>
- f \<in> (\<lambda>x. FC.mkArr False True [x]) ` Arr"
+ thus "f = MkIde False \<or> f = MkIde True \<or> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
by auto
qed
- lemma FC_seq_char:
- shows "FC.seq g f \<longleftrightarrow> FC.arr g \<and> FC.arr f \<and>
- ((f = FC.mkArr False False [] \<and> g \<noteq> FC.mkArr True True []) \<or>
- (f \<noteq> FC.mkArr False False [] \<and> g = FC.mkArr True True []))"
- proof
- assume gf: "FC.arr g \<and> FC.arr f \<and>
- ((f = FC.mkArr False False [] \<and> g \<noteq> FC.mkArr True True []) \<or>
- (f \<noteq> FC.mkArr False False [] \<and> g = FC.mkArr True True []))"
- show "FC.seq g f"
- using gf FC_arr_char FC_ide_char by (intro FC.seqI; fastforce)
- next
- assume gf: "FC.seq g f"
- hence 1: "FC.arr f \<and> FC.arr g \<and> FC.dom g = FC.cod f" by auto
- have "FC.Cod f = False \<Longrightarrow> f = FC.mkArr False False []"
- proof -
- assume "FC.Cod f = False"
- moreover have "FC.mkArr (FC.Dom f) (FC.Cod f) (FC.Path f) = f"
- using gf FC.arr_char [of f] by auto
- ultimately show ?thesis
- using FC.G.path_def FC.arr_char [of f] gf by auto
- qed
- moreover have "FC.Cod f = True \<Longrightarrow> g = FC.mkArr True True []"
+ lemma arr_char:
+ shows "arr f \<longleftrightarrow> f = Zero \<or> f = One \<or> f \<in> fromArr ` Arr"
+ using arr_char' Zero_def One_def fromArr_def by simp
+
+ lemma dom_char:
+ shows "dom f = (if arr f then
+ if f = One then One else Zero
+ else null)"
+ proof -
+ have "\<not> arr f \<Longrightarrow> ?thesis"
+ using dom_char by simp
+ moreover have "arr f \<Longrightarrow> ?thesis"
proof -
- assume f: "FC.Cod f = True"
- have "FC.Null \<noteq> g"
- using FC.arr_char gf by blast
- moreover have "FC.Cod f = FC.Dom g"
- proof -
- have "\<not> FC.Dom (FC.mkArr False False [])"
- using FC.not_arr_null FC.null_char FC_arr_char by force
- moreover have "FC.Dom (FC.mkArr True True [])"
- using FC.not_arr_null FC.null_char FC_arr_char by auto
- ultimately show ?thesis
- by (metis FC.arr_char FC.comp_def gf)
- qed
+ assume f: "arr f"
+ have 1: "dom f = MkIde (Dom f)"
+ using f dom_char by simp
+ have "f = One \<Longrightarrow> ?thesis"
+ using f 1 One_def by (metis (full_types) Dom.simps(1))
+ moreover have "f = Zero \<Longrightarrow> ?thesis"
+ using f 1 Zero_def by (metis (full_types) Dom.simps(1))
+ moreover have "f \<in> fromArr ` Arr \<Longrightarrow> ?thesis"
+ using f fromArr_def G.path_def Zero_def calculation(1) by auto
ultimately show ?thesis
- using f FC_arr_char [of g] gf by auto
+ using f arr_char by blast
qed
- ultimately have "f = FC.mkArr False False [] \<or> g = FC.mkArr True True []"
- using gf FC_arr_char by auto
- moreover have "\<not>(f = FC.mkArr False False [] \<and> g = FC.mkArr True True [])"
- using 1 by (metis FC.arr_char FC.dom_mkArr FC.Dom_mkArr FC.cod_mkArr)
- ultimately show "FC.arr g \<and> FC.arr f \<and>
- ((f = FC.mkArr False False [] \<and> g \<noteq> FC.mkArr True True []) \<or>
- (f \<noteq> FC.mkArr False False [] \<and> g = FC.mkArr True True []))"
- using 1 by metis
+ ultimately show ?thesis by blast
qed
- typedef 'a arr = "UNIV :: (bool, 'a) free_category.arr set" ..
-
- interpretation AC: abstracted_category FC.comp Abs_arr Rep_arr UNIV
- using Rep_arr_inverse Abs_arr_inverse by (unfold_locales, auto)
-
- definition comp (infixr "\<cdot>" 55)
- where "comp \<equiv> AC.comp"
-
- lemma is_category:
- shows "category comp"
+ lemma cod_char:
+ shows "cod f = (if arr f then
+ if f = Zero then Zero else One
+ else null)"
proof -
- have "category AC.comp" ..
- thus "category comp" using comp_def by auto
+ have "\<not> arr f \<Longrightarrow> ?thesis"
+ using cod_char by simp
+ moreover have "arr f \<Longrightarrow> ?thesis"
+ proof -
+ assume f: "arr f"
+ have 1: "cod f = MkIde (Cod f)"
+ using f cod_char by simp
+ have "f = One \<Longrightarrow> ?thesis"
+ using f 1 One_def by (metis (full_types) Cod.simps(1) f)
+ moreover have "f = Zero \<Longrightarrow> ?thesis"
+ using f 1 Zero_def by (metis (full_types) Cod.simps(1) f)
+ moreover have "f \<in> fromArr ` Arr \<Longrightarrow> ?thesis"
+ using f fromArr_def G.path_def One_def calculation(2) by auto
+ ultimately show ?thesis
+ using f arr_char by blast
+ qed
+ ultimately show ?thesis by blast
qed
- interpretation category comp
- using is_category by auto
-
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
-
- definition Zero
- where "Zero \<equiv> Abs_arr (FC.mkArr False False [])"
-
- definition One
- where "One \<equiv> Abs_arr (FC.mkArr True True [])"
-
- definition mkArr
- where "mkArr x \<equiv> if x \<in> Arr then Abs_arr (FC.mkArr False True [x]) else null"
-
- definition toArr
- where "toArr f \<equiv> hd (FC.Path (Rep_arr f))"
-
- lemma ide_char:
- shows "ide f \<longleftrightarrow> f = Zero \<or> f = One"
- using comp_def Zero_def One_def
- by (metis AC.ide_char Abs_arr_inverse FC_ide_char Rep_arr_inject UNIV_I)
-
- lemma not_ide_mkArr:
- shows "\<not>ide (mkArr x)"
- using mkArr_def ide_char ide_def Zero_def One_def
- by (metis Abs_arr_inverse FC.G.path_single_Arr UNIV_I FC.Cod_mkArr FC.Dom_mkArr
- FC.mkArr_not_Null)
+ lemma seq_char:
+ shows "seq g f \<longleftrightarrow> arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
+ proof
+ assume gf: "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
+ show "seq g f"
+ using gf dom_char cod_char by auto
+ next
+ assume gf: "seq g f"
+ hence 1: "arr f \<and> arr g \<and> dom g = cod f" by auto
+ have "Cod f = False \<Longrightarrow> f = Zero"
+ using gf 1 arr_char [of f] G.path_def Zero_def One_def cod_char Dom_cod
+ by (metis (no_types, lifting) Dom.simps(1))
+ moreover have "Cod f = True \<Longrightarrow> g = One"
+ using gf 1 arr_char [of f] G.path_def Zero_def One_def dom_char Dom_cod
+ by (metis (no_types, lifting) Dom.simps(1))
+ moreover have "\<not>(f = MkIde False \<and> g = MkIde True)"
+ using 1 by auto
+ ultimately show "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
+ using gf arr_char One_def Zero_def by blast
+ qed
- lemma arr_char:
- shows "arr f \<longleftrightarrow> f = Zero \<or> f = One \<or> f \<in> mkArr ` Arr"
- proof -
- obtain G :: "'arr set \<Rightarrow> ('arr \<Rightarrow> (bool, 'arr) FC.arr) \<Rightarrow> (bool, 'arr) FC.arr \<Rightarrow> 'arr"
- where "\<forall>A F h. (\<exists>h'. h' \<in> A \<and> h = F h') \<longleftrightarrow> (G A F h \<in> A \<and> h = F (G A F h))"
- by moura
- hence 1: "\<forall>a f A. (a \<in> f ` A \<longrightarrow> G A f a \<in> A \<and> a = f (G A f a)) \<and>
- (a \<notin> f ` A \<longrightarrow> (\<forall>a'. a' \<in> A \<longrightarrow> a \<noteq> f a'))"
- by auto
- have 2: "Rep_arr f = FC.mkArr False False [] \<longrightarrow> f = Zero"
- by (metis (no_types) Rep_arr_inverse Zero_def)
- have 3: "Rep_arr f = FC.mkArr True True [] \<longrightarrow> f = One"
- by (metis One_def Rep_arr_inverse)
- have "(Rep_arr f \<in> (\<lambda>a. FC.mkArr False True [a]) ` Arr \<longrightarrow>
- G Arr (\<lambda>a. FC.mkArr False True [a]) (Rep_arr f) \<in> Arr \<and>
- Rep_arr f =
- FC.mkArr False True [G Arr (\<lambda>a. FC.mkArr False True [a]) (Rep_arr f)])
- \<and> (Rep_arr f \<notin> (\<lambda>a. FC.mkArr False True [a]) ` Arr \<longrightarrow>
- (\<forall>a. a \<notin> Arr \<or> Rep_arr f \<noteq> FC.mkArr False True [a]))"
- using 1 by meson
- moreover have
- "f \<noteq> mkArr (G Arr (\<lambda>a. FC.mkArr False True [a]) (Rep_arr f))
- \<Longrightarrow> G Arr (\<lambda>a. FC.mkArr False True [a]) (Rep_arr f) \<notin> Arr \<or>
- Rep_arr f \<noteq>
- FC.mkArr False True [G Arr (\<lambda>a. FC.mkArr False True [a]) (Rep_arr f)]"
- by (metis Rep_arr_inverse mkArr_def)
- ultimately have "arr f \<Longrightarrow> f = Zero \<or> f = One \<or> f \<in> mkArr ` Arr"
- using 2 3 AC.arr_char FC_arr_char comp_def by force
- thus "arr f \<longleftrightarrow> (f = Zero \<or> f = One \<or> f \<in> mkArr ` Arr)"
- using AC.arr_char Abs_arr_inverse FC_arr_char One_def UNIV_I Zero_def comp_def
- mkArr_def
- by auto
- qed
+ lemma not_ide_fromArr:
+ shows "\<not> ide (fromArr x)"
+ using fromArr_def ide_char ide_def Zero_def One_def
+ by (metis Cod.simps(1) Dom.simps(1))
lemma in_hom_char:
shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> (a = Zero \<and> b = Zero \<and> f = Zero) \<or>
(a = One \<and> b = One \<and> f = One) \<or>
- (a = Zero \<and> b = One \<and> f \<in> mkArr ` Arr)"
+ (a = Zero \<and> b = One \<and> f \<in> fromArr ` Arr)"
proof -
have "f = Zero \<Longrightarrow> ?thesis"
- using arr_char [of f]
- by (metis ide_char ide_in_hom image_iff in_homE not_ide_mkArr)
+ using arr_char' [of f] ide_char'
+ by (metis (no_types, lifting) Zero_def category.in_homE category.in_homI
+ cod_MkArr dom_MkArr imageE is_category not_ide_fromArr)
moreover have "f = One \<Longrightarrow> ?thesis"
- using arr_char [of f]
- by (metis ide_char ide_in_hom image_iff in_homE not_ide_mkArr)
- moreover have "f \<in> mkArr ` Arr \<Longrightarrow> ?thesis"
+ using arr_char' [of f] ide_char'
+ by (metis (no_types, lifting) One_def category.in_homE category.in_homI
+ cod_MkArr dom_MkArr image_iff is_category not_ide_fromArr)
+ moreover have "f \<in> fromArr ` Arr \<Longrightarrow> ?thesis"
proof -
- assume f: "f \<in> mkArr ` Arr"
- have 1: "arr f" using f by (simp add: arr_char)
+ assume f: "f \<in> fromArr ` Arr"
+ have 1: "arr f" using f arr_char by simp
moreover have "dom f = Zero \<and> cod f = One"
- using f 1 AC.dom_char AC.cod_char AC.rep_abs comp_def mkArr_def Zero_def One_def
- by auto
+ using f 1 arr_char dom_char cod_char fromArr_def
+ by (metis (no_types, lifting) ide_char imageE not_ide_fromArr)
ultimately have "in_hom f Zero One" by auto
thus "in_hom f a b \<longleftrightarrow> (a = Zero \<and> b = Zero \<and> f = Zero \<or>
a = One \<and> b = One \<and> f = One \<or>
- a = Zero \<and> b = One \<and> f \<in> mkArr ` Arr)"
- by (metis f in_homE ide_char ide_in_hom)
+ a = Zero \<and> b = One \<and> f \<in> fromArr ` Arr)"
+ using f ide_char by auto
qed
ultimately show ?thesis
using arr_char [of f] by fast
qed
lemma Zero_not_eq_One [simp]:
shows "Zero \<noteq> One"
- using Zero_def One_def
- by (metis Abs_arr_inverse FC.not_arr_null FC.null_char FC_arr_char UNIV_I FC.Dom_mkArr)
-
- lemma Zero_not_in_mkArr_Arr [simp]:
- shows "Zero \<notin> mkArr ` Arr"
- by (metis ide_char imageE not_ide_mkArr)
-
- lemma One_not_in_mkArr_Arr [simp]:
- shows "One \<notin> mkArr ` Arr"
- by (metis ide_char imageE not_ide_mkArr)
-
- lemma dom_char:
- shows "dom f = (if ide f then f else if arr f then Zero else null)"
- using ide_char arr_char in_hom_char
- by (metis has_domain_iff_arr in_homE dom_def)
-
- lemma dom_simp [simp]:
- shows "dom One = One"
- and "\<lbrakk>arr f; f \<noteq> One\<rbrakk> \<Longrightarrow> dom f = Zero"
- using dom_char ide_char by auto
+ by (simp add: One_def Zero_def)
- lemma cod_char:
- shows "cod f = (if ide f then f else if arr f then One else null)"
- using ide_char arr_char in_hom_char
- by (metis has_codomain_iff_arr in_homE cod_def)
-
- lemma cod_simp [simp]:
- shows "cod Zero = Zero"
- and "\<lbrakk>arr f; f \<noteq> Zero\<rbrakk> \<Longrightarrow> cod f = One"
- using cod_char ide_char by auto
+ lemma Zero_not_eq_fromArr [simp]:
+ shows "Zero \<notin> fromArr ` Arr"
+ using ide_char not_ide_fromArr
+ by (metis (no_types, lifting) image_iff)
- lemma seq_char:
- shows "seq g f \<longleftrightarrow> arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
- proof
- assume gf: "seq g f"
- hence 1: "arr f \<and> arr g \<and> cod f = dom g" by auto
- have f: "arr f \<and> (f = Zero \<or> f = One \<or> f \<in> mkArr ` Arr)" using gf arr_char by auto
- have g: "arr g \<and> (g = Zero \<or> g = One \<or> g \<in> mkArr ` Arr)" using gf arr_char by auto
- have "f = Zero \<Longrightarrow> g \<noteq> One"
- using f g 1 by force
- moreover have "f = One \<Longrightarrow> g = One"
- using f g 1 by (metis Zero_not_eq_One cod_simp(2) dom_simp(2))
- moreover have "f \<in> mkArr ` Arr \<Longrightarrow> f \<noteq> Zero \<and> g = One"
- using f 1 arr_char [of f]
- by (metis Zero_not_eq_One Zero_not_in_mkArr_Arr cod_simp(2) dom_simp(2))
- ultimately show "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
- using f g arr_char [of f] arr_char [of g] by blast
- next
- assume gf: "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
- thus "seq g f" using in_hom_char by auto
- qed
+ lemma One_not_eq_fromArr [simp]:
+ shows "One \<notin> fromArr ` Arr"
+ using ide_char not_ide_fromArr
+ by (metis (no_types, lifting) image_iff)
lemma comp_char:
shows "g \<cdot> f = (if seq g f then
if f = Zero then g else if g = One then f else null
else null)"
proof -
have "seq g f \<Longrightarrow> f = Zero \<Longrightarrow> g \<cdot> f = g"
- using comp_def seq_char [of g f] AC.comp_char [of g f] Zero_def cod_simp(1)
- by (metis comp_arr_dom dom_simp(2))
+ using seq_char comp_char [of g f] Zero_def dom_char cod_char comp_arr_dom
+ by auto
moreover have "seq g f \<Longrightarrow> g = One \<Longrightarrow> g \<cdot> f = f"
- using comp_def seq_char [of g f] AC.comp_char [of g f] One_def dom_simp(1)
- by (metis comp_cod_arr cod_simp(2))
+ using seq_char comp_char [of g f] One_def dom_char cod_char comp_cod_arr
+ by simp
moreover have "seq g f \<Longrightarrow> f \<noteq> Zero \<Longrightarrow> g \<noteq> One \<Longrightarrow> g \<cdot> f = null"
- using seq_char by blast
+ using seq_char Zero_def One_def by simp
moreover have "\<not>seq g f \<Longrightarrow> g \<cdot> f = null"
- using comp_def AC.comp_char ext by fastforce
+ using comp_char ext by fastforce
ultimately show ?thesis by argo
qed
lemma comp_simp [simp]:
assumes "seq g f"
shows "f = Zero \<Longrightarrow> g \<cdot> f = g"
and "g = One \<Longrightarrow> g \<cdot> f = f"
- proof -
- show "f = Zero \<Longrightarrow> g \<cdot> f = g"
- using assms seq_char comp_char by metis
- show "g = One \<Longrightarrow> g \<cdot> f = f"
- using assms seq_char comp_char by metis
- qed
+ using assms seq_char comp_char by metis+
- lemma arr_mkArr:
+ lemma arr_fromArr:
assumes "x \<in> Arr"
- shows "arr (mkArr x)"
- using assms mkArr_def arr_char image_eqI by blast
+ shows "arr (fromArr x)"
+ using assms fromArr_def arr_char image_eqI by simp
lemma toArr_in_Arr:
assumes "arr f" and "\<not>ide f"
shows "toArr f \<in> Arr"
proof -
- have "\<And>a. a \<in> Arr \<Longrightarrow> FC.Path (Rep_arr (mkArr a)) = [a]"
- by (metis AC.domain_closed Abs_arr_inverse FC.Path_mkArr FC.arr_char FC.arr_single
- mkArr_def)
- hence "hd (FC.Path (Rep_arr f)) \<in> Arr"
- using arr_char assms(1) assms(2) ide_char by auto
+ have "\<And>a. a \<in> Arr \<Longrightarrow> Path (fromArr a) = [a]"
+ using fromArr_def arr_char by simp
+ hence "hd (Path f) \<in> Arr"
+ using assms arr_char ide_char by auto
thus ?thesis
by (simp add: toArr_def)
qed
- lemma toArr_mkArr [simp]:
+ lemma toArr_fromArr [simp]:
assumes "x \<in> Arr"
- shows "toArr (mkArr x) = x"
- using assms mkArr_def toArr_def
- by (metis Abs_arr_inverse FC.G.path_single_Arr UNIV_I FC.Path_mkArr FC.mkArr_not_Null
- list.sel(1))
+ shows "toArr (fromArr x) = x"
+ using assms fromArr_def toArr_def
+ by (simp add: toArr_def)
- lemma mkArr_toArr [simp]:
+ lemma fromArr_toArr [simp]:
assumes "arr f" and "\<not>ide f"
- shows "mkArr (toArr f) = f"
- using assms arr_char ide_char imageE toArr_mkArr by auto
+ shows "fromArr (toArr f) = f"
+ using assms fromArr_def toArr_def arr_char ide_char toArr_fromArr by auto
end
- sublocale quiver \<subseteq> category comp
- using is_category by auto
-
section "Parallel Pairs"
text\<open>
A parallel pair is a quiver with two non-identity arrows.
It is important in the definition of equalizers.
\<close>
locale parallel_pair =
- Q: quiver "{False, True} :: bool set"
+ quiver "{False, True} :: bool set"
begin
typedef arr = "UNIV :: bool quiver.arr set" ..
- interpretation AC: abstracted_category Q.comp Abs_arr Rep_arr UNIV
- using Rep_arr_inverse Abs_arr_inverse apply unfold_locales by auto
-
- definition comp (infixr "\<cdot>" 55)
- where "comp \<equiv> AC.comp"
-
- lemma is_category:
- shows "category comp"
- proof -
- have "category AC.comp" ..
- thus "category comp" using comp_def by metis
- qed
-
- interpretation category comp
- using is_category by auto
-
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
-
- definition Zero
- where "Zero \<equiv> Abs_arr Q.Zero"
-
- definition One
- where "One \<equiv> Abs_arr Q.One"
-
definition j0
- where "j0 \<equiv> Abs_arr (Q.mkArr False)"
+ where "j0 \<equiv> fromArr False"
definition j1
- where "j1 \<equiv> Abs_arr (Q.mkArr True)"
+ where "j1 \<equiv> fromArr True"
lemma arr_char:
shows "arr f \<longleftrightarrow> f = Zero \<or> f = One \<or> f = j0 \<or> f = j1"
- proof -
- have 1: "Rep_arr f = Q.Zero \<or> Rep_arr f = Q.One \<or> Rep_arr f \<in> Q.mkArr ` {False, True}
- \<longrightarrow> arr f"
- by (simp add: AC.arr_char Q.arr_char comp_def)
- have 2: "\<forall>a. a \<in> UNIV \<longrightarrow> Rep_arr (Abs_arr a) = a"
- by (simp add: Abs_arr_inverse)
- hence 3: "Rep_arr (Abs_arr (Q.mkArr True)) = Q.mkArr True"
- by blast
- hence 4: "f = j1 \<longrightarrow> arr f"
- using 1 j1_def by auto
- have "f = j0 \<or> f = Zero \<or> f = One \<longrightarrow> arr f"
- using 1 2 Zero_def One_def by (metis (no_types) UNIV_I insertI1 j0_def rev_image_eqI)
- thus ?thesis
- using 2 3 4
- by (metis (full_types) AC.arr_char One_def Q.ide_char Q.mkArr_toArr Rep_arr_inject
- UNIV_I Zero_def j0_def j1_def comp_def)
- qed
+ using arr_char j0_def j1_def by simp
lemma dom_char:
shows "dom f = (if f = j0 \<or> f = j1 then Zero else if arr f then f else null)"
- using comp_def
- by (metis (full_types) AC.arr_char AC.dom_char Abs_arr_inverse One_def Q.dom_char
- Q.ide_char Q.not_ide_mkArr UNIV_I Zero_def arr_char j0_def j1_def)
+ using arr_char dom_char j0_def j1_def
+ by (metis ide_char not_ide_fromArr)
lemma cod_char:
shows "cod f = (if f = j0 \<or> f = j1 then One else if arr f then f else null)"
- using comp_def
- by (metis (full_types) AC.arr_char AC.cod_char Abs_arr_inverse One_def Q.cod_char
- Q.ide_char Q.not_ide_mkArr UNIV_I Zero_def arr_char j0_def j1_def)
-
- lemma ide_char:
- shows "ide a \<longleftrightarrow> a = Zero \<or> a = One"
- using ide_in_hom arr_char
- by (metis (no_types, lifting) AC.ide_char Q.ide_char UNIV_I Zero_def in_homE j0_def j1_def
- comp_def Abs_arr_inverse One_def)
-
- lemma Zero_not_eq_One [simp]:
- shows "Zero \<noteq> One"
- using Zero_def One_def Q.Zero_def Q.One_def
- by (metis AC.rep_abs Q.Zero_not_eq_One UNIV_I)
+ using arr_char cod_char j0_def j1_def
+ by (metis ide_char not_ide_fromArr)
lemma j0_not_eq_j1 [simp]:
shows "j0 \<noteq> j1"
- by (metis (full_types) Abs_arr_inverse Q.toArr_mkArr UNIV_I UNIV_bool j0_def j1_def)
+ using j0_def j1_def
+ by (metis insert_iff toArr_fromArr)
lemma Zero_not_eq_j0 [simp]:
shows "Zero \<noteq> j0"
- using Zero_def j0_def by (metis Abs_arr_inverse Q.ide_char Q.not_ide_mkArr UNIV_I)
+ using Zero_def j0_def Zero_not_eq_fromArr by auto
lemma Zero_not_eq_j1 [simp]:
shows "Zero \<noteq> j1"
- using Zero_def j1_def by (metis Abs_arr_inverse Q.ide_char Q.not_ide_mkArr UNIV_I)
+ using Zero_def j1_def Zero_not_eq_fromArr by auto
lemma One_not_eq_j0 [simp]:
shows "One \<noteq> j0"
- using One_def j0_def by (metis Abs_arr_inverse Q.ide_char Q.not_ide_mkArr UNIV_I)
+ using One_def j0_def One_not_eq_fromArr by auto
lemma One_not_eq_j1 [simp]:
shows "One \<noteq> j1"
- using One_def j1_def by (metis Abs_arr_inverse Q.ide_char Q.not_ide_mkArr UNIV_I)
+ using One_def j1_def One_not_eq_fromArr by auto
lemma dom_simp [simp]:
shows "dom Zero = Zero"
and "dom One = One"
and "dom j0 = Zero"
and "dom j1 = Zero"
using dom_char arr_char by auto
lemma cod_simp [simp]:
shows "cod Zero = Zero"
and "cod One = One"
and "cod j0 = One"
and "cod j1 = One"
using cod_char arr_char by auto
- lemma seq_char:
- shows "seq g f \<longleftrightarrow> arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
- proof
- assume gf: "seq g f"
- have f: "arr f \<and> (f = Zero \<or> f = One \<or> f = j0 \<or> f = j1)" using gf arr_char by blast
- have g: "arr g \<and> (g = Zero \<or> g = One \<or> g = j0 \<or> g = j1)" using gf arr_char by blast
- have "f = Zero \<Longrightarrow> g \<noteq> One"
- using f g gf
- by (metis Zero_not_eq_One seqE cod_simp(1) dom_simp(2))
- moreover have "f \<noteq> Zero \<Longrightarrow> g = One"
- using f g gf by auto
- ultimately show "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
- using f g by blast
- next
- assume gf: "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
- have "f = Zero \<Longrightarrow> seq g f" using gf arr_char [of g] by auto
- moreover have "g = One \<Longrightarrow> seq g f" using gf arr_char [of f] by auto
- ultimately show "seq g f" using gf by blast
- qed
-
- lemma comp_char:
- shows "g \<cdot> f = (if seq g f then
- if f = Zero then g else if g = One then f else null
- else null)"
- proof -
- have "\<not>seq g f \<Longrightarrow> g \<cdot> f = null"
- using comp_def AC.comp_char Q.comp_char seq_char ext by blast
- moreover have "seq g f \<Longrightarrow> f = Zero \<Longrightarrow> g \<cdot> f = g"
- using comp_arr_dom by auto
- moreover have "seq g f \<Longrightarrow> g = One \<Longrightarrow> g \<cdot> f = f"
- using comp_cod_arr by auto
- ultimately show ?thesis
- by (metis seqE seq_char)
- qed
-
- lemma comp_simp [simp]:
- assumes "seq g f"
- shows "f = Zero \<Longrightarrow> g \<cdot> f = g"
- and "g = One \<Longrightarrow> g \<cdot> f = f"
- proof -
- show "f = Zero \<Longrightarrow> g \<cdot> f = g"
- using assms comp_char by metis
- show "g = One \<Longrightarrow> g \<cdot> f = f"
- using assms comp_char seq_char by metis
- qed
-
end
- sublocale parallel_pair \<subseteq> category comp
- using is_category by auto
-
end
diff --git a/thys/Category3/Functor.thy b/thys/Category3/Functor.thy
--- a/thys/Category3/Functor.thy
+++ b/thys/Category3/Functor.thy
@@ -1,463 +1,488 @@
(* Title: Functor
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter Functor
theory Functor
-imports Category DualCategory InitialTerminal
+imports Category ConcreteCategory DualCategory InitialTerminal
begin
text\<open>
One advantage of the ``object-free'' definition of category is that a functor
from category \<open>A\<close> to category \<open>B\<close> is simply a function from the type
of arrows of \<open>A\<close> to the type of arrows of \<open>B\<close> that satisfies certain
conditions: namely, that arrows are mapped to arrows, non-arrows are mapped to
\<open>null\<close>, and domains, codomains, and composition of arrows are preserved.
\<close>
locale "functor" =
A: category A +
B: category B
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b" +
assumes is_extensional: "\<not>A.arr f \<Longrightarrow> F f = B.null"
and preserves_arr: "A.arr f \<Longrightarrow> B.arr (F f)"
and preserves_dom [iff]: "A.arr f \<Longrightarrow> B.dom (F f) = F (A.dom f)"
and preserves_cod [iff]: "A.arr f \<Longrightarrow> B.cod (F f) = F (A.cod f)"
and preserves_comp [iff]: "A.seq g f \<Longrightarrow> F (g \<cdot>\<^sub>A f) = F g \<cdot>\<^sub>B F f"
begin
notation A.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A _\<guillemotright>")
notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
lemma preserves_hom [intro]:
assumes "\<guillemotleft>f : a \<rightarrow>\<^sub>A b\<guillemotright>"
shows "\<guillemotleft>F f : F a \<rightarrow>\<^sub>B F b\<guillemotright>"
using assms B.in_homI
by (metis A.in_homE preserves_arr preserves_cod preserves_dom)
text\<open>
The following, which is made possible through the presence of \<open>null\<close>,
allows us to infer that the subterm @{term f} denotes an arrow if the
term @{term "F f"} denotes an arrow. This is very useful, because otherwise
doing anything with @{term f} would require a separate proof that it is an arrow
by some other means.
\<close>
lemma preserves_reflects_arr [iff]:
shows "B.arr (F f) \<longleftrightarrow> A.arr f"
using preserves_arr is_extensional B.not_arr_null by metis
lemma preserves_seq [intro]:
assumes "A.seq g f"
shows "B.seq (F g) (F f)"
using assms by auto
lemma preserves_ide [simp]:
assumes "A.ide a"
shows "B.ide (F a)"
using assms A.ide_in_hom B.ide_in_hom by auto
lemma preserves_iso [simp]:
assumes "A.iso f"
shows "B.iso (F f)"
using assms A.inverse_arrowsE
apply (elim A.isoE A.inverse_arrowsE A.seqE A.ide_compE)
by (metis A.arr_dom_iff_arr B.ide_dom B.inverse_arrows_def B.isoI preserves_arr
preserves_comp preserves_dom)
lemma preserves_section_retraction:
assumes "A.ide (A e m)"
shows "B.ide (B (F e) (F m))"
using assms by (metis A.ide_compE preserves_comp preserves_ide)
lemma preserves_section:
assumes "A.section m"
shows "B.section (F m)"
using assms preserves_section_retraction by blast
lemma preserves_retraction:
assumes "A.retraction e"
shows "B.retraction (F e)"
using assms preserves_section_retraction by blast
lemma preserves_inverse_arrows:
assumes "A.inverse_arrows f g"
shows "B.inverse_arrows (F f) (F g)"
using assms A.inverse_arrows_def B.inverse_arrows_def preserves_section_retraction
by simp
lemma preserves_inv:
assumes "A.iso f"
shows "F (A.inv f) = B.inv (F f)"
using assms preserves_inverse_arrows A.inv_is_inverse B.inv_is_inverse
B.inverse_arrow_unique
by blast
end
locale endofunctor =
"functor" A A F
for A :: "'a comp" (infixr "\<cdot>" 55)
and F :: "'a \<Rightarrow> 'a"
locale faithful_functor = "functor" A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a \<Rightarrow> 'b" +
assumes is_faithful: "\<lbrakk> A.par f f'; F f = F f' \<rbrakk> \<Longrightarrow> f = f'"
begin
lemma locally_reflects_ide:
assumes "\<guillemotleft>f : a \<rightarrow>\<^sub>A a\<guillemotright>" and "B.ide (F f)"
shows "A.ide f"
using assms is_faithful
by (metis A.arr_dom_iff_arr A.cod_dom A.dom_dom A.in_homE B.comp_ide_self
B.ide_self_inverse B.comp_arr_inv A.ide_cod preserves_dom)
end
locale full_functor = "functor" A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a \<Rightarrow> 'b" +
assumes is_full: "\<lbrakk> A.ide a; A.ide a'; \<guillemotleft>g : F a' \<rightarrow>\<^sub>B F a\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>f. \<guillemotleft>f : a' \<rightarrow>\<^sub>A a\<guillemotright> \<and> F f = g"
locale fully_faithful_functor =
faithful_functor A B F +
full_functor A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a \<Rightarrow> 'b"
begin
lemma reflects_iso:
assumes "\<guillemotleft>f : a' \<rightarrow>\<^sub>A a\<guillemotright>" and "B.iso (F f)"
shows "A.iso f"
proof -
from assms obtain g' where g': "B.inverse_arrows (F f) g'" by blast
have 1: "\<guillemotleft>g' : F a \<rightarrow>\<^sub>B F a'\<guillemotright>"
using assms g' by (metis B.inv_in_hom B.inverse_unique preserves_hom)
from this obtain g where g: "\<guillemotleft>g : a \<rightarrow>\<^sub>A a'\<guillemotright> \<and> F g = g'"
using assms(1) is_full by (metis A.arrI A.ide_cod A.ide_dom A.in_homE)
have "A.inverse_arrows f g"
- using assms 1 g g'
- apply (elim B.inverse_arrowsE, intro A.inverse_arrowsI, auto)
- using B.ide_dom B.iso_is_arr locally_reflects_ide preserves_comp
- apply (metis A.in_homI A.seqI' A.dom_comp A.cod_comp A.in_homE)
- using B.ide_dom B.iso_is_arr locally_reflects_ide preserves_comp
- by (metis A.in_homI A.seqI' A.dom_comp A.cod_comp A.in_homE)
+ using assms 1 g g' A.inverse_arrowsI
+ by (metis A.arr_iff_in_hom A.dom_comp A.in_homE A.seqI' B.inverse_arrowsE
+ A.cod_comp locally_reflects_ide preserves_comp)
thus ?thesis by auto
qed
end
locale embedding_functor = "functor" A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a \<Rightarrow> 'b" +
assumes is_embedding: "\<lbrakk> A.arr f; A.arr f'; F f = F f' \<rbrakk> \<Longrightarrow> f = f'"
sublocale embedding_functor \<subseteq> faithful_functor
using is_embedding by (unfold_locales, blast)
context embedding_functor
begin
lemma reflects_ide:
assumes "B.ide (F f)"
shows "A.ide f"
using assms is_embedding A.ide_in_hom B.ide_in_hom
by (metis A.in_homE B.in_homE A.ide_cod preserves_cod preserves_reflects_arr)
end
locale full_embedding_functor =
embedding_functor A B F +
full_functor A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a \<Rightarrow> 'b"
locale essentially_surjective_functor = "functor" +
assumes essentially_surjective: "\<And>b. B.ide b \<Longrightarrow> \<exists>a. A.ide a \<and> B.isomorphic (F a) b"
locale constant_functor =
A: category A +
B: category B
for A :: "'a comp"
and B :: "'b comp"
and b :: 'b +
assumes value_is_ide: "B.ide b"
begin
definition map
where "map f = (if A.arr f then b else B.null)"
lemma map_simp [simp]:
assumes "A.arr f"
shows "map f = b"
using assms map_def by auto
lemma is_functor:
shows "functor A B map"
using map_def value_is_ide by (unfold_locales, auto)
end
sublocale constant_functor \<subseteq> "functor" A B map
using is_functor by auto
locale identity_functor =
C: category C
for C :: "'a comp"
begin
definition map :: "'a \<Rightarrow> 'a"
where "map f = (if C.arr f then f else C.null)"
lemma map_simp [simp]:
assumes "C.arr f"
shows "map f = f"
using assms map_def by simp
lemma is_functor:
shows "functor C C map"
using C.arr_dom_iff_arr C.arr_cod_iff_arr
by (unfold_locales; auto simp add: map_def)
end
sublocale identity_functor \<subseteq> "functor" C C map
using is_functor by auto
text \<open>
It is convenient to have an easy way to obtain from a category the identity functor
on that category. The following declaration causes the definitions and facts from the
@{locale identity_functor} locale to be inherited by the @{locale category} locale,
including the function @{term map} on arrows that represents the identity functor.
This makes it generally unnecessary to give explicit interpretations of
@{locale identity_functor}.
\<close>
sublocale category \<subseteq> identity_functor C ..
text\<open>
Composition of functors coincides with function composition, thanks to the
magic of \<open>null\<close>.
\<close>
lemma functor_comp:
assumes "functor A B F" and "functor B C G"
shows "functor A C (G o F)"
proof -
interpret F: "functor" A B F using assms(1) by auto
interpret G: "functor" B C G using assms(2) by auto
show "functor A C (G o F)"
using F.preserves_arr F.is_extensional G.is_extensional by (unfold_locales, auto)
qed
locale composite_functor =
F: "functor" A B F +
G: "functor" B C G
for A :: "'a comp"
and B :: "'b comp"
and C :: "'c comp"
and F :: "'a \<Rightarrow> 'b"
and G :: "'b \<Rightarrow> 'c"
begin
abbreviation map
where "map \<equiv> G o F"
end
sublocale composite_functor \<subseteq> "functor" A C "G o F"
using functor_comp F.functor_axioms G.functor_axioms by blast
lemma comp_functor_identity [simp]:
assumes "functor A B F"
shows "F o identity_functor.map A = F"
proof
interpret "functor" A B F using assms by blast
show "\<And>x. (F o A.map) x = F x"
using A.map_def is_extensional by simp
qed
lemma comp_identity_functor [simp]:
assumes "functor A B F"
shows "identity_functor.map B o F = F"
proof
interpret "functor" A B F using assms by blast
show "\<And>x. (B.map o F) x = F x"
using B.map_def by (metis comp_apply is_extensional preserves_arr)
qed
locale inverse_functors =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" B A G
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'b \<Rightarrow> 'a" +
assumes inv: "G o F = identity_functor.map A"
and inv': "F o G = identity_functor.map B"
locale isomorphic_categories =
A: category A +
B: category B
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55) +
assumes iso: "\<exists>F G. inverse_functors A B F G"
sublocale inverse_functors \<subseteq> isomorphic_categories A B
using inverse_functors_axioms by (unfold_locales, auto)
lemma inverse_functors_sym:
assumes "inverse_functors A B F G"
shows "inverse_functors B A G F"
proof -
interpret inverse_functors A B F G using assms by auto
show ?thesis using inv inv' by (unfold_locales, auto)
qed
+ text \<open>
+ Inverse functors uniquely determine each other.
+\<close>
+
lemma inverse_functor_unique:
assumes "inverse_functors C D F G" and "inverse_functors C D F G'"
shows "G = G'"
proof -
interpret FG: inverse_functors C D F G using assms(1) by auto
interpret FG': inverse_functors C D F G' using assms(2) by auto
show "G = G'"
using FG.G.is_extensional FG'.G.is_extensional FG'.inv FG.inv'
by (metis FG'.G.functor_axioms FG.G.functor_axioms comp_assoc comp_identity_functor
comp_functor_identity)
qed
lemma inverse_functor_unique':
assumes "inverse_functors C D F G" and "inverse_functors C D F' G"
shows "F = F'"
using assms inverse_functors_sym inverse_functor_unique by blast
locale invertible_functor =
A: category A +
B: category B +
F: "functor" A B F
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b" +
assumes invertible: "\<exists>G. inverse_functors A B F G"
begin
lemma has_unique_inverse:
shows "\<exists>!G. inverse_functors A B F G"
using invertible inverse_functor_unique by blast
definition inv
where "inv \<equiv> THE G. inverse_functors A B F G"
interpretation inverse_functors A B F inv
using inv_def has_unique_inverse theI' [of "\<lambda>G. inverse_functors A B F G"]
by simp
lemma inv_is_inverse:
shows "inverse_functors A B F inv" ..
lemma preserves_terminal:
assumes "A.terminal a"
shows "B.terminal (F a)"
proof
show 0: "B.ide (F a)" using assms F.preserves_ide A.terminal_def by blast
fix b :: 'b
assume b: "B.ide b"
show "\<exists>!g. \<guillemotleft>g : b \<rightarrow>\<^sub>B F a\<guillemotright>"
proof
let ?G = "SOME G. inverse_functors A B F G"
from invertible have G: "inverse_functors A B F ?G"
using someI_ex [of "\<lambda>G. inverse_functors A B F G"] by fast
interpret inverse_functors A B F ?G using G by auto
let ?P = "\<lambda>f. \<guillemotleft>f : ?G b \<rightarrow>\<^sub>A a\<guillemotright>"
have 1: "\<exists>!f. ?P f" using assms b A.terminal_def G.preserves_ide by simp
hence 2: "?P (THE f. ?P f)" by (metis (no_types, lifting) theI')
thus "\<guillemotleft>F (THE f. ?P f) : b \<rightarrow>\<^sub>B F a\<guillemotright>"
using b apply (elim A.in_homE, intro B.in_homI, auto)
using B.ideD(1) B.map_simp comp_def inv' by metis
hence 3: "\<guillemotleft>(THE f. ?P f) : ?G b \<rightarrow>\<^sub>A a\<guillemotright>"
using assms 2 b G by simp
fix g :: 'b
assume g: "\<guillemotleft>g : b \<rightarrow>\<^sub>B F a\<guillemotright>"
have "?G (F a) = a"
using assms(1) A.terminal_def inv A.map_simp
by (metis 0 F.preserves_reflects_arr B.ideD(1) comp_apply)
hence "\<guillemotleft>?G g : ?G b \<rightarrow>\<^sub>A a\<guillemotright>"
using assms(1) g A.terminal_def inv G.preserves_hom [of b "F a" g]
by (elim B.in_homE, auto)
hence "?G g = (THE f. ?P f)" using assms 1 3 A.terminal_def by blast
thus "g = F (THE f. ?P f)"
using inv' g by (metis B.in_homE B.map_simp comp_def)
qed
qed
end
sublocale invertible_functor \<subseteq> inverse_functors A B F inv
using inv_is_inverse by simp
text \<open>
- Inverse functors uniquely determine each other.
-\<close>
+ We now prove the result, advertised earlier in theory \<open>ConcreteCategory\<close>,
+ that any category is in fact isomorphic to the concrete category formed from it in
+ the obvious way.
+ \<close>
- lemma inverse_functor_eq:
- assumes "inverse_functors C D F G" and "inverse_functors C D F G'"
- shows "G = G'"
- proof -
- interpret FG: inverse_functors C D F G using assms(1) by auto
- interpret FG': inverse_functors C D F G' using assms(2) by auto
- show "G = G'"
- using FG.G.is_extensional FG'.G.is_extensional FG'.inv FG'.inverse_functors_axioms
- FG.inverse_functors_axioms inverse_functor_unique
- by metis
- qed
+ context category
+ begin
- lemma inverse_functor_eq':
- assumes "inverse_functors C D F G" and "inverse_functors C D F' G"
- shows "F = F'"
- using assms inverse_functors_sym inverse_functor_eq by blast
+ interpretation CC: concrete_category \<open>Collect ide\<close> hom id \<open>\<lambda>C B A g f. g \<cdot> f\<close>
+ using comp_arr_dom comp_cod_arr comp_assoc
+ by (unfold_locales, auto)
+
+ interpretation F: "functor" C CC.COMP
+ \<open>\<lambda>f. if arr f then CC.MkArr (dom f) (cod f) f else CC.null\<close>
+ by (unfold_locales, auto simp add: in_homI)
+
+ interpretation G: "functor" CC.COMP C \<open>\<lambda>F. if CC.arr F then CC.Map F else null\<close>
+ using CC.Map_in_Hom CC.seq_char
+ by (unfold_locales, auto)
+
+ interpretation FG: inverse_functors C CC.COMP
+ \<open>\<lambda>f. if arr f then CC.MkArr (dom f) (cod f) f else CC.null\<close>
+ \<open>\<lambda>F. if CC.arr F then CC.Map F else null\<close>
+ proof
+ show "(\<lambda>F. if CC.arr F then CC.Map F else null) \<circ>
+ (\<lambda>f. if arr f then CC.MkArr (dom f) (cod f) f else CC.null) =
+ map"
+ using CC.arr_char map_def by fastforce
+ show "(\<lambda>f. if arr f then CC.MkArr (dom f) (cod f) f else CC.null) \<circ>
+ (\<lambda>F. if CC.arr F then CC.Map F else null) =
+ CC.map"
+ using CC.MkArr_Map G.preserves_arr G.preserves_cod G.preserves_dom
+ CC.is_extensional
+ by auto
+ qed
+
+ interpretation isomorphic_categories C CC.COMP ..
+
+ theorem is_isomorphic_to_concrete_category:
+ shows "isomorphic_categories C CC.COMP"
+ ..
+
+ end
locale dual_functor =
F: "functor" A B F +
Aop: dual_category A +
Bop: dual_category B
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
begin
notation Aop.comp (infixr "\<cdot>\<^sub>A\<^sup>o\<^sup>p" 55)
notation Bop.comp (infixr "\<cdot>\<^sub>B\<^sup>o\<^sup>p" 55)
definition map
where "map \<equiv> F"
lemma map_simp [simp]:
shows "map f = F f"
by (simp add: map_def)
lemma is_functor:
shows "functor Aop.comp Bop.comp map"
using F.is_extensional by (unfold_locales, auto)
end
sublocale invertible_functor \<subseteq> inverse_functors A B F inv
using inv_is_inverse by simp
sublocale dual_functor \<subseteq> "functor" Aop.comp Bop.comp map
using is_functor by auto
end
diff --git a/thys/Category3/FunctorCategory.thy b/thys/Category3/FunctorCategory.thy
--- a/thys/Category3/FunctorCategory.thy
+++ b/thys/Category3/FunctorCategory.thy
@@ -1,1123 +1,810 @@
(* Title: FunctorCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter FunctorCategory
theory FunctorCategory
-imports Category AbstractedCategory BinaryFunctor
+imports ConcreteCategory BinaryFunctor
begin
text\<open>
The functor category \<open>[A, B]\<close> is the category whose objects are functors
from @{term A} to @{term B} and whose arrows correspond to natural transformations
between these functors.
- Since the arrows of a functor category cannot (in the context of the present development)
- be directly identified with natural transformations, but rather only with natural
- transformations that have been equipped with their domain and codomain functors,
- and since there is no natural value to serve as @{term null},
- the construction here is a bit more involved than most of the other constructions
- on categories we have defined so far.
- What we do first is to construct a ``classical category'' whose objects are
- functors and whose arrows are natural transformations. Then, we extract from this
- construction a partial composition using the standard result proved in the
- \<open>classical_category\<close> locale. The effect of this standard result is to define
- arrows of the resulting category to be triples that consist of natural transformations
- equipped with their domain and codomain functors, injected into an option type
- in order to provide a value to be used as @{term null}.
- We then use the \<open>abstracted_category\<close> locale to lift the resulting category to an
- opaque arrow type, to avoid the possibility of a client of this theory inadvertently
- depending on the details of the concrete construction.
- Finally, we define a set of constructors for the opaque arrow type and characterize the
- resulting category in terms of these constructors so that the details of the concrete
- construction are no longer required and only the constructors and associated facts need
- be used.
\<close>
section "Construction"
text\<open>
- In this section a construction for functor categories is given.
- For convenience, we proceed indirectly, by way of the \<open>classical_category\<close> locale,
- though the construction could also have been done directly.
- Some auxiliary definitions are involved, but these are declared ``private'' and in
- the end what is exported is an opaque arrow type, a partial composition operation on
- this arrow type defining the category, functions for constructing and destructing arrows,
- and facts that characterize the basic notions (domain, codomain, \emph{etc.}) in terms
- of these functions.
+ Since the arrows of a functor category cannot (in the context of the present development)
+ be directly identified with natural transformations, but rather only with natural
+ transformations that have been equipped with their domain and codomain functors,
+ and since there is no natural value to serve as @{term null},
+ we use the general-purpose construction given by @{locale concrete_category} to define
+ this category.
\<close>
locale functor_category =
A: category A +
B: category B
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
begin
notation A.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A _\<guillemotright>")
notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
- context begin
-
- text\<open>
- First, we construct a ``classical category'' whose objects are functors and
- whose arrows are triples \<open>(\<tau>, (F, G))\<close>, where \<open>F\<close> and \<open>G\<close>
- are functors and \<open>\<tau>\<close> is a natural transformation from \<open>F\<close> to \<open>G\<close>.
-\<close>
-
- private abbreviation Dom'
- where "Dom' t \<equiv> fst (snd t)"
-
- private abbreviation Cod'
- where "Cod' t \<equiv> snd (snd t)"
-
- private abbreviation Fun'
- where "Fun' t \<equiv> fst t"
-
- private definition Obj'
- where "Obj' F \<equiv> functor A B F"
-
- private definition Arr'
- where "Arr' t \<equiv> natural_transformation A B (Dom' t) (Cod' t) (Fun' t)"
-
- private abbreviation Id'
- where "Id' F \<equiv> (F, (F, F))"
-
- private definition Comp'
- where "Comp' t s \<equiv> (vertical_composite.map A B (Fun' s) (Fun' t), (Dom' s, Cod' t))"
-
- interpretation CC: classical_category Obj' Arr' Dom' Cod' Id' Comp'
- proof
- fix F
- assume F: "Obj' F"
- show "Arr' (Id' F)"
- using F Arr'_def Obj'_def functor_is_transformation by simp
- show "Dom' (Id' F) = F" using F by (metis fst_conv snd_conv)
- show "Cod' (Id' F) = F" using F by (metis snd_conv)
- next
- fix t
- assume t: "Arr' t"
- interpret \<tau>: natural_transformation A B "Dom' t" "Cod' t" "Fun' t"
- using t Arr'_def by blast
- show "Obj' (Dom' t)" unfolding Obj'_def ..
- show "Obj' (Cod' t)" unfolding Obj'_def ..
- show "Comp' t (Id' (Dom' t)) = t"
- by (metis Comp'_def \<tau>.natural_transformation_axioms fst_conv prod.collapse snd_conv
- vcomp_ide_dom)
- show "Comp' (Id' (Cod' t)) t = t"
- by (metis (no_types, lifting) Comp'_def \<tau>.natural_transformation_axioms fst_conv
- prod.collapse snd_conv vcomp_ide_cod)
- fix s
- assume s: "Arr' s"
- and st: "Cod' s = Dom' t"
- show "Arr' (Comp' t s)"
- proof -
- interpret \<sigma>: natural_transformation A B "Dom' s" "Cod' s" "Fun' s"
- using s Arr'_def by blast
- interpret VC: vertical_composite A B "Dom' s" "Cod' s" "Cod' t" "Fun' s" "Fun' t"
- using s t st Arr'_def Obj'_def
- by (simp add: natural_transformation_def vertical_composite.intro)
- have "natural_transformation A B (Dom' s) (Cod' t) (Fun' (Comp' t s))"
- using VC.is_natural_transformation Comp'_def by (metis fst_conv)
- thus ?thesis using s t st Arr'_def Comp'_def by (metis fst_conv snd_conv)
- qed
- show "Dom' (Comp' t s) = Dom' s"
- using Comp'_def fst_conv snd_conv by metis
- show "Cod' (Comp' t s) = Cod' t"
- using Comp'_def snd_conv by metis
- fix r
- assume r: "Arr' r"
- and rs: "Cod' r = Dom' s"
- show "Comp' (Comp' t s) r = Comp' t (Comp' s r)"
- unfolding Comp'_def
- using r s t rs st Arr'_def by auto
- qed
-
- private lemma CC_is_classical_category:
- shows "classical_category Obj' Arr' Dom' Cod' Id' Comp'" ..
-
- text\<open>
- At this point, @{term CC.comp} is a partial composition that defines a category.
- The arrow type for this category is @{typ "(('a \<Rightarrow> 'b) \<times> ('a \<Rightarrow> 'b) \<times> ('a \<Rightarrow> 'b)) option"},
- because the definition of @{term CC.comp} introduces an option type to provide
- a value to be used as @{term null}. We next define a corresponding opaque arrow type.
-\<close>
-
- typedef ('c, 'd) arr = "UNIV :: (('c \<Rightarrow> 'd) * ('c \<Rightarrow> 'd) * ('c \<Rightarrow> 'd)) option set" ..
-
- text\<open>
- The category defined by @{term CC.comp} is then lifted to the opaque arrow type.
-\<close>
-
- interpretation AC: abstracted_category CC.comp Abs_arr Rep_arr UNIV
- using Rep_arr_inverse Abs_arr_inverse apply unfold_locales by auto
-
- text\<open>
- The function @{term AC.comp} is now the partial composition that defines the
- desired category.
-\<close>
-
- definition comp :: "('a, 'b) arr comp" (infixr "\<cdot>" 55)
- where "comp \<equiv> AC.comp"
-
- lemma is_category:
- shows "category comp"
- using AC.category_axioms comp_def by auto
-
- interpretation category comp
- using is_category by auto
-
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
-
- text\<open>
- We introduce a constructor \<open>mkArr\<close> for building an arrow from two
- functors and a natural transformation.
-\<close>
-
- definition mkArr :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) arr"
- where "mkArr F G \<tau> \<equiv> (if natural_transformation A B F G \<tau>
- then Abs_arr (Some (\<tau>, (F, G))) else null)"
-
- abbreviation mkIde
- where "mkIde F \<equiv> mkArr F F F"
-
- text\<open>
- Destructors @{term Dom}, @{term Cod}, and @{term Fun} extract the components
- of an arrow.
-\<close>
-
- definition Dom :: "('a, 'b) arr \<Rightarrow> 'a \<Rightarrow> 'b"
- where "Dom t \<equiv> Dom' (the (Rep_arr t))"
-
- definition Cod :: "('a, 'b) arr \<Rightarrow> 'a \<Rightarrow> 'b"
- where "Cod t \<equiv> Cod' (the (Rep_arr t))"
-
- definition Fun :: "('a, 'b) arr \<Rightarrow> 'a \<Rightarrow> 'b"
- where "Fun t \<equiv> Fun' (the (Rep_arr t))"
-
- text\<open>
- Finally, we prove a set of facts that characterize the basic categorical notions
- in terms of the constructors and destructors. These are the facts that will
- be exported.
-\<close>
+ type_synonym ('aa, 'bb) arr = "('aa \<Rightarrow> 'bb, 'aa \<Rightarrow> 'bb) concrete_category.arr"
- lemma null_char:
- shows "null = Abs_arr None"
- using comp_def AC.null_char CC.null_char by simp
-
- lemma arr_char:
- shows "arr f \<longleftrightarrow> f \<noteq> null \<and> natural_transformation A B (Dom f) (Cod f) (Fun f)"
- using comp_def not_arr_null Dom_def Cod_def Fun_def null_char AC.arr_char CC.arr_char
- Arr'_def Rep_arr_inverse
- by metis
-
- lemma arrI [intro]:
- assumes "f \<noteq> null" and "natural_transformation A B (Dom f) (Cod f) (Fun f)"
- shows "arr f"
- using assms arr_char by blast
-
- lemma arrE [elim]:
- assumes "arr f"
- and "f \<noteq> null \<Longrightarrow> natural_transformation A B (Dom f) (Cod f) (Fun f) \<Longrightarrow> T"
- shows T
- using assms arr_char by simp
-
- lemma dom_char:
- shows "dom f = (if arr f then mkIde (Dom f) else null)"
- using comp_def mkArr_def Dom_def arr_char null_char AC.arr_char AC.dom_char CC.dom_char
- functor_is_transformation natural_transformation_def
- by (metis (no_types, lifting))
-
- lemma dom_simp:
- assumes "arr t"
- shows "dom t = mkIde (Dom t)"
- using assms dom_char by auto
-
- lemma cod_char:
- shows "cod f = (if arr f then mkIde (Cod f) else null)"
- using comp_def mkArr_def Cod_def arr_char null_char AC.arr_char AC.cod_char CC.cod_char
- functor_is_transformation natural_transformation_def
- by (metis (no_types, lifting))
-
- lemma cod_simp:
- assumes "arr t"
- shows "cod t = mkIde (Cod t)"
- using assms cod_char by auto
-
- lemma arr_mkArr [iff]:
- shows "arr (mkArr F G \<tau>) \<longleftrightarrow> natural_transformation A B F G \<tau>"
- using mkArr_def arr_char null_char Dom_def Cod_def Fun_def Abs_arr_inverse
- UNIV_I fst_conv snd_conv option.sel
- by (metis option.distinct(1))
-
- lemma Dom_mkArr [simp]:
- assumes "arr (mkArr F G \<tau>)"
- shows "Dom (mkArr F G \<tau>) = F"
- using assms arr_char mkArr_def Dom_def Abs_arr_inverse
- by (metis UNIV_I fst_conv option.sel snd_conv)
-
- lemma Cod_mkArr [simp]:
- assumes "arr (mkArr F G \<tau>)"
- shows "Cod (mkArr F G \<tau>) = G"
- using assms arr_char mkArr_def Cod_def Abs_arr_inverse
- by (metis UNIV_I option.sel snd_conv)
-
- lemma Fun_mkArr [simp]:
- assumes "arr (mkArr F G \<tau>)"
- shows "Fun (mkArr F G \<tau>) = \<tau>"
- using assms arr_char mkArr_def Fun_def Abs_arr_inverse
- by (metis UNIV_I fst_conv option.sel)
-
- lemma mkArr_Fun:
- assumes "arr t"
- shows "mkArr (Dom t) (Cod t) (Fun t) = t"
- using assms arr_char mkArr_def
- by (metis Cod_def Dom_def Fun_def Rep_arr_inverse null_char option.collapse prod.collapse)
+ sublocale concrete_category \<open>Collect (functor A B)\<close>
+ \<open>\<lambda>F G. Collect (natural_transformation A B F G)\<close> \<open>\<lambda>F. F\<close>
+ \<open>\<lambda>F G H \<tau> \<sigma>. vertical_composite.map A B \<sigma> \<tau>\<close>
+ using vcomp_assoc
+ apply (unfold_locales, simp_all)
+ proof -
+ fix F G H \<sigma> \<tau>
+ assume F: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F"
+ assume G: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) G"
+ assume H: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) H"
+ assume \<sigma>: "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F G \<sigma>"
+ assume \<tau>: "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) G H \<tau>"
+ interpret F: "functor" A B F using F by simp
+ interpret G: "functor" A B G using G by simp
+ interpret H: "functor" A B H using H by simp
+ interpret \<sigma>: natural_transformation A B F G \<sigma>
+ using \<sigma> by simp
+ interpret \<tau>: natural_transformation A B G H \<tau>
+ using \<tau> by simp
+ interpret \<tau>\<sigma>: vertical_composite A B F G H \<sigma> \<tau>
+ ..
+ show "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F H (vertical_composite.map (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) \<sigma> \<tau>)"
+ using \<tau>\<sigma>.map_def \<tau>\<sigma>.is_natural_transformation by simp
+ qed
- lemma seq_char:
- shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> Cod f = Dom g"
- proof
- assume gf: "seq g f"
- have f: "arr f" using gf by auto
- moreover have g: "arr g" using gf by auto
- moreover have "Cod f = Dom g"
- proof -
- have "Cod f = Cod (dom g)"
- using f gf cod_char arr_cod_iff_arr [of f] by auto
- also have "... = Dom g"
- using g dom_char ide_dom Cod_mkArr by (metis arr_dom)
- finally show ?thesis by simp
- qed
- ultimately show "arr f \<and> arr g \<and> Cod f = Dom g" by blast
- next
- assume fg: "arr f \<and> arr g \<and> Cod f = Dom g"
- show "seq g f"
- using fg dom_char cod_char by auto
- qed
+ abbreviation comp (infixr "\<cdot>" 55)
+ where "comp \<equiv> COMP"
+ notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
- lemma comp_char:
- shows "g \<cdot> f = (if seq g f then
- mkArr (Dom f) (Cod g) (vertical_composite.map A B (Fun f) (Fun g))
- else null)"
- proof -
- have "\<not>seq g f \<Longrightarrow> g \<cdot> f = null"
- using comp_def AC.comp_char ext by fastforce
- moreover have
- "seq g f \<Longrightarrow>
- g \<cdot> f = mkArr (Dom f) (Cod g) (vertical_composite.map A B (Fun f) (Fun g))"
- proof -
- assume gf: "seq g f"
- interpret Fun_f: natural_transformation A B "Dom f" "Cod f" "Fun f"
- using gf arr_char by blast
- interpret Fun_g: natural_transformation A B "Cod f" "Cod g" "Fun g"
- using gf arr_char seq_char by simp
- interpret Fun_goFun_f: vertical_composite A B "Dom f" "Cod f" "Cod g" "Fun f" "Fun g" ..
- show ?thesis
- using gf comp_def AC.comp_char seqI' CC.comp_def arr_char null_char
- Dom_def Cod_def Fun_def mkArr_def Fun_goFun_f.natural_transformation_axioms
- by (metis (no_types, lifting) Comp'_def)
- qed
- ultimately show ?thesis by auto
- qed
+ lemma arrI [intro]:
+ assumes "f \<noteq> null" and "natural_transformation A B (Dom f) (Cod f) (Map f)"
+ shows "arr f"
+ using assms arr_char null_char
+ by (simp add: natural_transformation_def)
- lemma comp_simp:
- assumes "seq t s"
- shows "t \<cdot> s = mkArr (Dom s) (Cod t) (vertical_composite.map A B (Fun s) (Fun t))"
- using assms comp_char seq_char by auto
+ lemma arrE [elim]:
+ assumes "arr f"
+ and "f \<noteq> null \<Longrightarrow> natural_transformation A B (Dom f) (Cod f) (Map f) \<Longrightarrow> T"
+ shows T
+ using assms arr_char null_char by simp
- lemma ide_char [iff]:
- shows "ide t \<longleftrightarrow> t \<noteq> null \<and> functor A B (Fun t) \<and> Dom t = Fun t \<and> Cod t = Fun t"
- proof
- show "ide t \<Longrightarrow> t \<noteq> null \<and> functor A B (Fun t) \<and> Dom t = Fun t \<and> Cod t = Fun t"
- proof -
- assume t: "ide t"
- have 1: "t = mkIde (Dom t) \<and> t = mkIde (Cod t)"
- using t mkArr_Fun Cod_mkArr dom_simp cod_simp
- by (metis ideD(1) ideD(2))
- hence 2: "Dom t = Fun t \<and> Cod t = Fun t"
- using t 1 Fun_mkArr [of "Dom t" "Dom t" "Dom t"] Fun_mkArr [of "Cod t" "Cod t" "Cod t"]
- by auto
- have 3: "functor A B (Fun t)"
- using t 2 arr_char [of t] natural_transformation_def by force
- show "t \<noteq> null \<and> functor A B (Fun t) \<and> Dom t = Fun t \<and> Cod t = Fun t"
- using t 1 2 3 ideD(1) not_arr_null by blast
- qed
- show "t \<noteq> null \<and> functor A B (Fun t) \<and> Dom t = Fun t \<and> Cod t = Fun t \<Longrightarrow> ide t"
- using arr_char dom_simp mkArr_Fun [of t] ide_dom [of t] by simp
- qed
+ lemma arr_MkArr [iff]:
+ shows "arr (MkArr F G \<tau>) \<longleftrightarrow> natural_transformation A B F G \<tau>"
+ using arr_char null_char arr_MkArr natural_transformation_def by fastforce
- end
+ lemma ide_char [iff]:
+ shows "ide t \<longleftrightarrow> t \<noteq> null \<and> functor A B (Map t) \<and> Dom t = Map t \<and> Cod t = Map t"
+ using ide_char null_char by fastforce
end
- sublocale functor_category \<subseteq> category comp
- using is_category by auto
-
section "Additional Properties"
text\<open>
In this section some additional facts are proved, which make it easier to
work with the @{term "functor_category"} locale.
\<close>
context functor_category
begin
- lemma ide_mkIde [simp]:
- assumes "functor A B F"
- shows "ide (mkIde F)"
- using assms
- by (metis Cod_mkArr Dom_mkArr Fun_mkArr arr_mkArr functor_is_transformation
- ide_char not_arr_null)
-
- lemma Dom_ide:
- assumes "ide a"
- shows "Dom a = Fun a"
- using assms Dom_def Fun_def ide_char by blast
-
- lemma Cod_ide:
- assumes "ide a"
- shows "Cod a = Fun a"
- using assms Cod_def Fun_def ide_char by blast
-
- lemma Dom_dom [simp]:
- assumes "arr f"
- shows "Dom (dom f) = Dom f"
- using assms dom_simp Dom_mkArr arr_dom_iff_arr by metis
-
- lemma Cod_dom [simp]:
- assumes "arr f"
- shows "Cod (dom f) = Dom f"
- using assms dom_simp Cod_mkArr arr_dom_iff_arr by metis
-
- lemma Dom_cod [simp]:
- assumes "arr f"
- shows "Dom (cod f) = Cod f"
- using assms cod_simp Dom_mkArr arr_cod_iff_arr by metis
-
- lemma Cod_cod [simp]:
- assumes "arr f"
- shows "Cod (cod f) = Cod f"
- using assms cod_simp Cod_mkArr arr_cod_iff_arr by metis
-
- lemma Fun_dom [simp]:
- assumes "arr t"
- shows "Fun (dom t) = Dom t"
- using assms ide_dom by auto
-
- lemma Fun_cod [simp]:
- assumes "arr t"
- shows "Fun (cod t) = Cod t"
- using assms ide_cod by auto
-
- lemma Fun_comp [simp]:
+ lemma Map_comp [simp]:
assumes "seq t' t" and "A.seq a' a"
- shows "Fun (t' \<cdot> t) (a' \<cdot>\<^sub>A a) = Fun t' a' \<cdot>\<^sub>B Fun t a"
+ shows "Map (t' \<cdot> t) (a' \<cdot>\<^sub>A a) = Map t' a' \<cdot>\<^sub>B Map t a"
proof -
- interpret t: natural_transformation A B "Dom t" "Cod t" "Fun t"
+ interpret t: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
using assms(1) arr_char seq_char by blast
- interpret t': natural_transformation A B "Cod t" "Cod t'" "Fun t'"
- using assms(1) arr_char seq_char by auto
- interpret t'ot: vertical_composite A B "Dom t" "Cod t" "Cod t'" "Fun t" "Fun t'" ..
+ interpret t': natural_transformation A B \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t'\<close>
+ using assms(1) arr_char seq_char by force
+ interpret t'ot: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
show ?thesis
proof -
- have "Fun (t' \<cdot> t) = t'ot.map"
- using assms(1) seq_char comp_simp t'ot.natural_transformation_axioms by simp
+ have "Map (t' \<cdot> t) = t'ot.map"
+ using assms(1) seq_char t'ot.natural_transformation_axioms by simp
thus ?thesis
using assms(2) t'ot.map_simp_2 t'.preserves_comp_2 B.comp_assoc by auto
qed
qed
- lemma arr_eqI:
- assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Fun t = Fun t'"
- shows "t = t'"
- using assms mkArr_Fun by metis
+ lemma Map_comp':
+ assumes "seq t' t"
+ shows "Map (t' \<cdot> t) = vertical_composite.map A B (Map t) (Map t')"
+ proof -
+ interpret t: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
+ using assms(1) arr_char seq_char by blast
+ interpret t': natural_transformation A B \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t'\<close>
+ using assms(1) arr_char seq_char by force
+ interpret t'ot: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
+ show ?thesis
+ using assms(1) seq_char t'ot.natural_transformation_axioms by simp
+ qed
- lemma mkArr_eqI [intro]:
- assumes "arr (mkArr F G \<tau>)"
+ lemma MkArr_eqI [intro]:
+ assumes "arr (MkArr F G \<tau>)"
and "F = F'" and "G = G'" and "\<tau> = \<tau>'"
- shows "mkArr F G \<tau> = mkArr F' G' \<tau>'"
+ shows "MkArr F G \<tau> = MkArr F' G' \<tau>'"
using assms arr_eqI by simp
- lemma mkArr_eqI' [intro]:
- assumes "arr (mkArr F G \<tau>)" and "\<tau> = \<tau>'"
- shows "mkArr F G \<tau> = mkArr F G \<tau>'"
+ lemma MkArr_eqI' [intro]:
+ assumes "arr (MkArr F G \<tau>)" and "\<tau> = \<tau>'"
+ shows "MkArr F G \<tau> = MkArr F G \<tau>'"
using assms arr_eqI by simp
- lemma comp_mkArr [simp]:
- assumes "arr (mkArr F G \<sigma>)" and "arr (mkArr G H \<tau>)"
- shows "mkArr G H \<tau> \<cdot> mkArr F G \<sigma> = mkArr F H (vertical_composite.map A B \<sigma> \<tau>)"
- using assms mkArr_Fun dom_simp cod_simp comp_char seq_char by simp
-
- lemma mkArr_in_hom:
- assumes "natural_transformation A B F G \<tau>"
- shows "\<guillemotleft>mkArr F G \<tau> : mkIde F \<rightarrow> mkIde G\<guillemotright>"
- using assms dom_simp cod_simp by fastforce
-
lemma iso_char [iff]:
- shows "iso t \<longleftrightarrow> t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Fun t)"
+ shows "iso t \<longleftrightarrow> t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
proof
assume t: "iso t"
- show "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Fun t)"
+ show "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
proof
show "t \<noteq> null" using t arr_char iso_is_arr by auto
from t obtain t' where t': "inverse_arrows t t'" by blast
- interpret \<tau>: natural_transformation A B "Dom t" "Cod t" "Fun t"
+ interpret \<tau>: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
using t arr_char iso_is_arr by auto
- interpret \<tau>': natural_transformation A B "Cod t" "Dom t" "Fun t'"
+ interpret \<tau>': natural_transformation A B \<open>Cod t\<close> \<open>Dom t\<close> \<open>Map t'\<close>
using t' arr_char dom_char seq_char
- by (metis (no_types, lifting) comp_char ide_char inverse_arrowsE)
- interpret \<tau>'o\<tau>: vertical_composite A B "Dom t" "Cod t" "Dom t" "Fun t" "Fun t'" ..
- interpret \<tau>o\<tau>': vertical_composite A B "Cod t" "Dom t" "Cod t" "Fun t'" "Fun t" ..
- show "natural_isomorphism A B (Dom t) (Cod t) (Fun t)"
+ by (metis arrE ide_compE inverse_arrowsE)
+ interpret \<tau>'o\<tau>: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Dom t\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
+ interpret \<tau>o\<tau>': vertical_composite A B \<open>Cod t\<close> \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t'\<close> \<open>Map t\<close> ..
+ show "natural_isomorphism A B (Dom t) (Cod t) (Map t)"
proof
fix a
assume a: "A.ide a"
- show "B.iso (Fun t a)"
+ show "B.iso (Map t a)"
proof
have 1: "\<tau>'o\<tau>.map = Dom t \<and> \<tau>o\<tau>'.map = Cod t"
using t t'
- by (metis Fun_cod Fun_mkArr comp_simp seq_char ide_compE inverse_arrowsE)
- show "B.inverse_arrows (Fun t a) (Fun t' a)"
+ by (metis (no_types, lifting) Map_dom concrete_category.Map_comp
+ concrete_category_axioms ide_compE inverse_arrowsE seq_char)
+ show "B.inverse_arrows (Map t a) (Map t' a)"
using a 1 \<tau>o\<tau>'.map_simp_ide \<tau>'o\<tau>.map_simp_ide \<tau>.F.preserves_ide \<tau>.G.preserves_ide
by auto
qed
qed
qed
next
- assume t: "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Fun t)"
+ assume t: "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
show "iso t"
proof
- interpret \<tau>: natural_isomorphism A B "Dom t" "Cod t" "Fun t"
+ interpret \<tau>: natural_isomorphism A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
using t by auto
- interpret \<tau>': inverse_transformation A B "Dom t" "Cod t" "Fun t" ..
- have 1: "vertical_composite.map A B (Fun t) \<tau>'.map = Dom t \<and>
- vertical_composite.map A B \<tau>'.map (Fun t) = Cod t"
+ interpret \<tau>': inverse_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close> ..
+ have 1: "vertical_composite.map A B (Map t) \<tau>'.map = Dom t \<and>
+ vertical_composite.map A B \<tau>'.map (Map t) = Cod t"
using \<tau>.natural_isomorphism_axioms vertical_composite_inverse_iso
vertical_composite_iso_inverse
by blast
- show "inverse_arrows t (mkArr (Cod t) (Dom t) (\<tau>'.map))"
+ show "inverse_arrows t (MkArr (Cod t) (Dom t) (\<tau>'.map))"
proof
- show "ide (mkArr (Cod t) (Dom t) \<tau>'.map \<cdot> t)"
+ show 2: "ide (MkArr (Cod t) (Dom t) \<tau>'.map \<cdot> t)"
using t 1
- by (metis \<tau>'.natural_transformation_axioms \<tau>.F.functor_axioms
- \<tau>.natural_transformation_axioms arr_mkArr arrI
- comp_mkArr ide_mkIde mkArr_Fun)
- show "ide (t \<cdot> mkArr (Cod t) (Dom t) \<tau>'.map)"
- using t 1
- by (metis \<tau>'.natural_transformation_axioms \<tau>.G.functor_axioms
- \<tau>.natural_transformation_axioms arr_mkArr arrI
- comp_mkArr ide_mkIde mkArr_Fun)
+ by (metis (no_types, lifting) MkArr_Map MkIde_Dom \<tau>'.natural_transformation_axioms
+ \<tau>.natural_transformation_axioms arrI arr_MkArr comp_MkArr ide_dom)
+ show "ide (t \<cdot> MkArr (Cod t) (Dom t) \<tau>'.map)"
+ using t 1 2
+ by (metis Map.simps(1) \<tau>'.natural_transformation_axioms arr_MkArr comp_char
+ dom_MkArr dom_comp ide_char' ide_compE)
qed
qed
qed
end
section "Evaluation Functor"
text\<open>
This section defines the evaluation map that applies an arrow of the functor
category \<open>[A, B]\<close> to an arrow of @{term A} to obtain an arrow of @{term B}
and shows that it is functorial.
\<close>
locale evaluation_functor =
A: category A +
B: category B +
A_B: functor_category A B +
A_BxA: product_category A_B.comp A
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
begin
notation A_B.comp (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]" 55)
notation A_BxA.comp (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A" 55)
notation A_B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
notation A_BxA.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A _\<guillemotright>")
definition map
- where "map Fg \<equiv> if A_BxA.arr Fg then A_B.Fun (fst Fg) (snd Fg) else B.null"
+ where "map Fg \<equiv> if A_BxA.arr Fg then A_B.Map (fst Fg) (snd Fg) else B.null"
lemma map_simp:
assumes "A_BxA.arr Fg"
- shows "map Fg = A_B.Fun (fst Fg) (snd Fg)"
+ shows "map Fg = A_B.Map(fst Fg) (snd Fg)"
using assms map_def by auto
lemma is_functor:
shows "functor A_BxA.comp B map"
proof
show "\<And>Fg. \<not> A_BxA.arr Fg \<Longrightarrow> map Fg = B.null"
using map_def by auto
fix Fg
assume Fg: "A_BxA.arr Fg"
let ?F = "fst Fg" and ?g = "snd Fg"
have F: "A_B.arr ?F" using Fg by auto
have g: "A.arr ?g" using Fg by auto
- have DomF: "A_B.Dom ?F = A_B.Fun (A_B.dom ?F)" using F A_B.Fun_dom by simp
- have CodF: "A_B.Cod ?F = A_B.Fun (A_B.cod ?F)" using F A_B.Fun_cod by simp
- interpret F: natural_transformation A B "A_B.Dom ?F" "A_B.Cod ?F" "A_B.Fun ?F"
+ have DomF: "A_B.Dom ?F = A_B.Map (A_B.dom ?F)" using F by simp
+ have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)" using F by simp
+ interpret F: natural_transformation A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Map ?F\<close>
using Fg A_B.arr_char [of ?F] by blast
show "B.arr (map Fg)" using Fg map_def by auto
show "B.dom (map Fg) = map (A_BxA.dom Fg)"
- using Fg map_def DomF
- by (metis A_BxA.arr_dom_iff_arr A_BxA.dom_simp F.preserves_dom fst_conv g snd_conv)
+ using g Fg map_def DomF
+ by (metis (no_types, lifting) A_BxA.arr_dom A_BxA.dom_simp F.preserves_dom
+ fst_conv snd_conv)
show "B.cod (map Fg) = map (A_BxA.cod Fg)"
- using Fg map_def CodF
- by (metis A_BxA.arr_cod_iff_arr A_BxA.cod_simp F.preserves_cod fst_conv g snd_conv)
+ using g Fg map_def CodF
+ by (metis (no_types, lifting) A_BxA.arr_cod A_BxA.cod_simp F.preserves_cod
+ fst_conv snd_conv)
next
fix Fg Fg'
assume 1: "A_BxA.seq Fg' Fg"
let ?F = "fst Fg" and ?g = "snd Fg"
let ?F' = "fst Fg'" and ?g' = "snd Fg'"
have F': "A_B.arr ?F'" using 1 A_BxA.seqE by blast
- have CodF: "A_B.Cod ?F = A_B.Fun (A_B.cod ?F)"
- using 1 A_B.Fun_cod by fastforce
- have DomF': "A_B.Dom ?F' = A_B.Fun (A_B.dom ?F')"
- using F' A_B.Fun_dom by simp
+ have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)"
+ using 1 by (metis A_B.Map_cod A_B.seqE A_BxA.seqE)
+ have DomF': "A_B.Dom ?F' = A_B.Map (A_B.dom ?F')"
+ using F' by simp
have seq_F'F: "A_B.seq ?F' ?F" using 1 by blast
have seq_g'g: "A.seq ?g' ?g" using 1 by blast
- interpret F: natural_transformation A B "A_B.Dom ?F" "A_B.Cod ?F" "A_B.Fun ?F"
+ interpret F: natural_transformation A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Map ?F\<close>
using 1 A_B.arr_char by blast
- interpret F': natural_transformation A B "A_B.Cod ?F" "A_B.Cod ?F'" "A_B.Fun ?F'"
- using 1 seq_F'F CodF DomF' A_B.arr_char A_B.seqE by metis
- interpret F'oF: vertical_composite A B "A_B.Dom ?F" "A_B.Cod ?F" "A_B.Cod ?F'"
- "A_B.Fun ?F" "A_B.Fun ?F'" ..
+ interpret F': natural_transformation A B \<open>A_B.Cod ?F\<close> \<open>A_B.Cod ?F'\<close> \<open>A_B.Map ?F'\<close>
+ using 1 A_B.arr_char seq_F'F CodF DomF' A_B.seqE
+ by (metis mem_Collect_eq)
+ interpret F'oF: vertical_composite A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Cod ?F'\<close>
+ \<open>A_B.Map ?F\<close> \<open>A_B.Map ?F'\<close> ..
show "map (Fg' \<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A Fg) = map Fg' \<cdot>\<^sub>B map Fg"
- unfolding map_def A_B.Fun_def
- using 1 seq_F'F seq_g'g A_B.Fun_comp A_B.Fun_def A_BxA.comp_def
- by (elim A_B.seqE, auto)
+ unfolding map_def
+ using 1 seq_F'F seq_g'g by auto
qed
end
sublocale evaluation_functor \<subseteq> "functor" A_BxA.comp B map
using is_functor by auto
sublocale evaluation_functor \<subseteq> binary_functor A_B.comp A B map ..
section "Currying"
text\<open>
This section defines the notion of currying of a natural transformation
between binary functors, to obtain a natural transformation between
functors into a functor category, along with the inverse operation of uncurrying.
We have only proved here what is needed to establish the results
in theory \<open>Limit\<close> about limits in functor categories and have not
attempted to fully develop the functoriality and naturality properties of
these notions.
\<close>
locale currying =
A1: category A1 +
A2: category A2 +
B: category B
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
begin
interpretation A1xA2: product_category A1 A2 ..
interpretation A2_B: functor_category A2 B ..
interpretation A2_BxA2: product_category A2_B.comp A2 ..
interpretation E: evaluation_functor A2 B ..
notation A1xA2.comp (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
notation A2_B.comp (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>]" 55)
notation A2_BxA2.comp (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A\<^sub>2" 55)
notation A1xA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
notation A2_B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
notation A2_BxA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
text\<open>
A proper definition for @{term curry} requires that it be parametrized by
binary functors @{term F} and @{term G} that are the domain and codomain
of the natural transformations to which it is being applied.
Similar parameters are not needed in the case of @{term uncurry}.
\<close>
definition curry :: "('a1 \<times> 'a2 \<Rightarrow> 'b) \<Rightarrow> ('a1 \<times> 'a2 \<Rightarrow> 'b) \<Rightarrow> ('a1 \<times> 'a2 \<Rightarrow> 'b)
\<Rightarrow> 'a1 \<Rightarrow> ('a2, 'b) A2_B.arr"
where "curry F G \<tau> f1 = (if A1.arr f1 then
- A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
+ A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
(\<lambda>f2. \<tau> (f1, f2))
else A2_B.null)"
definition uncurry :: "('a1 \<Rightarrow> ('a2, 'b) A2_B.arr) \<Rightarrow> 'a1 \<times> 'a2 \<Rightarrow> 'b"
where "uncurry \<tau> f \<equiv> if A1xA2.arr f then E.map (\<tau> (fst f), snd f) else B.null"
lemma curry_simp:
assumes "A1.arr f1"
- shows "curry F G \<tau> f1 = A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
+ shows "curry F G \<tau> f1 = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
(\<lambda>f2. \<tau> (f1, f2))"
using assms curry_def by auto
lemma uncurry_simp:
assumes "A1xA2.arr f"
shows "uncurry \<tau> f = E.map (\<tau> (fst f), snd f)"
using assms uncurry_def by auto
lemma curry_in_hom:
assumes f1: "A1.arr f1"
and "natural_transformation A1xA2.comp B F G \<tau>"
shows "\<guillemotleft>curry F G \<tau> f1 : curry F F F (A1.dom f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry G G G (A1.cod f1)\<guillemotright>"
proof -
interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
show ?thesis
proof -
- interpret F_dom_f1: "functor" A2 B "\<lambda>f2. F (A1.dom f1, f2)"
+ interpret F_dom_f1: "functor" A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
using f1 \<tau>.F.is_extensional apply (unfold_locales, simp_all)
by (metis A1xA2.comp_char A1.arr_dom_iff_arr A1.comp_arr_dom A1.dom_dom
A1xA2.seqI \<tau>.F.preserves_comp_2 fst_conv snd_conv)
- interpret G_cod_f1: "functor" A2 B "\<lambda>f2. G (A1.cod f1, f2)"
+ interpret G_cod_f1: "functor" A2 B \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
using f1 \<tau>.G.is_extensional A1.arr_cod_iff_arr
apply (unfold_locales, simp_all)
using A1xA2.comp_char A1.arr_cod_iff_arr A1.comp_cod_arr
by (metis A1.cod_cod A1xA2.seqI \<tau>.G.preserves_comp_2 fst_conv snd_conv)
have "natural_transformation A2 B (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
(\<lambda>f2. \<tau> (f1, f2))"
using f1 \<tau>.is_extensional apply (unfold_locales, simp_all)
proof -
fix f2
assume f2: "A2.arr f2"
show "G (A1.cod f1, f2) \<cdot>\<^sub>B \<tau> (f1, A2.dom f2) = \<tau> (f1, f2)"
using f1 f2 \<tau>.preserves_comp_1 [of "(A1.cod f1, f2)" "(f1, A2.dom f2)"]
A1.comp_cod_arr A2.comp_arr_dom
by simp
show "\<tau> (f1, A2.cod f2) \<cdot>\<^sub>B F (A1.dom f1, f2) = \<tau> (f1, f2)"
using f1 f2 \<tau>.preserves_comp_2 [of "(f1, A2.cod f2)" "(A1.dom f1, f2)"]
A1.comp_arr_dom A2.comp_cod_arr
by simp
qed
thus ?thesis
- using f1 A2_B.arr_mkArr A2_B.dom_simp A2_B.cod_simp curry_simp
- A1.arr_dom_iff_arr A1.arr_cod_iff_arr
- by auto
+ using f1 curry_simp by auto
qed
qed
lemma curry_preserves_functors:
assumes "functor A1xA2.comp B F"
shows "functor A1 A2_B.comp (curry F F F)"
proof -
interpret F: "functor" A1xA2.comp B F using assms by auto
interpret F: binary_functor A1 A2 B F ..
show ?thesis
- using curry_def F.fixing_arr_gives_natural_transformation_1 A2_B.dom_simp A2_B.cod_simp
- A2_B.comp_char F.preserves_comp_1 curry_simp A2_B.comp_simp A2_B.seq_char
- A1.arr_cod_iff_arr
+ using curry_def F.fixing_arr_gives_natural_transformation_1
+ A2_B.comp_char F.preserves_comp_1 curry_simp A2_B.seq_char
apply unfold_locales by auto
qed
lemma curry_preserves_transformations:
assumes "natural_transformation A1xA2.comp B F G \<tau>"
shows "natural_transformation A1 A2_B.comp (curry F F F) (curry G G G) (curry F G \<tau>)"
proof -
interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
interpret \<tau>: binary_functor_transformation A1 A2 B F G \<tau> ..
- interpret curry_F: "functor" A1 A2_B.comp "curry F F F"
+ interpret curry_F: "functor" A1 A2_B.comp \<open>curry F F F\<close>
using curry_preserves_functors \<tau>.F.functor_axioms by simp
- interpret curry_G: "functor" A1 A2_B.comp "curry G G G"
+ interpret curry_G: "functor" A1 A2_B.comp \<open>curry G G G\<close>
using curry_preserves_functors \<tau>.G.functor_axioms by simp
show ?thesis
proof
show "\<And>f2. \<not> A1.arr f2 \<Longrightarrow> curry F G \<tau> f2 = A2_B.null"
using curry_def by simp
fix f1
assume f1: "A1.arr f1"
show "A2_B.dom (curry F G \<tau> f1) = curry F F F (A1.dom f1)"
using assms f1 curry_in_hom by blast
show "A2_B.cod (curry F G \<tau> f1) = curry G G G (A1.cod f1)"
using assms f1 curry_in_hom by blast
show "curry G G G f1 \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F G \<tau> (A1.dom f1) = curry F G \<tau> f1"
proof -
- interpret \<tau>_dom_f1: natural_transformation A2 B "\<lambda>f2. F (A1.dom f1, f2)"
- "\<lambda>f2. G (A1.dom f1, f2)" "\<lambda>f2. \<tau> (A1.dom f1, f2)"
- using assms f1 curry_in_hom A2_B.arr_mkArr A1.ide_dom
- \<tau>.fixing_ide_gives_natural_transformation_1
+ interpret \<tau>_dom_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
+ \<open>\<lambda>f2. G (A1.dom f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.dom f1, f2)\<close>
+ using assms f1 curry_in_hom A1.ide_dom \<tau>.fixing_ide_gives_natural_transformation_1
by blast
interpret G_f1: natural_transformation A2 B
- "\<lambda>f2. G (A1.dom f1, f2)" "\<lambda>f2. G (A1.cod f1, f2)" "\<lambda>f2. G (f1, f2)"
+ \<open>\<lambda>f2. G (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. G (f1, f2)\<close>
using f1 \<tau>.G.fixing_arr_gives_natural_transformation_1 by simp
interpret G_f1o\<tau>_dom_f1: vertical_composite A2 B
- "\<lambda>f2. F (A1.dom f1, f2)" "\<lambda>f2. G (A1.dom f1, f2)"
- "\<lambda>f2. G (A1.cod f1, f2)"
- "\<lambda>f2. \<tau> (A1.dom f1, f2)" "\<lambda>f2. G (f1, f2)" ..
+ \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (A1.dom f1, f2)\<close>
+ \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
+ \<open>\<lambda>f2. \<tau> (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (f1, f2)\<close> ..
have "curry G G G f1 \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F G \<tau> (A1.dom f1)
- = A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) G_f1o\<tau>_dom_f1.map"
+ = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) G_f1o\<tau>_dom_f1.map"
proof -
have "A2_B.seq (curry G G G f1) (curry F G \<tau> (A1.dom f1))"
using f1 curry_in_hom [of "A1.dom f1"] \<tau>.natural_transformation_axioms by force
thus ?thesis
- using curry_simp A2_B.comp_simp [of "curry G G G f1" "curry F G \<tau> (A1.dom f1)"]
- by (metis A1.arr_dom_iff_arr A1.dom_dom A2_B.Cod_mkArr A2_B.Dom_mkArr
- A2_B.Fun_mkArr A2_B.seqE f1)
+ using f1 curry_simp A2_B.comp_char [of "curry G G G f1" "curry F G \<tau> (A1.dom f1)"]
+ by simp
qed
- also have "... = A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
+ also have "... = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
(\<lambda>f2. \<tau> (f1, f2))"
- proof (intro A2_B.mkArr_eqI)
+ proof (intro A2_B.MkArr_eqI)
show "(\<lambda>f2. F (A1.dom f1, f2)) = (\<lambda>f2. F (A1.dom f1, f2))" by simp
show "(\<lambda>f2. G (A1.cod f1, f2)) = (\<lambda>f2. G (A1.cod f1, f2))" by simp
- show "A2_B.arr (A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
+ show "A2_B.arr (A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
G_f1o\<tau>_dom_f1.map)"
- using A2_B.arr_mkArr G_f1o\<tau>_dom_f1.natural_transformation_axioms by blast
+ using G_f1o\<tau>_dom_f1.natural_transformation_axioms by blast
show "G_f1o\<tau>_dom_f1.map = (\<lambda>f2. \<tau> (f1, f2))"
proof
fix f2
have "\<not>A2.arr f2 \<Longrightarrow> G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
using f1 G_f1o\<tau>_dom_f1.is_extensional \<tau>.is_extensional by simp
moreover have "A2.arr f2 \<Longrightarrow> G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
proof -
- interpret \<tau>_f1: natural_transformation A2 B "\<lambda>f2. F (A1.dom f1, f2)"
- "\<lambda>f2. G (A1.cod f1, f2)" "\<lambda>f2. \<tau> (f1, f2)"
- using assms f1 curry_in_hom [of f1] A2_B.arr_mkArr curry_simp by auto
+ interpret \<tau>_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
+ \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (f1, f2)\<close>
+ using assms f1 curry_in_hom [of f1] curry_simp by auto
fix f2
assume f2: "A2.arr f2"
show "G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
using f1 f2 G_f1o\<tau>_dom_f1.map_simp_2 B.comp_assoc \<tau>.is_natural_1
by fastforce
qed
ultimately show "G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2" by blast
qed
qed
also have "... = curry F G \<tau> f1" using f1 curry_def by simp
finally show ?thesis by blast
qed
show "curry F G \<tau> (A1.cod f1) \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F F F f1 = curry F G \<tau> f1"
proof -
- interpret \<tau>_cod_f1: natural_transformation A2 B "\<lambda>f2. F (A1.cod f1, f2)"
- "\<lambda>f2. G (A1.cod f1, f2)" "\<lambda>f2. \<tau> (A1.cod f1, f2)"
- using assms f1 curry_in_hom A2_B.arr_mkArr A1.ide_cod
- \<tau>.fixing_ide_gives_natural_transformation_1
+ interpret \<tau>_cod_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
+ \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.cod f1, f2)\<close>
+ using assms f1 curry_in_hom A1.ide_cod \<tau>.fixing_ide_gives_natural_transformation_1
by blast
interpret F_f1: natural_transformation A2 B
- "\<lambda>f2. F (A1.dom f1, f2)" "\<lambda>f2. F (A1.cod f1, f2)" "\<lambda>f2. F (f1, f2)"
+ \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (f1, f2)\<close>
using f1 \<tau>.F.fixing_arr_gives_natural_transformation_1 by simp
interpret \<tau>_cod_f1oF_f1: vertical_composite A2 B
- "\<lambda>f2. F (A1.dom f1, f2)" "\<lambda>f2. F (A1.cod f1, f2)"
- "\<lambda>f2. G (A1.cod f1, f2)"
- "\<lambda>f2. F (f1, f2)" "\<lambda>f2. \<tau> (A1.cod f1, f2)" ..
+ \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
+ \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
+ \<open>\<lambda>f2. F (f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.cod f1, f2)\<close> ..
have "curry F G \<tau> (A1.cod f1) \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F F F f1
- = A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) \<tau>_cod_f1oF_f1.map"
+ = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) \<tau>_cod_f1oF_f1.map"
proof -
have
"curry F F F f1 =
- A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2))
- (\<lambda>f2. F (f1, f2)) \<and>
+ A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2))
+ (\<lambda>f2. F (f1, f2)) \<and>
\<guillemotleft>curry F F F f1 : curry F F F (A1.dom f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry F F F (A1.cod f1)\<guillemotright>"
using f1 curry_F.preserves_hom curry_simp by blast
moreover have
"curry F G \<tau> (A1.dom f1) =
- A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.dom f1, f2))
+ A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.dom f1, f2))
(\<lambda>f2. \<tau> (A1.dom f1, f2)) \<and>
\<guillemotleft>curry F G \<tau> (A1.cod f1) :
curry F F F (A1.cod f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry G G G (A1.cod f1)\<guillemotright>"
using assms f1 curry_in_hom [of "A1.cod f1"] curry_def A1.arr_cod_iff_arr by simp
ultimately show ?thesis
- using f1 curry_def A2_B.comp_mkArr by fastforce
+ using f1 curry_def by fastforce
qed
- also have "... = A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
+ also have "... = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
(\<lambda>f2. \<tau> (f1, f2))"
- proof (intro A2_B.mkArr_eqI)
+ proof (intro A2_B.MkArr_eqI)
show "(\<lambda>f2. F (A1.dom f1, f2)) = (\<lambda>f2. F (A1.dom f1, f2))" by simp
show "(\<lambda>f2. G (A1.cod f1, f2)) = (\<lambda>f2. G (A1.cod f1, f2))" by simp
- show "A2_B.arr (A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
+ show "A2_B.arr (A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
\<tau>_cod_f1oF_f1.map)"
- using A2_B.arr_mkArr \<tau>_cod_f1oF_f1.natural_transformation_axioms by blast
+ using \<tau>_cod_f1oF_f1.natural_transformation_axioms by blast
show "\<tau>_cod_f1oF_f1.map = (\<lambda>f2. \<tau> (f1, f2))"
proof
fix f2
have "\<not>A2.arr f2 \<Longrightarrow> \<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
using f1 by (simp add: \<tau>.is_extensional \<tau>_cod_f1oF_f1.is_extensional)
moreover have "A2.arr f2 \<Longrightarrow> \<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
proof -
- interpret \<tau>_f1: natural_transformation A2 B "\<lambda>f2. F (A1.dom f1, f2)"
- "\<lambda>f2. G (A1.cod f1, f2)" "\<lambda>f2. \<tau> (f1, f2)"
- using assms f1 curry_in_hom [of f1] A2_B.arr_mkArr curry_simp by auto
+ interpret \<tau>_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
+ \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (f1, f2)\<close>
+ using assms f1 curry_in_hom [of f1] curry_simp by auto
fix f2
assume f2: "A2.arr f2"
show "\<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
using f1 f2 \<tau>_cod_f1oF_f1.map_simp_1 B.comp_assoc \<tau>.is_natural_2
by fastforce
qed
ultimately show "\<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2" by blast
qed
qed
also have "... = curry F G \<tau> f1" using f1 curry_def by simp
finally show ?thesis by blast
qed
qed
qed
lemma uncurry_preserves_functors:
assumes "functor A1 A2_B.comp F"
shows "functor A1xA2.comp B (uncurry F)"
proof -
interpret F: "functor" A1 A2_B.comp F using assms by auto
show ?thesis
using uncurry_def
apply (unfold_locales)
apply auto[4]
proof -
fix f g :: "'a1 * 'a2"
let ?f1 = "fst f"
let ?f2 = "snd f"
let ?g1 = "fst g"
let ?g2 = "snd g"
assume fg: "A1xA2.seq g f"
have f: "A1xA2.arr f" using fg A1xA2.seqE by blast
have f1: "A1.arr ?f1" using f by auto
have f2: "A2.arr ?f2" using f by auto
have g: "\<guillemotleft>g : A1xA2.cod f \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 A1xA2.cod g\<guillemotright>"
using fg A1xA2.dom_char A1xA2.cod_char
by (elim A1xA2.seqE, intro A1xA2.in_homI, auto)
let ?g1 = "fst g"
let ?g2 = "snd g"
have g1: "\<guillemotleft>?g1 : A1.cod ?f1 \<rightarrow>\<^sub>A\<^sub>1 A1.cod ?g1\<guillemotright>"
using f g by (intro A1.in_homI, auto)
have g2: "\<guillemotleft>?g2 : A2.cod ?f2 \<rightarrow>\<^sub>A\<^sub>2 A2.cod ?g2\<guillemotright>"
using f g by (intro A2.in_homI, auto)
- interpret Ff1: natural_transformation A2 B "A2_B.Dom (F ?f1)" "A2_B.Cod (F ?f1)"
- "A2_B.Fun (F ?f1)"
+ interpret Ff1: natural_transformation A2 B \<open>A2_B.Dom (F ?f1)\<close> \<open>A2_B.Cod (F ?f1)\<close>
+ \<open>A2_B.Map (F ?f1)\<close>
using f A2_B.arr_char [of "F ?f1"] by auto
- interpret Fg1: natural_transformation A2 B "A2_B.Cod (F ?f1)" "A2_B.Cod (F ?g1)"
- "A2_B.Fun (F ?g1)"
+ interpret Fg1: natural_transformation A2 B \<open>A2_B.Cod (F ?f1)\<close> \<open>A2_B.Cod (F ?g1)\<close>
+ \<open>A2_B.Map (F ?g1)\<close>
using f1 g1 A2_B.arr_char F.preserves_arr
- A2_B.Fun_dom [of "F ?g1"] A2_B.Fun_cod [of "F ?f1"]
+ A2_B.Map_dom [of "F ?g1"] A2_B.Map_cod [of "F ?f1"]
by fastforce
interpret Fg1oFf1: vertical_composite A2 B
- "A2_B.Dom (F ?f1)" "A2_B.Cod (F ?f1)" "A2_B.Cod (F ?g1)"
- "A2_B.Fun (F ?f1)" "A2_B.Fun (F ?g1)" ..
+ \<open>A2_B.Dom (F ?f1)\<close> \<open>A2_B.Cod (F ?f1)\<close> \<open>A2_B.Cod (F ?g1)\<close>
+ \<open>A2_B.Map (F ?f1)\<close> \<open>A2_B.Map (F ?g1)\<close> ..
show "uncurry F (g \<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 f) = uncurry F g \<cdot>\<^sub>B uncurry F f"
using f1 g1 g2 g2 f g fg E.map_simp uncurry_def by auto
qed
qed
lemma uncurry_preserves_transformations:
assumes "natural_transformation A1 A2_B.comp F G \<tau>"
shows "natural_transformation A1xA2.comp B (uncurry F) (uncurry G) (uncurry \<tau>)"
proof -
interpret \<tau>: natural_transformation A1 A2_B.comp F G \<tau> using assms by auto
- interpret "functor" A1xA2.comp B "uncurry F"
+ interpret "functor" A1xA2.comp B \<open>uncurry F\<close>
using \<tau>.F.functor_axioms uncurry_preserves_functors by blast
- interpret "functor" A1xA2.comp B "uncurry G"
+ interpret "functor" A1xA2.comp B \<open>uncurry G\<close>
using \<tau>.G.functor_axioms uncurry_preserves_functors by blast
show ?thesis
proof
fix f
show "\<not> A1xA2.arr f \<Longrightarrow> uncurry \<tau> f = B.null"
using uncurry_def by auto
assume f: "A1xA2.arr f"
let ?f1 = "fst f"
let ?f2 = "snd f"
show "B.dom (uncurry \<tau> f) = uncurry F (A1xA2.dom f)"
using f uncurry_def by simp
show "B.cod (uncurry \<tau> f) = uncurry G (A1xA2.cod f)"
using f uncurry_def by simp
show "uncurry G f \<cdot>\<^sub>B uncurry \<tau> (A1xA2.dom f) = uncurry \<tau> f"
using f uncurry_def \<tau>.is_natural_1 A2_BxA2.seq_char A2.comp_arr_dom
E.preserves_comp [of "(G (fst f), snd f)" "(\<tau> (A1.dom (fst f)), A2.dom (snd f))"]
by auto
show "uncurry \<tau> (A1xA2.cod f) \<cdot>\<^sub>B uncurry F f = uncurry \<tau> f"
proof -
have 1: "A1.arr ?f1 \<and> A1.arr (fst (A1.cod ?f1, A2.cod ?f2)) \<and>
A1.cod ?f1 = A1.dom (fst (A1.cod ?f1, A2.cod ?f2)) \<and>
A2.seq (snd (A1.cod ?f1, A2.cod ?f2)) ?f2"
using f A1.arr_cod_iff_arr A2.arr_cod_iff_arr by auto
hence 2:
"?f2 = A2 (snd (\<tau> (fst (A1xA2.cod f)), snd (A1xA2.cod f))) (snd (F ?f1, ?f2))"
using f A2.comp_cod_arr by simp
have "A2_B.arr (\<tau> ?f1)" using 1 by force
thus ?thesis
- using f 1 2 uncurry_def \<tau>.is_natural_2 [of ?f1] A1xA2.cod_simp A2.seqE
- A1xA2.arr_cod_iff_arr A2_BxA2.comp_char
- by (metis (no_types) A2_BxA2.seqI E.preserves_comp fst_conv)
+ unfolding uncurry_def E.map_def
+ using f 1 2
+ apply simp
+ by (metis (no_types, lifting) A2_B.Map_comp \<open>A2_B.arr (\<tau> (fst f))\<close> \<tau>.is_natural_2)
+
qed
qed
qed
lemma uncurry_curry:
assumes "natural_transformation A1xA2.comp B F G \<tau>"
shows "uncurry (curry F G \<tau>) = \<tau>"
proof
interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
- interpret curry_\<tau>: natural_transformation A1 A2_B.comp "curry F F F" "curry G G G"
- "curry F G \<tau>"
+ interpret curry_\<tau>: natural_transformation A1 A2_B.comp \<open>curry F F F\<close> \<open>curry G G G\<close>
+ \<open>curry F G \<tau>\<close>
using assms curry_preserves_transformations by auto
fix f
have "\<not>A1xA2.arr f \<Longrightarrow> uncurry (curry F G \<tau>) f = \<tau> f"
using curry_def uncurry_def \<tau>.is_extensional by auto
moreover have "A1xA2.arr f \<Longrightarrow> uncurry (curry F G \<tau>) f = \<tau> f"
- unfolding uncurry_def using A1xA2.arr_char E.map_simp
- by (metis A2_B.Fun_mkArr A2_BxA2.arr_char curry_\<tau>.preserves_reflects_arr fst_conv
- curry_def prod.collapse snd_conv)
+ proof -
+ assume f: "A1xA2.arr f"
+ have 1: "A2_B.Map (curry F G \<tau> (fst f)) (snd f) = \<tau> (fst f, snd f)"
+ using f A1xA2.arr_char curry_def by simp
+ thus "uncurry (curry F G \<tau>) f = \<tau> f"
+ unfolding uncurry_def E.map_def
+ using f 1 A1xA2.arr_char [of f] by simp
+ qed
ultimately show "uncurry (curry F G \<tau>) f = \<tau> f" by blast
qed
lemma curry_uncurry:
assumes "functor A1 A2_B.comp F" and "functor A1 A2_B.comp G"
and "natural_transformation A1 A2_B.comp F G \<tau>"
shows "curry (uncurry F) (uncurry G) (uncurry \<tau>) = \<tau>"
proof
interpret F: "functor" A1 A2_B.comp F using assms(1) by auto
interpret G: "functor" A1 A2_B.comp G using assms(2) by auto
interpret \<tau>: natural_transformation A1 A2_B.comp F G \<tau> using assms(3) by auto
- interpret uncurry_F: "functor" A1xA2.comp B "uncurry F"
+ interpret uncurry_F: "functor" A1xA2.comp B \<open>uncurry F\<close>
using F.functor_axioms uncurry_preserves_functors by auto
- interpret uncurry_G: "functor" A1xA2.comp B "uncurry G"
+ interpret uncurry_G: "functor" A1xA2.comp B \<open>uncurry G\<close>
using G.functor_axioms uncurry_preserves_functors by auto
fix f1
have "\<not>A1.arr f1 \<Longrightarrow> curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1"
using curry_def uncurry_def \<tau>.is_extensional by simp
moreover have "A1.arr f1 \<Longrightarrow> curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1"
proof -
assume f1: "A1.arr f1"
interpret uncurry_\<tau>:
- natural_transformation A1xA2.comp B "uncurry F" "uncurry G" "uncurry \<tau>"
+ natural_transformation A1xA2.comp B \<open>uncurry F\<close> \<open>uncurry G\<close> \<open>uncurry \<tau>\<close>
using \<tau>.natural_transformation_axioms uncurry_preserves_transformations [of F G \<tau>]
by simp
have "curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 =
- A2_B.mkArr (\<lambda>f2. uncurry F (A1.dom f1, f2)) (\<lambda>f2. uncurry G (A1.cod f1, f2))
+ A2_B.MkArr (\<lambda>f2. uncurry F (A1.dom f1, f2)) (\<lambda>f2. uncurry G (A1.cod f1, f2))
(\<lambda>f2. uncurry \<tau> (f1, f2))"
using f1 curry_def by simp
- also have "... = A2_B.mkArr (\<lambda>f2. uncurry F (A1.dom f1, f2))
+ also have "... = A2_B.MkArr (\<lambda>f2. uncurry F (A1.dom f1, f2))
(\<lambda>f2. uncurry G (A1.cod f1, f2))
(\<lambda>f2. E.map (\<tau> f1, f2))"
proof -
have "(\<lambda>f2. uncurry \<tau> (f1, f2)) = (\<lambda>f2. E.map (\<tau> f1, f2))"
using f1 uncurry_def E.is_extensional by auto
thus ?thesis by simp
qed
also have "... = \<tau> f1"
proof -
have "A2_B.Dom (\<tau> f1) = (\<lambda>f2. uncurry F (A1.dom f1, f2))"
proof -
- have "A2_B.Dom (\<tau> f1) = A2_B.Fun (A2_B.dom (\<tau> f1))"
- using f1 A2_B.ide_char A2_B.Fun_dom A2_B.dom_simp by auto
- also have "... = A2_B.Fun (F (A1.dom f1))"
+ have "A2_B.Dom (\<tau> f1) = A2_B.Map (A2_B.dom (\<tau> f1))"
+ using f1 A2_B.ide_char A2_B.Map_dom A2_B.dom_char by auto
+ also have "... = A2_B.Map (F (A1.dom f1))"
using f1 by simp
also have "... = (\<lambda>f2. uncurry F (A1.dom f1, f2))"
proof
fix f2
- interpret F_dom_f1: "functor" A2 B "A2_B.Fun (F (A1.dom f1))"
+ interpret F_dom_f1: "functor" A2 B \<open>A2_B.Map (F (A1.dom f1))\<close>
using f1 A2_B.ide_char F.preserves_ide by simp
- show "A2_B.Fun (F (A1.dom f1)) f2 = uncurry F (A1.dom f1, f2)"
+ show "A2_B.Map (F (A1.dom f1)) f2 = uncurry F (A1.dom f1, f2)"
using f1 uncurry_def E.map_simp F_dom_f1.is_extensional by auto
qed
finally show ?thesis by auto
qed
moreover have "A2_B.Cod (\<tau> f1) = (\<lambda>f2. uncurry G (A1.cod f1, f2))"
proof -
- have "A2_B.Cod (\<tau> f1) = A2_B.Fun (A2_B.cod (\<tau> f1))"
- using f1 A2_B.ide_char A2_B.Fun_cod A2_B.cod_simp by auto
- also have "... = A2_B.Fun (G (A1.cod f1))"
+ have "A2_B.Cod (\<tau> f1) = A2_B.Map (A2_B.cod (\<tau> f1))"
+ using f1 A2_B.ide_char A2_B.Map_cod A2_B.cod_char by auto
+ also have "... = A2_B.Map (G (A1.cod f1))"
using f1 by simp
also have "... = (\<lambda>f2. uncurry G (A1.cod f1, f2))"
proof
fix f2
- interpret G_cod_f1: "functor" A2 B "A2_B.Fun (G (A1.cod f1))"
+ interpret G_cod_f1: "functor" A2 B \<open>A2_B.Map (G (A1.cod f1))\<close>
using f1 A2_B.ide_char G.preserves_ide by simp
- show "A2_B.Fun (G (A1.cod f1)) f2 = uncurry G (A1.cod f1, f2)"
+ show "A2_B.Map (G (A1.cod f1)) f2 = uncurry G (A1.cod f1, f2)"
using f1 uncurry_def E.map_simp G_cod_f1.is_extensional by auto
qed
finally show ?thesis by auto
qed
- moreover have "A2_B.Fun (\<tau> f1) = (\<lambda>f2. E.map (\<tau> f1, f2))"
+ moreover have "A2_B.Map (\<tau> f1) = (\<lambda>f2. E.map (\<tau> f1, f2))"
proof
fix f2
- have "\<not>A2.arr f2 \<Longrightarrow> A2_B.Fun (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
- using f1 E.is_extensional A2_B.arr_char \<tau>.preserves_reflects_arr
- natural_transformation.is_extensional E.map_def
- by (metis (no_types, lifting) prod.sel(1) prod.sel(2))
- moreover have "A2.arr f2 \<Longrightarrow> A2_B.Fun (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
+ have "\<not>A2.arr f2 \<Longrightarrow> A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
+ using f1 A2_B.arrE \<tau>.preserves_reflects_arr natural_transformation.is_extensional
+ by (metis (no_types, lifting) E.fixing_arr_gives_natural_transformation_1)
+ moreover have "A2.arr f2 \<Longrightarrow> A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
using f1 E.map_simp by fastforce
- ultimately show "A2_B.Fun (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2" by blast
+ ultimately show "A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2" by blast
qed
ultimately show ?thesis
- using A2_B.mkArr_Fun f1 \<tau>.preserves_reflects_arr by metis
+ using f1 A2_B.MkArr_Map \<tau>.preserves_reflects_arr by metis
qed
finally show ?thesis by auto
qed
ultimately show "curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1" by blast
qed
end
locale curried_functor =
currying A1 A2 B +
A1xA2: product_category A1 A2 +
A2_B: functor_category A2 B +
F: binary_functor A1 A2 B F
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a1 * 'a2 \<Rightarrow> 'b"
begin
notation A1xA2.comp (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
notation A2_B.comp (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>]" 55)
notation A1xA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
notation A2_B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
definition map
where "map \<equiv> curry F F F"
lemma map_simp [simp]:
assumes "A1.arr f1"
shows "map f1 =
- A2_B.mkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2)) (\<lambda>f2. F (f1, f2))"
+ A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2)) (\<lambda>f2. F (f1, f2))"
using assms map_def curry_simp by auto
lemma is_functor:
shows "functor A1 A2_B.comp map"
using F.functor_axioms map_def curry_preserves_functors by simp
end
sublocale curried_functor \<subseteq> "functor" A1 A2_B.comp map
using is_functor by auto
locale curried_functor' =
A1: category A1 +
A2: category A2 +
A1xA2: product_category A1 A2 +
currying A2 A1 B +
F: binary_functor A1 A2 B F +
A1_B: functor_category A1 B
for A1 :: "'a1 comp" (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
and A2 :: "'a2 comp" (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a1 * 'a2 \<Rightarrow> 'b"
begin
notation A1xA2.comp (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
notation A1_B.comp (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>1,\<^sub>B\<^sub>]" 55)
notation A1xA2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
notation A1_B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>1\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
definition map
where "map \<equiv> curry F.sym F.sym F.sym"
lemma map_simp [simp]:
assumes "A2.arr f2"
shows "map f2 =
- A1_B.mkArr (\<lambda>f1. F (f1, A2.dom f2)) (\<lambda>f1. F (f1, A2.cod f2)) (\<lambda>f1. F (f1, f2))"
+ A1_B.MkArr (\<lambda>f1. F (f1, A2.dom f2)) (\<lambda>f1. F (f1, A2.cod f2)) (\<lambda>f1. F (f1, f2))"
using assms map_def curry_simp by simp
lemma is_functor:
shows "functor A2 A1_B.comp map"
proof -
interpret A2xA1: product_category A2 A1 ..
interpret F': binary_functor A2 A1 B F.sym
using F.sym_is_binary_functor by simp
have "functor A2xA1.comp B F.sym" ..
thus ?thesis using map_def curry_preserves_functors by simp
qed
end
sublocale curried_functor' \<subseteq> "functor" A2 A1_B.comp map
using is_functor by auto
end
diff --git a/thys/Category3/InitialTerminal.thy b/thys/Category3/InitialTerminal.thy
--- a/thys/Category3/InitialTerminal.thy
+++ b/thys/Category3/InitialTerminal.thy
@@ -1,110 +1,110 @@
(* Title: InitialTerminal
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter InitialTerminal
theory InitialTerminal
imports EpiMonoIso
begin
text\<open>
This theory defines the notions of initial and terminal object in a category
and establishes some properties of these notions, including that when they exist
they are unique up to isomorphism.
\<close>
context category
begin
definition initial
where "initial a \<equiv> ide a \<and> (\<forall>b. ide b \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>))"
definition terminal
where "terminal b \<equiv> ide b \<and> (\<forall>a. ide a \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>))"
abbreviation initial_arr
where "initial_arr f \<equiv> arr f \<and> initial (dom f)"
abbreviation terminal_arr
where "terminal_arr f \<equiv> arr f \<and> terminal (cod f)"
abbreviation point
where "point f \<equiv> arr f \<and> terminal (dom f)"
lemma initial_arr_unique:
assumes "par f f'" and "initial_arr f" and "initial_arr f'"
shows "f = f'"
using assms in_homI initial_def ide_cod by blast
lemma initialI [intro]:
assumes "ide a" and "\<And>b. ide b \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
shows "initial a"
using assms initial_def by auto
lemma initialE [elim]:
assumes "initial a" and "ide b"
obtains f where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<And>f'. \<guillemotleft>f' : a \<rightarrow> b\<guillemotright> \<Longrightarrow> f' = f"
using assms initial_def initial_arr_unique by meson
lemma terminal_arr_unique:
assumes "par f f'" and "terminal_arr f" and "terminal_arr f'"
shows "f = f'"
using assms in_homI terminal_def ide_dom by blast
lemma terminalI [intro]:
assumes "ide b" and "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
shows "terminal b"
using assms terminal_def by auto
lemma terminalE [elim]:
assumes "terminal b" and "ide a"
obtains f where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<And>f'. \<guillemotleft>f' : a \<rightarrow> b\<guillemotright> \<Longrightarrow> f' = f"
using assms terminal_def terminal_arr_unique by meson
theorem terminal_objs_isomorphic:
assumes "terminal a" and "terminal b"
shows "isomorphic a b"
proof -
from assms obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
using terminal_def by meson
from assms obtain g where g: "\<guillemotleft>g : b \<rightarrow> a\<guillemotright>"
using terminal_def by meson
have "iso f"
using assms f g
- by (metis (no_types, lifting) iso_iff_section_and_retraction retractionI sectionI
- terminal_def comp_in_homI ide_in_hom)
+ by (metis arr_iff_in_hom cod_comp retractionI sectionI seqI' terminal_def
+ dom_comp in_homE iso_iff_section_and_retraction ide_in_hom)
thus ?thesis using f by auto
qed
theorem initial_objs_isomorphic:
assumes "initial a" and "initial b"
shows "isomorphic a b"
proof -
from assms obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" using initial_def by auto
from assms obtain g where g: "\<guillemotleft>g : b \<rightarrow> a\<guillemotright>" using initial_def by auto
have "iso f"
using assms f g
- by (metis iso_iff_section_and_retraction retractionI sectionI
- initial_def comp_in_homI ide_in_hom)
+ by (metis (no_types, lifting) arr_iff_in_hom cod_comp in_homE initial_def
+ retractionI sectionI dom_comp iso_iff_section_and_retraction ide_in_hom seqI')
thus ?thesis
using f by auto
qed
lemma point_is_mono:
assumes "point f"
shows "mono f"
proof -
have "ide (cod f)" using assms by auto
from this obtain t where t: "\<guillemotleft>t: cod f \<rightarrow> dom f\<guillemotright>"
using assms terminal_def by blast
thus ?thesis
using assms terminal_def monoI
by (metis seqE in_homI dom_comp ide_dom terminal_def)
qed
end
end
diff --git a/thys/Category3/Limit.thy b/thys/Category3/Limit.thy
--- a/thys/Category3/Limit.thy
+++ b/thys/Category3/Limit.thy
@@ -1,6143 +1,6171 @@
(* Title: Limit
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter Limit
theory Limit
imports FreeCategory DiscreteCategory Adjunction
begin
text\<open>
This theory defines the notion of limit in terms of diagrams and cones and relates
it to the concept of a representation of a functor. The diagonal functor associated
with a diagram shape @{term J} is defined and it is shown that a right adjoint to
the diagonal functor gives limits of shape @{term J} and that a category has limits
of shape @{term J} if and only if the diagonal functor is a left adjoint functor.
Products and equalizers are defined as special cases of limits, and it is shown
that a category with equalizers has limits of shape @{term J} if it has products
indexed by the sets of objects and arrows of @{term J}.
The existence of limits in a set category is investigated, and it is shown that
every set category has equalizers and that a set category @{term S} has @{term I}-indexed
products if and only if the universe of @{term S} ``admits @{term I}-indexed tupling.''
The existence of limits in functor categories is also developed, showing that
limits in functor categories are ``determined pointwise'' and that a functor category
@{term "[A, B]"} has limits of shape @{term J} if @{term B} does.
Finally, it is shown that the Yoneda functor preserves limits.
This theory concerns itself only with limits; I have made no attempt to consider colimits.
Although it would be possible to rework the entire development in dual form,
it is possible that there is a more efficient way to dualize at least parts of it without
repeating all the work. This is something that deserves further thought.
\<close>
section "Representations of Functors"
text\<open>
A representation of a contravariant functor \<open>F: Cop \<rightarrow> S\<close>, where @{term S}
is a set category that is the target of a hom-functor for @{term C}, consists of
an object @{term a} of @{term C} and a natural isomorphism @{term "\<Phi>: Y a \<rightarrow> F"},
where \<open>Y: C \<rightarrow> [Cop, S]\<close> is the Yoneda functor.
\<close>
locale representation_of_functor =
C: category C +
Cop: dual_category C +
S: set_category S +
F: "functor" Cop.comp S F +
Hom: hom_functor C S \<phi> +
Ya: yoneda_functor_fixed_object C S \<phi> a +
- natural_isomorphism Cop.comp S "Ya.Y a" F \<Phi>
+ natural_isomorphism Cop.comp S \<open>Ya.Y a\<close> F \<Phi>
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and F :: "'c \<Rightarrow> 's"
and a :: 'c
and \<Phi> :: "'c \<Rightarrow> 's"
begin
abbreviation Y where "Y \<equiv> Ya.Y"
abbreviation \<psi> where "\<psi> \<equiv> Hom.\<psi>"
end
text\<open>
Two representations of the same functor are uniquely isomorphic.
\<close>
locale two_representations_one_functor =
C: category C +
Cop: dual_category C +
S: set_category S +
F: set_valued_functor Cop.comp S F +
yoneda_functor C S \<phi> +
Ya: yoneda_functor_fixed_object C S \<phi> a +
Ya': yoneda_functor_fixed_object C S \<phi> a' +
\<Phi>: representation_of_functor C S \<phi> F a \<Phi> +
\<Phi>': representation_of_functor C S \<phi> F a' \<Phi>'
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and F :: "'c \<Rightarrow> 's"
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and a :: 'c
and \<Phi> :: "'c \<Rightarrow> 's"
and a' :: 'c
and \<Phi>' :: "'c \<Rightarrow> 's"
begin
- interpretation \<Psi>: inverse_transformation Cop.comp S "Y a" F \<Phi> ..
- interpretation \<Psi>': inverse_transformation Cop.comp S "Y a'" F \<Phi>' ..
- interpretation \<Phi>\<Psi>': vertical_composite Cop.comp S "Y a" F "Y a'" \<Phi> \<Psi>'.map ..
- interpretation \<Phi>'\<Psi>: vertical_composite Cop.comp S "Y a'" F "Y a" \<Phi>' \<Psi>.map ..
+ interpretation \<Psi>: inverse_transformation Cop.comp S \<open>Y a\<close> F \<Phi> ..
+ interpretation \<Psi>': inverse_transformation Cop.comp S \<open>Y a'\<close> F \<Phi>' ..
+ interpretation \<Phi>\<Psi>': vertical_composite Cop.comp S \<open>Y a\<close> F \<open>Y a'\<close> \<Phi> \<Psi>'.map ..
+ interpretation \<Phi>'\<Psi>: vertical_composite Cop.comp S \<open>Y a'\<close> F \<open>Y a\<close> \<Phi>' \<Psi>.map ..
lemma are_uniquely_isomorphic:
- shows "\<exists>!\<phi>. \<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> C.iso \<phi> \<and> map \<phi> = Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
+ shows "\<exists>!\<phi>. \<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> C.iso \<phi> \<and> map \<phi> = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
proof -
have "natural_isomorphism Cop.comp S (Y a) F \<Phi>" ..
moreover have "natural_isomorphism Cop.comp S F (Y a') \<Psi>'.map" ..
ultimately have 1: "natural_isomorphism Cop.comp S (Y a) (Y a') \<Phi>\<Psi>'.map"
using NaturalTransformation.natural_isomorphisms_compose by blast
- interpret \<Phi>\<Psi>': natural_isomorphism Cop.comp S "Y a" "Y a'" \<Phi>\<Psi>'.map
+ interpret \<Phi>\<Psi>': natural_isomorphism Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<Phi>\<Psi>'.map
using 1 by auto
have "natural_isomorphism Cop.comp S (Y a') F \<Phi>'" ..
moreover have "natural_isomorphism Cop.comp S F (Y a) \<Psi>.map" ..
ultimately have 2: "natural_isomorphism Cop.comp S (Y a') (Y a) \<Phi>'\<Psi>.map"
using NaturalTransformation.natural_isomorphisms_compose by blast
- interpret \<Phi>'\<Psi>: natural_isomorphism Cop.comp S "Y a'" "Y a" \<Phi>'\<Psi>.map
+ interpret \<Phi>'\<Psi>: natural_isomorphism Cop.comp S \<open>Y a'\<close> \<open>Y a\<close> \<Phi>'\<Psi>.map
using 2 by auto
- interpret \<Phi>\<Psi>'_\<Phi>'\<Psi>: inverse_transformations Cop.comp S "Y a" "Y a'" \<Phi>\<Psi>'.map \<Phi>'\<Psi>.map
+ interpret \<Phi>\<Psi>'_\<Phi>'\<Psi>: inverse_transformations Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<Phi>\<Psi>'.map \<Phi>'\<Psi>.map
proof
fix x
assume X: "Cop.ide x"
show "S.inverse_arrows (\<Phi>\<Psi>'.map x) (\<Phi>'\<Psi>.map x)"
proof
have 1: "S.arr (\<Phi>\<Psi>'.map x) \<and> \<Phi>\<Psi>'.map x = \<Psi>'.map x \<cdot>\<^sub>S \<Phi> x"
using X \<Phi>\<Psi>'.preserves_reflects_arr [of x]
by (simp add: \<Phi>\<Psi>'.map_simp_2)
have 2: "S.arr (\<Phi>'\<Psi>.map x) \<and> \<Phi>'\<Psi>.map x = \<Psi>.map x \<cdot>\<^sub>S \<Phi>' x"
using X \<Phi>'\<Psi>.preserves_reflects_arr [of x]
by (simp add: \<Phi>'\<Psi>.map_simp_1)
show "S.ide (\<Phi>\<Psi>'.map x \<cdot>\<^sub>S \<Phi>'\<Psi>.map x)"
using 1 2 X \<Psi>.is_natural_2 \<Psi>'.inverts_components \<Psi>.inverts_components
by (metis S.inverse_arrows_def S.inverse_arrows_compose)
show "S.ide (\<Phi>'\<Psi>.map x \<cdot>\<^sub>S \<Phi>\<Psi>'.map x)"
using 1 2 X \<Psi>'.inverts_components \<Psi>.inverts_components
by (metis S.inverse_arrows_def S.inverse_arrows_compose)
qed
qed
- have "Cop_S.inverse_arrows (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
- (Cop_S.mkArr (Y a') (Y a) \<Phi>'\<Psi>.map)"
+ have "Cop_S.inverse_arrows (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
+ (Cop_S.MkArr (Y a') (Y a) \<Phi>'\<Psi>.map)"
proof -
have Ya: "functor Cop.comp S (Y a)" ..
have Ya': "functor Cop.comp S (Y a')" ..
have \<Phi>\<Psi>': "natural_transformation Cop.comp S (Y a) (Y a') \<Phi>\<Psi>'.map" ..
have \<Phi>'\<Psi>: "natural_transformation Cop.comp S (Y a') (Y a) \<Phi>'\<Psi>.map" ..
show ?thesis
proof (intro Cop_S.inverse_arrowsI)
have 0: "inverse_transformations Cop.comp S (Y a) (Y a') \<Phi>\<Psi>'.map \<Phi>'\<Psi>.map" ..
- have 1: "Cop_S.antipar (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
- (Cop_S.mkArr (Y a') (Y a) \<Phi>'\<Psi>.map)"
- using Ya Ya' \<Phi>\<Psi>' \<Phi>'\<Psi> Cop_S.dom_simp Cop_S.cod_simp Cop_S.seqI
- Cop_S.Cod_mkArr Cop_S.Dom_mkArr Cop_S.arr_mkArr
+ have 1: "Cop_S.antipar (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
+ (Cop_S.MkArr (Y a') (Y a) \<Phi>'\<Psi>.map)"
+ using Ya Ya' \<Phi>\<Psi>' \<Phi>'\<Psi> Cop_S.dom_char Cop_S.cod_char Cop_S.seqI
+ Cop_S.arr_MkArr Cop_S.cod_MkArr Cop_S.dom_MkArr
by presburger
- show "Cop_S.ide (Cop_S.comp (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
- (Cop_S.mkArr (Y a') (Y a) \<Phi>'\<Psi>.map))"
- using 0 1 NaturalTransformation.inverse_transformations_inverse(2) Cop_S.comp_mkArr
- by (metis Cop_S.ide_mkIde Cop_S.seqE Ya'.functor_axioms)
- show "Cop_S.ide (Cop_S.comp (Cop_S.mkArr (Y a') (Y a) \<Phi>'\<Psi>.map)
- (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map))"
- using 0 1 NaturalTransformation.inverse_transformations_inverse(1) Cop_S.comp_mkArr
- by (metis Cop_S.ide_mkIde Cop_S.seqE Ya.functor_axioms)
+ show "Cop_S.ide (Cop_S.comp (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
+ (Cop_S.MkArr (Y a') (Y a) \<Phi>'\<Psi>.map))"
+ using 0 1 NaturalTransformation.inverse_transformations_inverse(2) Cop_S.comp_MkArr
+ by (metis Cop_S.cod_MkArr Cop_S.ide_char' Cop_S.seqE)
+ show "Cop_S.ide (Cop_S.comp (Cop_S.MkArr (Y a') (Y a) \<Phi>'\<Psi>.map)
+ (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map))"
+ using 0 1 NaturalTransformation.inverse_transformations_inverse(1) Cop_S.comp_MkArr
+ by (metis Cop_S.cod_MkArr Cop_S.ide_char' Cop_S.seqE)
qed
qed
- hence 3: "Cop_S.iso (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map)" using Cop_S.isoI by blast
- hence "Cop_S.arr (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map)" using Cop_S.iso_is_arr by blast
- hence "Cop_S.in_hom (Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map) (map a) (map a')"
- using Ya.ide_a Ya'.ide_a Cop_S.dom_simp Cop_S.cod_simp by auto
- hence "\<exists>f. \<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> map f = Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
+ hence 3: "Cop_S.iso (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)" using Cop_S.isoI by blast
+ hence "Cop_S.arr (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)" using Cop_S.iso_is_arr by blast
+ hence "Cop_S.in_hom (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map) (map a) (map a')"
+ using Ya.ide_a Ya'.ide_a Cop_S.dom_char Cop_S.cod_char by auto
+ hence "\<exists>f. \<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> map f = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
using Ya.ide_a Ya'.ide_a is_full Y_def Cop_S.iso_is_arr full_functor.is_full
by auto
from this obtain \<phi>
- where \<phi>: "\<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> map \<phi> = Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
+ where \<phi>: "\<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> map \<phi> = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
by blast
from \<phi> have "C.iso \<phi>"
using 3 reflects_iso [of \<phi> a a'] by simp
- hence EX: "\<exists>\<phi>. \<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> C.iso \<phi> \<and> map \<phi> = Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
+ hence EX: "\<exists>\<phi>. \<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> C.iso \<phi> \<and> map \<phi> = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
using \<phi> by blast
have
- UN: "\<And>\<phi>'. \<guillemotleft>\<phi>' : a \<rightarrow> a'\<guillemotright> \<and> map \<phi>' = Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map \<Longrightarrow> \<phi>' = \<phi>"
+ UN: "\<And>\<phi>'. \<guillemotleft>\<phi>' : a \<rightarrow> a'\<guillemotright> \<and> map \<phi>' = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map \<Longrightarrow> \<phi>' = \<phi>"
proof -
fix \<phi>'
- assume \<phi>': "\<guillemotleft>\<phi>' : a \<rightarrow> a'\<guillemotright> \<and> map \<phi>' = Cop_S.mkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
+ assume \<phi>': "\<guillemotleft>\<phi>' : a \<rightarrow> a'\<guillemotright> \<and> map \<phi>' = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
have "C.par \<phi> \<phi>' \<and> map \<phi> = map \<phi>'" using \<phi> \<phi>' by auto
thus "\<phi>' = \<phi>" using is_faithful by fast
qed
from EX UN show ?thesis by auto
qed
end
section "Diagrams and Cones"
text\<open>
A \emph{diagram} in a category @{term C} is a functor \<open>D: J \<rightarrow> C\<close>.
We refer to the category @{term J} as the diagram \emph{shape}.
Note that in the usual expositions of category theory that use set theory
as their foundations, the shape @{term J} of a diagram is required to be
a ``small'' category, where smallness means that the collection of objects
of @{term J}, as well as each of the ``homs,'' is a set.
However, in HOL there is no class of all sets, so it is not meaningful
to speak of @{term J} as ``small'' in any kind of absolute sense.
There is likely a meaningful notion of smallness of @{term J}
\emph{relative to} @{term C} (the result below that states that a set
category has @{term I}-indexed products if and only if its universe
``admits @{term I}-indexed tuples'' is suggestive of how this might
be defined), but I haven't fully explored this idea at present.
\<close>
locale diagram =
C: category C +
J: category J +
"functor" J C D
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
begin
notation J.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J _\<guillemotright>")
end
lemma comp_diagram_functor:
assumes "diagram J C D" and "functor J' J F"
shows "diagram J' C (D o F)"
by (meson assms(1) assms(2) diagram_def functor.axioms(1) functor_comp)
text\<open>
A \emph{cone} over a diagram \<open>D: J \<rightarrow> C\<close> is a natural transformation
from a constant functor to @{term D}. The value of the constant functor is
the \emph{apex} of the cone.
\<close>
locale cone =
C: category C +
J: category J +
D: diagram J C D +
A: constant_functor J C a +
natural_transformation J C A.map D \<chi>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
and a :: 'c
and \<chi> :: "'j \<Rightarrow> 'c"
begin
lemma ide_apex:
shows "C.ide a"
using A.value_is_ide by auto
lemma component_in_hom:
assumes "J.arr j"
shows "\<guillemotleft>\<chi> j : a \<rightarrow> D (J.cod j)\<guillemotright>"
using assms by auto
end
text\<open>
A cone over diagram @{term D} is transformed into a cone over diagram @{term "D o F"}
by pre-composing with @{term F}.
\<close>
lemma comp_cone_functor:
assumes "cone J C D a \<chi>" and "functor J' J F"
shows "cone J' C (D o F) a (\<chi> o F)"
proof -
interpret \<chi>: cone J C D a \<chi> using assms(1) by auto
interpret F: "functor" J' J F using assms(2) by auto
interpret A': constant_functor J' C a
apply unfold_locales using \<chi>.A.value_is_ide by auto
have 1: "\<chi>.A.map o F = A'.map"
using \<chi>.A.map_def A'.map_def \<chi>.J.not_arr_null by auto
- interpret \<chi>': horizontal_composite J' J C F F \<chi>.A.map D F \<chi> ..
- interpret \<chi>': natural_transformation J' C A'.map "D o F" "\<chi> o F"
- using 1 \<chi>'.natural_transformation_axioms by auto
+ interpret \<chi>': natural_transformation J' C A'.map \<open>D o F\<close> \<open>\<chi> o F\<close>
+ using 1 horizontal_composite F.natural_transformation_axioms
+ \<chi>.natural_transformation_axioms
+ by fastforce
show "cone J' C (D o F) a (\<chi> o F)" ..
qed
text\<open>
A cone over diagram @{term D} can be transformed into a cone over a diagram @{term D'}
by post-composing with a natural transformation from @{term D} to @{term D'}.
\<close>
lemma vcomp_transformation_cone:
assumes "cone J C D a \<chi>"
and "natural_transformation J C D D' \<tau>"
shows "cone J C D' a (vertical_composite.map J C \<chi> \<tau>)"
proof -
interpret \<chi>: cone J C D a \<chi> using assms(1) by auto
interpret \<tau>: natural_transformation J C D D' \<tau> using assms(2) by auto
interpret \<tau>o\<chi>: vertical_composite J C \<chi>.A.map D D' \<chi> \<tau> ..
interpret \<tau>o\<chi>: cone J C D' a \<tau>o\<chi>.map ..
show ?thesis ..
qed
context "functor"
begin
lemma preserves_diagrams:
fixes J :: "'j comp"
assumes "diagram J A D"
shows "diagram J B (F o D)"
proof -
interpret D: diagram J A D using assms by auto
interpret FoD: composite_functor J A B D F ..
show "diagram J B (F o D)" ..
qed
lemma preserves_cones:
fixes J :: "'j comp"
assumes "cone J A D a \<chi>"
shows "cone J B (F o D) (F a) (F o \<chi>)"
proof -
interpret \<chi>: cone J A D a \<chi> using assms by auto
- interpret Fa: constant_functor J B "F a"
+ interpret Fa: constant_functor J B \<open>F a\<close>
apply unfold_locales using \<chi>.ide_apex by auto
- interpret \<chi>': horizontal_composite J A B \<chi>.A.map D F F \<chi> F ..
have 1: "F o \<chi>.A.map = Fa.map"
proof
fix f
show "(F \<circ> \<chi>.A.map) f = Fa.map f"
using is_extensional Fa.is_extensional \<chi>.A.is_extensional
by (cases "\<chi>.J.arr f", simp_all)
qed
- interpret \<chi>': natural_transformation J B Fa.map "F o D" "F o \<chi>"
- using 1 \<chi>'.natural_transformation_axioms by auto
+ interpret \<chi>': natural_transformation J B Fa.map \<open>F o D\<close> \<open>F o \<chi>\<close>
+ using 1 horizontal_composite \<chi>.natural_transformation_axioms
+ natural_transformation_axioms
+ by fastforce
show "cone J B (F o D) (F a) (F o \<chi>)" ..
qed
end
context diagram
begin
abbreviation cone
where "cone a \<chi> \<equiv> Limit.cone J C D a \<chi>"
abbreviation cones :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) set"
where "cones a \<equiv> { \<chi>. cone a \<chi> }"
text\<open>
An arrow @{term "f \<in> C.hom a' a"} induces by composition a transformation from
cones with apex @{term a} to cones with apex @{term a'}. This transformation
is functorial in @{term f}.
\<close>
abbreviation cones_map :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) \<Rightarrow> ('j \<Rightarrow> 'c)"
where "cones_map f \<equiv> (\<lambda>\<chi> \<in> cones (C.cod f). \<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null)"
lemma cones_map_mapsto:
assumes "C.arr f"
shows "cones_map f \<in>
extensional (cones (C.cod f)) \<inter> (cones (C.cod f) \<rightarrow> cones (C.dom f))"
proof
show "cones_map f \<in> extensional (cones (C.cod f))" by blast
show "cones_map f \<in> cones (C.cod f) \<rightarrow> cones (C.dom f)"
proof
fix \<chi>
assume "\<chi> \<in> cones (C.cod f)"
hence \<chi>: "cone (C.cod f) \<chi>" by auto
- interpret \<chi>: cone J C D "C.cod f" \<chi> using \<chi> by auto
- interpret B: constant_functor J C "C.dom f"
+ interpret \<chi>: cone J C D \<open>C.cod f\<close> \<chi> using \<chi> by auto
+ interpret B: constant_functor J C \<open>C.dom f\<close>
apply unfold_locales using assms by auto
have "cone (C.dom f) (\<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null)"
using assms B.value_is_ide \<chi>.is_natural_1 \<chi>.is_natural_2
apply (unfold_locales, auto)
using \<chi>.is_natural_1
apply (metis C.comp_assoc)
using \<chi>.is_natural_2 C.comp_arr_dom
by (metis J.arr_cod_iff_arr J.cod_cod C.comp_assoc)
thus "(\<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null) \<in> cones (C.dom f)" by auto
qed
qed
lemma cones_map_ide:
assumes "\<chi> \<in> cones a"
shows "cones_map a \<chi> = \<chi>"
proof -
interpret \<chi>: cone J C D a \<chi> using assms by auto
show ?thesis
proof
fix j
show "cones_map a \<chi> j = \<chi> j"
using assms \<chi>.A.value_is_ide \<chi>.preserves_hom C.comp_arr_dom \<chi>.is_extensional
by (cases "J.arr j", auto)
qed
qed
lemma cones_map_comp:
assumes "C.seq f g"
shows "cones_map (f \<cdot> g) = restrict (cones_map g o cones_map f) (cones (C.cod f))"
proof (intro restr_eqI)
show "cones (C.cod (f \<cdot> g)) = cones (C.cod f)" using assms by simp
show "\<And>\<chi>. \<chi> \<in> cones (C.cod (f \<cdot> g)) \<Longrightarrow>
(\<lambda>j. if J.arr j then \<chi> j \<cdot> f \<cdot> g else C.null) = (cones_map g o cones_map f) \<chi>"
proof -
fix \<chi>
assume \<chi>: "\<chi> \<in> cones (C.cod (f \<cdot> g))"
show "(\<lambda>j. if J.arr j then \<chi> j \<cdot> f \<cdot> g else C.null) = (cones_map g o cones_map f) \<chi>"
proof -
have "((cones_map g) o (cones_map f)) \<chi> = cones_map g (cones_map f \<chi>)"
by force
also have "... = (\<lambda>j. if J.arr j then
(\<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null) j \<cdot> g else C.null)"
proof
fix j
have "cone (C.dom f) (cones_map f \<chi>)"
using assms \<chi> cones_map_mapsto by (elim C.seqE, force)
thus "cones_map g (cones_map f \<chi>) j =
(if J.arr j then C (if J.arr j then \<chi> j \<cdot> f else C.null) g else C.null)"
using \<chi> assms by auto
qed
also have "... = (\<lambda>j. if J.arr j then \<chi> j \<cdot> f \<cdot> g else C.null)"
proof -
have "\<And>j. J.arr j \<Longrightarrow> (\<chi> j \<cdot> f) \<cdot> g = \<chi> j \<cdot> f \<cdot> g"
proof -
- interpret \<chi>: cone J C D "C.cod f" \<chi> using assms \<chi> by auto
+ interpret \<chi>: cone J C D \<open>C.cod f\<close> \<chi> using assms \<chi> by auto
fix j
assume j: "J.arr j"
show "(\<chi> j \<cdot> f) \<cdot> g = \<chi> j \<cdot> f \<cdot> g"
using assms C.comp_assoc by simp
qed
thus ?thesis by auto
qed
finally show ?thesis by auto
qed
qed
qed
end
text\<open>
Changing the apex of a cone by pre-composing with an arrow @{term f} commutes
with changing the diagram of a cone by post-composing with a natural transformation.
\<close>
lemma cones_map_vcomp:
assumes "diagram J C D" and "diagram J C D'"
and "natural_transformation J C D D' \<tau>"
and "cone J C D a \<chi>"
and f: "partial_magma.in_hom C f a' a"
shows "diagram.cones_map J C D' f (vertical_composite.map J C \<chi> \<tau>)
= vertical_composite.map J C (diagram.cones_map J C D f \<chi>) \<tau>"
proof -
interpret D: diagram J C D using assms(1) by auto
interpret D': diagram J C D' using assms(2) by auto
interpret \<tau>: natural_transformation J C D D' \<tau> using assms(3) by auto
interpret \<chi>: cone J C D a \<chi> using assms(4) by auto
interpret \<tau>o\<chi>: vertical_composite J C \<chi>.A.map D D' \<chi> \<tau> ..
interpret \<tau>o\<chi>: cone J C D' a \<tau>o\<chi>.map ..
- interpret \<chi>f: cone J C D a' "D.cones_map f \<chi>"
+ interpret \<chi>f: cone J C D a' \<open>D.cones_map f \<chi>\<close>
using f \<chi>.cone_axioms D.cones_map_mapsto by blast
- interpret \<tau>o\<chi>f: vertical_composite J C \<chi>f.A.map D D' "D.cones_map f \<chi>" \<tau> ..
- interpret \<tau>o\<chi>_f: cone J C D' a' "D'.cones_map f \<tau>o\<chi>.map"
+ interpret \<tau>o\<chi>f: vertical_composite J C \<chi>f.A.map D D' \<open>D.cones_map f \<chi>\<close> \<tau> ..
+ interpret \<tau>o\<chi>_f: cone J C D' a' \<open>D'.cones_map f \<tau>o\<chi>.map\<close>
using f \<tau>o\<chi>.cone_axioms D'.cones_map_mapsto [of f] by blast
write C (infixr "\<cdot>" 55)
show "D'.cones_map f \<tau>o\<chi>.map = \<tau>o\<chi>f.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J C \<chi>f.A.map D' (D'.cones_map f \<tau>o\<chi>.map)" ..
show "natural_transformation J C \<chi>f.A.map D' \<tau>o\<chi>f.map" ..
show "\<And>j. D.J.ide j \<Longrightarrow> D'.cones_map f \<tau>o\<chi>.map j = \<tau>o\<chi>f.map j"
proof -
fix j
assume j: "D.J.ide j"
have "D'.cones_map f \<tau>o\<chi>.map j = \<tau>o\<chi>.map j \<cdot> f"
using f \<tau>o\<chi>.cone_axioms \<tau>o\<chi>.map_simp_2 \<tau>o\<chi>.is_extensional by auto
also have "... = (\<tau> j \<cdot> \<chi> (D.J.dom j)) \<cdot> f"
using j \<tau>o\<chi>.map_simp_2 by simp
also have "... = \<tau> j \<cdot> \<chi> (D.J.dom j) \<cdot> f"
using D.C.comp_assoc by simp
also have "... = \<tau>o\<chi>f.map j"
using j f \<chi>.cone_axioms \<tau>o\<chi>f.map_simp_2 by auto
finally show "D'.cones_map f \<tau>o\<chi>.map j = \<tau>o\<chi>f.map j" by auto
qed
qed
qed
text\<open>
Given a diagram @{term D}, we can construct a contravariant set-valued functor,
which takes each object @{term a} of @{term C} to the set of cones over @{term D}
with apex @{term a}, and takes each arrow @{term f} of @{term C} to the function
on cones over @{term D} induced by pre-composition with @{term f}.
For this, we need to introduce a set category @{term S} whose universe is large
enough to contain all the cones over @{term D}, and we need to have an explicit
correspondence between cones and elements of the universe of @{term S}.
A set category @{term S} equipped with an injective mapping
@{term_type "\<iota> :: ('j => 'c) => 's"} serves this purpose.
\<close>
locale cones_functor =
C: category C +
Cop: dual_category C +
J: category J +
D: diagram J C D +
S: concrete_set_category S UNIV \<iota>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<iota> :: "('j \<Rightarrow> 'c) \<Rightarrow> 's"
begin
notation S.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
abbreviation \<o> where "\<o> \<equiv> S.\<o>"
definition map :: "'c \<Rightarrow> 's"
where "map = (\<lambda>f. if C.arr f then
S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom f))
(\<iota> o D.cones_map f o \<o>)
else S.null)"
lemma map_simp [simp]:
assumes "C.arr f"
- shows
- "map f = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom f)) (\<iota> o D.cones_map f o \<o>)"
+ shows "map f = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom f))
+ (\<iota> o D.cones_map f o \<o>)"
using assms map_def by auto
lemma arr_map:
assumes "C.arr f"
shows "S.arr (map f)"
proof -
have "\<iota> o D.cones_map f o \<o> \<in> \<iota> ` D.cones (C.cod f) \<rightarrow> \<iota> ` D.cones (C.dom f)"
using assms D.cones_map_mapsto by force
thus ?thesis using assms S.\<iota>_mapsto by auto
qed
lemma map_ide:
assumes "C.ide a"
shows "map a = S.mkIde (\<iota> ` D.cones a)"
proof -
have "map a = S.mkArr (\<iota> ` D.cones a) (\<iota> ` D.cones a) (\<iota> o D.cones_map a o \<o>)"
using assms map_simp by force
also have "... = S.mkArr (\<iota> ` D.cones a) (\<iota> ` D.cones a) (\<lambda>x. x)"
using S.\<iota>_mapsto D.cones_map_ide by force
also have "... = S.mkIde (\<iota> ` D.cones a)"
using assms S.mkIde_as_mkArr S.\<iota>_mapsto by blast
finally show ?thesis by auto
qed
lemma map_preserves_dom:
assumes "Cop.arr f"
shows "map (Cop.dom f) = S.dom (map f)"
using assms arr_map map_ide by auto
lemma map_preserves_cod:
assumes "Cop.arr f"
shows "map (Cop.cod f) = S.cod (map f)"
using assms arr_map map_ide by auto
lemma map_preserves_comp:
assumes "Cop.seq g f"
shows "map (g \<cdot>\<^sup>o\<^sup>p f) = map g \<cdot>\<^sub>S map f"
proof -
have 0: "S.seq (map g) (map f)"
using assms arr_map [of f] arr_map [of g] map_simp
by (intro S.seqI, auto)
have "map (g \<cdot>\<^sup>o\<^sup>p f) = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom g))
((\<iota> o D.cones_map g o \<o>) o (\<iota> o D.cones_map f o \<o>))"
proof -
have 1: "S.arr (map (g \<cdot>\<^sup>o\<^sup>p f))"
using assms arr_map [of "C f g"] by simp
have "map (g \<cdot>\<^sup>o\<^sup>p f) = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom g))
(\<iota> o D.cones_map (C f g) o \<o>)"
using assms map_simp [of "C f g"] by simp
also have "... = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom g))
((\<iota> o D.cones_map g o \<o>) o (\<iota> o D.cones_map f o \<o>))"
using assms 1 calculation D.cones_map_mapsto D.cones_map_comp by auto
finally show ?thesis by blast
qed
also have "... = map g \<cdot>\<^sub>S map f"
using assms 0 by (elim S.seqE, auto)
finally show ?thesis by auto
qed
lemma is_functor:
shows "functor Cop.comp S map"
apply (unfold_locales)
using map_def arr_map map_preserves_dom map_preserves_cod map_preserves_comp
by auto
end
sublocale cones_functor \<subseteq> "functor" Cop.comp S map using is_functor by auto
sublocale cones_functor \<subseteq> set_valued_functor Cop.comp S map ..
section Limits
subsection "Limit Cones"
text\<open>
A \emph{limit cone} for a diagram @{term D} is a cone @{term \<chi>} over @{term D}
with the universal property that any other cone @{term \<chi>'} over the diagram @{term D}
factors uniquely through @{term \<chi>}.
\<close>
locale limit_cone =
C: category C +
J: category J +
D: diagram J C D +
cone J C D a \<chi>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
and a :: 'c
and \<chi> :: "'j \<Rightarrow> 'c" +
assumes is_universal: "cone J C D a' \<chi>' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
begin
definition induced_arrow :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) \<Rightarrow> 'c"
where "induced_arrow a' \<chi>' = (THE f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>')"
lemma induced_arrowI:
assumes \<chi>': "\<chi>' \<in> D.cones a'"
shows "\<guillemotleft>induced_arrow a' \<chi>' : a' \<rightarrow> a\<guillemotright>"
and "D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
proof -
have "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
using assms \<chi>' is_universal by simp
hence 1: "\<guillemotleft>induced_arrow a' \<chi>' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
using theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"] induced_arrow_def
by presburger
show "\<guillemotleft>induced_arrow a' \<chi>' : a' \<rightarrow> a\<guillemotright>" using 1 by simp
show "D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'" using 1 by simp
qed
lemma cones_map_induced_arrow:
shows "induced_arrow a' \<in> D.cones a' \<rightarrow> C.hom a' a"
and "\<And>\<chi>'. \<chi>' \<in> D.cones a' \<Longrightarrow> D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
using induced_arrowI by auto
lemma induced_arrow_cones_map:
assumes "C.ide a'"
shows "(\<lambda>f. D.cones_map f \<chi>) \<in> C.hom a' a \<rightarrow> D.cones a'"
and "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> induced_arrow a' (D.cones_map f \<chi>) = f"
proof -
have a': "C.ide a'" using assms by (simp add: cone.ide_apex)
have cone_\<chi>: "cone J C D a \<chi>" ..
show "(\<lambda>f. D.cones_map f \<chi>) \<in> C.hom a' a \<rightarrow> D.cones a'"
using cone_\<chi> D.cones_map_mapsto by blast
fix f
assume f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>"
show "induced_arrow a' (D.cones_map f \<chi>) = f"
proof -
have "D.cones_map f \<chi> \<in> D.cones a'"
using f cone_\<chi> D.cones_map_mapsto by blast
hence "\<exists>!f'. \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f' \<chi> = D.cones_map f \<chi>"
using assms is_universal by auto
thus ?thesis
using f induced_arrow_def
the1_equality [of "\<lambda>f'. \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f' \<chi> = D.cones_map f \<chi>"]
by presburger
qed
qed
text\<open>
For a limit cone @{term \<chi>} with apex @{term a}, for each object @{term a'} the
hom-set @{term "C.hom a' a"} is in bijective correspondence with the set of cones
with apex @{term a'}.
\<close>
lemma bij_betw_hom_and_cones:
assumes "C.ide a'"
shows "bij_betw (\<lambda>f. D.cones_map f \<chi>) (C.hom a' a) (D.cones a')"
proof (intro bij_betwI)
show "(\<lambda>f. D.cones_map f \<chi>) \<in> C.hom a' a \<rightarrow> D.cones a'"
using assms induced_arrow_cones_map by blast
show "induced_arrow a' \<in> D.cones a' \<rightarrow> C.hom a' a"
using assms cones_map_induced_arrow by blast
show "\<And>f. f \<in> C.hom a' a \<Longrightarrow> induced_arrow a' (D.cones_map f \<chi>) = f"
using assms induced_arrow_cones_map by blast
show "\<And>\<chi>'. \<chi>' \<in> D.cones a' \<Longrightarrow> D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
using assms cones_map_induced_arrow by blast
qed
lemma induced_arrow_eqI:
assumes "D.cone a' \<chi>'" and "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" and "D.cones_map f \<chi> = \<chi>'"
shows "induced_arrow a' \<chi>' = f"
using assms is_universal induced_arrow_def
the1_equality [of "\<lambda>f. f \<in> C.hom a' a \<and> D.cones_map f \<chi> = \<chi>'" f]
by simp
lemma induced_arrow_self:
shows "induced_arrow a \<chi> = a"
proof -
have "\<guillemotleft>a : a \<rightarrow> a\<guillemotright> \<and> D.cones_map a \<chi> = \<chi>"
using ide_apex cone_axioms D.cones_map_ide by force
thus ?thesis using induced_arrow_eqI cone_axioms by auto
qed
end
context diagram
begin
abbreviation limit_cone
where "limit_cone a \<chi> \<equiv> Limit.limit_cone J C D a \<chi>"
text\<open>
A diagram @{term D} has object @{term a} as a limit if @{term a} is the apex
of some limit cone over @{term D}.
\<close>
abbreviation has_as_limit :: "'c \<Rightarrow> bool"
where "has_as_limit a \<equiv> (\<exists>\<chi>. limit_cone a \<chi>)"
abbreviation has_limit
where "has_limit \<equiv> (\<exists>a \<chi>. limit_cone a \<chi>)"
definition some_limit :: 'c
where "some_limit = (SOME a. \<exists>\<chi>. limit_cone a \<chi>)"
definition some_limit_cone :: "'j \<Rightarrow> 'c"
where "some_limit_cone = (SOME \<chi>. limit_cone some_limit \<chi>)"
lemma limit_cone_some_limit_cone:
assumes has_limit
shows "limit_cone some_limit some_limit_cone"
proof -
have "\<exists>a. has_as_limit a" using assms by simp
hence "has_as_limit some_limit"
using some_limit_def someI_ex [of "\<lambda>a. \<exists>\<chi>. limit_cone a \<chi>"] by simp
thus "limit_cone some_limit some_limit_cone"
using assms some_limit_cone_def someI_ex [of "\<lambda>\<chi>. limit_cone some_limit \<chi>"]
by simp
qed
lemma ex_limitE:
assumes "\<exists>a. has_as_limit a"
obtains a \<chi> where "limit_cone a \<chi>"
using assms someI_ex by blast
end
subsection "Limits by Representation"
text\<open>
A limit for a diagram D can also be given by a representation \<open>(a, \<Phi>)\<close>
of the cones functor.
\<close>
locale representation_of_cones_functor =
C: category C +
Cop: dual_category C +
J: category J +
D: diagram J C D +
S: concrete_set_category S UNIV \<iota> +
Cones: cones_functor J C D S \<iota> +
Hom: hom_functor C S \<phi> +
representation_of_functor C S \<phi> Cones.map a \<Phi>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and \<iota> :: "('j \<Rightarrow> 'c) \<Rightarrow> 's"
and a :: 'c
and \<Phi> :: "'c \<Rightarrow> 's"
subsection "Putting it all Together"
text\<open>
A ``limit situation'' combines and connects the ways of presenting a limit.
\<close>
locale limit_situation =
C: category C +
Cop: dual_category C +
J: category J +
D: diagram J C D +
S: concrete_set_category S UNIV \<iota> +
Cones: cones_functor J C D S \<iota> +
Hom: hom_functor C S \<phi> +
\<Phi>: representation_of_functor C S \<phi> Cones.map a \<Phi> +
\<chi>: limit_cone J C D a \<chi>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and \<iota> :: "('j \<Rightarrow> 'c) \<Rightarrow> 's"
and a :: 'c
and \<Phi> :: "'c \<Rightarrow> 's"
and \<chi> :: "'j \<Rightarrow> 'c" +
assumes \<chi>_in_terms_of_\<Phi>: "\<chi> = S.\<o> (S.Fun (\<Phi> a) (\<phi> (a, a) a))"
and \<Phi>_in_terms_of_\<chi>:
"Cop.ide a' \<Longrightarrow> \<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a')
(\<lambda>x. \<iota> (D.cones_map (Hom.\<psi> (a', a) x) \<chi>))"
text (in limit_situation) \<open>
The assumption @{prop \<chi>_in_terms_of_\<Phi>} states that the universal cone @{term \<chi>} is obtained
by applying the function @{term "S.Fun (\<Phi> a)"} to the identity @{term a} of
@{term[source=true] C} (after taking into account the necessary coercions).
\<close>
text (in limit_situation) \<open>
The assumption @{prop \<Phi>_in_terms_of_\<chi>} states that the component of @{term \<Phi>} at @{term a'}
is the arrow of @{term[source=true] S} corresponding to the function that takes an arrow
@{term "f \<in> C.hom a' a"} and produces the cone with vertex @{term a'} obtained
by transforming the universal cone @{term \<chi>} by @{term f}.
\<close>
subsection "Limit Cones Induce Limit Situations"
text\<open>
To obtain a limit situation from a limit cone, we need to introduce a set category
that is large enough to contain the hom-sets of @{term C} as well as the cones
over @{term D}. We use the category of @{typ "('c + ('j \<Rightarrow> 'c))"}-sets for this.
\<close>
context limit_cone
begin
interpretation Cop: dual_category C ..
interpretation CopxC: product_category Cop.comp C ..
- interpretation S: set_category "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
+ interpretation S: set_category \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
using SetCat.is_set_category by auto
- interpretation S: concrete_set_category "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
- UNIV "UP o Inr"
+ interpretation S: concrete_set_category \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
+ UNIV \<open>UP o Inr\<close>
apply unfold_locales
using UP_mapsto
apply auto[1]
using inj_UP inj_Inr inj_compose
by metis
notation SetCat.comp (infixr "\<cdot>\<^sub>S" 55)
- interpretation Cones: cones_functor J C D "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
- "UP o Inr" ..
-
- interpretation Hom: hom_functor C "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
- "\<lambda>_. UP o Inl"
+ interpretation Cones: cones_functor J C D \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
+ \<open>UP o Inr\<close> ..
+
+ interpretation Hom: hom_functor C \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
+ \<open>\<lambda>_. UP o Inl\<close>
apply (unfold_locales)
using UP_mapsto
apply auto[1]
using SetCat.inj_UP injD inj_onI inj_Inl inj_compose
by (metis (no_types, lifting))
- interpretation Y: yoneda_functor C "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
- "\<lambda>_. UP o Inl" ..
+ interpretation Y: yoneda_functor C \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
+ \<open>\<lambda>_. UP o Inl\<close> ..
interpretation Ya: yoneda_functor_fixed_object
- C "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
- "\<lambda>_. UP o Inl" a
+ C \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
+ \<open>\<lambda>_. UP o Inl\<close> a
apply (unfold_locales) using ide_apex by auto
abbreviation inl :: "'c \<Rightarrow> 'c + ('j \<Rightarrow> 'c)" where "inl \<equiv> Inl"
abbreviation inr :: "('j \<Rightarrow> 'c) \<Rightarrow> 'c + ('j \<Rightarrow> 'c)" where "inr \<equiv> Inr"
abbreviation \<iota> where "\<iota> \<equiv> UP o inr"
abbreviation \<o> where "\<o> \<equiv> Cones.\<o>"
abbreviation \<phi> where "\<phi> \<equiv> \<lambda>_. UP o inl"
abbreviation \<psi> where "\<psi> \<equiv> Hom.\<psi>"
abbreviation Y where "Y \<equiv> Y.Y"
lemma Ya_ide:
assumes a': "C.ide a'"
shows "Y a a' = S.mkIde (Hom.set (a', a))"
using assms ide_apex Y.Y_simp Hom.map_ide by simp
lemma Ya_arr:
assumes g: "C.arr g"
shows "Y a g = S.mkArr (Hom.set (C.cod g, a)) (Hom.set (C.dom g, a))
(\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
using ide_apex g Y.Y_ide_arr [of a g "C.dom g" "C.cod g"] by auto
lemma cone_\<chi> [simp]:
shows "\<chi> \<in> D.cones a"
using cone_axioms by simp
text\<open>
For each object @{term a'} of @{term[source=true] C} we have a function mapping
@{term "C.hom a' a"} to the set of cones over @{term D} with apex @{term a'},
which takes @{term "f \<in> C.hom a' a"} to \<open>\<chi>f\<close>, where \<open>\<chi>f\<close> is the cone obtained by
composing @{term \<chi>} with @{term f} (after accounting for coercions to and from the
- universe of @{term S}. The corresponding arrows of @{term S} are the
+ universe of @{term S}). The corresponding arrows of @{term S} are the
components of a natural isomorphism from @{term "Y a"} to \<open>Cones\<close>.
\<close>
- definition \<Phi>o :: "'c \<Rightarrow> ('c + ('j \<Rightarrow> 'c)) SetCat.arr"
+ definition \<Phi>o :: "'c \<Rightarrow> ('c + ('j \<Rightarrow> 'c)) setcat.arr"
where
"\<Phi>o a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>))"
lemma \<Phi>o_in_hom:
assumes a': "C.ide a'"
shows "\<guillemotleft>\<Phi>o a' : S.mkIde (Hom.set (a', a)) \<rightarrow>\<^sub>S S.mkIde (\<iota> ` D.cones a')\<guillemotright>"
proof -
have " \<guillemotleft>S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)) :
S.mkIde (Hom.set (a', a)) \<rightarrow>\<^sub>S S.mkIde (\<iota> ` D.cones a')\<guillemotright>"
proof -
have "(\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)) \<in> Hom.set (a', a) \<rightarrow> \<iota> ` D.cones a'"
proof
fix x
assume x: "x \<in> Hom.set (a', a)"
hence "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>"
using ide_apex a' Hom.\<psi>_mapsto by auto
hence "D.cones_map (\<psi> (a', a) x) \<chi> \<in> D.cones a'"
using ide_apex a' x D.cones_map_mapsto cone_\<chi> by force
thus "\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>) \<in> \<iota> ` D.cones a'" by simp
qed
moreover have "Hom.set (a', a) \<subseteq> S.Univ"
using ide_apex a' Hom.set_subset_Univ by auto
moreover have "\<iota> ` D.cones a' \<subseteq> S.Univ"
using UP_mapsto by auto
ultimately show ?thesis using S.mkArr_in_hom by simp
qed
thus ?thesis using \<Phi>o_def [of a'] by auto
qed
interpretation \<Phi>: transformation_by_components
- Cop.comp SetCat.comp "Y a" Cones.map \<Phi>o
+ Cop.comp SetCat.comp \<open>Y a\<close> Cones.map \<Phi>o
proof
fix a'
assume A': "Cop.ide a'"
show "\<guillemotleft>\<Phi>o a' : Y a a' \<rightarrow>\<^sub>S Cones.map a'\<guillemotright>"
using A' Ya_ide \<Phi>o_in_hom Cones.map_ide by auto
next
fix g
assume g: "Cop.arr g"
show "\<Phi>o (Cop.cod g) \<cdot>\<^sub>S Y a g = Cones.map g \<cdot>\<^sub>S \<Phi>o (Cop.dom g)"
proof -
let ?A = "Hom.set (C.cod g, a)"
let ?B = "Hom.set (C.dom g, a)"
let ?B' = "\<iota> ` D.cones (C.cod g)"
let ?C = "\<iota> ` D.cones (C.dom g)"
let ?F = "\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a)"
let ?F' = "\<iota> o D.cones_map g o \<o>"
let ?G = "\<lambda>x. \<iota> (D.cones_map (\<psi> (C.dom g, a) x) \<chi>)"
let ?G' = "\<lambda>x. \<iota> (D.cones_map (\<psi> (C.cod g, a) x) \<chi>)"
have "S.arr (Y a g) \<and> Y a g = S.mkArr ?A ?B ?F"
using ide_apex g Ya.preserves_arr Ya_arr by fastforce
moreover have "S.arr (\<Phi>o (Cop.cod g))"
using g \<Phi>o_in_hom [of "Cop.cod g"] by auto
moreover have "\<Phi>o (Cop.cod g) = S.mkArr ?B ?C ?G"
using g \<Phi>o_def [of "C.dom g"] by auto
moreover have "S.seq (\<Phi>o (Cop.cod g)) (Y a g)"
using ide_apex g \<Phi>o_in_hom [of "Cop.cod g"] by auto
ultimately have 1: "S.seq (\<Phi>o (Cop.cod g)) (Y a g) \<and>
\<Phi>o (Cop.cod g) \<cdot>\<^sub>S Y a g = S.mkArr ?A ?C (?G o ?F)"
using S.comp_mkArr [of ?A ?B ?F ?C ?G] by argo
have "Cones.map g = S.mkArr (\<iota> ` D.cones (C.cod g)) (\<iota> ` D.cones (C.dom g)) ?F'"
using g Cones.map_simp by fastforce
moreover have "\<Phi>o (Cop.dom g) = S.mkArr ?A ?B' ?G'"
using g \<Phi>o_def by fastforce
moreover have "S.seq (Cones.map g) (\<Phi>o (Cop.dom g))"
using g Cones.preserves_hom [of g "C.cod g" "C.dom g"] \<Phi>o_in_hom [of "Cop.dom g"]
by force
ultimately have
2: "S.seq (Cones.map g) (\<Phi>o (Cop.dom g)) \<and>
Cones.map g \<cdot>\<^sub>S \<Phi>o (Cop.dom g) = S.mkArr ?A ?C (?F' o ?G')"
using S.seqI' [of "\<Phi>o (Cop.dom g)" "Cones.map g"] by force
have "\<Phi>o (Cop.cod g) \<cdot>\<^sub>S Y a g = S.mkArr ?A ?C (?G o ?F)"
using 1 by auto
also have "... = S.mkArr ?A ?C (?F' o ?G')"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr ?A ?C (?G o ?F))" using 1 by force
show "\<And>x. x \<in> ?A \<Longrightarrow> (?G o ?F) x = (?F' o ?G') x"
proof -
fix x
assume x: "x \<in> ?A"
hence 1: "\<guillemotleft>\<psi> (C.cod g, a) x : C.cod g \<rightarrow> a\<guillemotright>"
using ide_apex g Hom.\<psi>_mapsto [of "C.cod g" a] by auto
have "(?G o ?F) x = \<iota> (D.cones_map (\<psi> (C.dom g, a)
(\<phi> (C.dom g, a) (\<psi> (C.cod g, a) x \<cdot> g))) \<chi>)"
proof - (* Why is it so balky with this proof? *)
have "(?G o ?F) x = ?G (?F x)" by simp
also have "... = \<iota> (D.cones_map (\<psi> (C.dom g, a)
(\<phi> (C.dom g, a) (\<psi> (C.cod g, a) x \<cdot> g))) \<chi>)"
proof -
have "?F x = \<phi> (C.dom g, a) (\<psi> (C.cod g, a) x \<cdot> g)" by simp
thus ?thesis by presburger (* presburger 5ms, metis 797ms! Why? *)
qed
finally show ?thesis by auto
qed
also have "... = \<iota> (D.cones_map (\<psi> (C.cod g, a) x \<cdot> g) \<chi>)"
proof -
have "\<guillemotleft>\<psi> (C.cod g, a) x \<cdot> g : C.dom g \<rightarrow> a\<guillemotright>" using g 1 by auto
thus ?thesis using Hom.\<psi>_\<phi> by presburger
qed
also have "... = \<iota> (D.cones_map g (D.cones_map (\<psi> (C.cod g, a) x) \<chi>))"
using g x 1 cone_\<chi> D.cones_map_comp [of "\<psi> (C.cod g, a) x" g] by fastforce
also have "... = \<iota> (D.cones_map g (\<o> (\<iota> (D.cones_map (\<psi> (C.cod g, a) x) \<chi>))))"
using 1 cone_\<chi> D.cones_map_mapsto S.\<o>_\<iota> by simp
also have "... = (?F' o ?G') x" by simp
finally show "(?G o ?F) x = (?F' o ?G') x" by auto
qed
qed
also have "... = Cones.map g \<cdot>\<^sub>S \<Phi>o (Cop.dom g)"
using 2 by auto
finally show ?thesis by auto
qed
qed
interpretation \<Phi>: set_valued_transformation
- Cop.comp SetCat.comp "Y a" Cones.map \<Phi>.map ..
+ Cop.comp SetCat.comp \<open>Y a\<close> Cones.map \<Phi>.map ..
- interpretation \<Phi>: natural_isomorphism Cop.comp SetCat.comp "Y a" Cones.map \<Phi>.map
+ interpretation \<Phi>: natural_isomorphism Cop.comp SetCat.comp \<open>Y a\<close> Cones.map \<Phi>.map
proof
fix a'
assume a': "Cop.ide a'"
show "S.iso (\<Phi>.map a')"
proof -
let ?F = "\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
have bij: "bij_betw ?F (Hom.set (a', a)) (\<iota> ` D.cones a')"
proof -
have "\<And>x x'. \<lbrakk> x \<in> Hom.set (a', a); x' \<in> Hom.set (a', a);
\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>) \<rbrakk>
\<Longrightarrow> x = x'"
proof -
fix x x'
assume x: "x \<in> Hom.set (a', a)" and x': "x' \<in> Hom.set (a', a)"
and xx': "\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>)"
have \<psi>x: "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>" using x ide_apex a' Hom.\<psi>_mapsto by auto
have \<psi>x': "\<guillemotleft>\<psi> (a', a) x' : a' \<rightarrow> a\<guillemotright>" using x' ide_apex a' Hom.\<psi>_mapsto by auto
have 1: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
proof -
have "D.cones_map (\<psi> (a', a) x) \<chi> \<in> D.cones a'"
using \<psi>x a' cone_\<chi> D.cones_map_mapsto by force
hence 2: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>"
using a' is_universal by simp
show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
proof -
have "\<And>f. \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)
\<longleftrightarrow> D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>"
proof -
fix f :: 'c
have "D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>
\<longrightarrow> \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
by simp
thus "(\<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>))
= (D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>)"
by (meson S.inj_\<iota> injD)
qed
thus ?thesis using 2 by auto
qed
qed
have 2: "\<exists>!x''. x'' \<in> Hom.set (a', a) \<and>
\<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
proof -
from 1 obtain f'' where
f'': "\<guillemotleft>f'' : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f'' \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
by blast
have "\<phi> (a', a) f'' \<in> Hom.set (a', a) \<and>
\<iota> (D.cones_map (\<psi> (a', a) (\<phi> (a', a) f'')) \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
proof
show "\<phi> (a', a) f'' \<in> Hom.set (a', a)" using f'' Hom.set_def by auto
show "\<iota> (D.cones_map (\<psi> (a', a) (\<phi> (a', a) f'')) \<chi>) =
\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
using f'' Hom.\<psi>_\<phi> by presburger
qed
moreover have
"\<And>x''. x'' \<in> Hom.set (a', a) \<and>
\<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)
\<Longrightarrow> x'' = \<phi> (a', a) f''"
proof -
fix x''
assume x'': "x'' \<in> Hom.set (a', a) \<and>
\<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
hence "\<guillemotleft>\<psi> (a', a) x'' : a' \<rightarrow> a\<guillemotright> \<and>
\<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
using ide_apex a' Hom.set_def Hom.\<psi>_mapsto [of a' a] by auto
hence "\<phi> (a', a) (\<psi> (a', a) x'') = \<phi> (a', a) f''"
using 1 f'' by auto
thus "x'' = \<phi> (a', a) f''"
using ide_apex a' x'' Hom.\<phi>_\<psi> by simp
qed
ultimately show ?thesis
using ex1I [of "\<lambda>x'. x' \<in> Hom.set (a', a) \<and>
\<iota> (D.cones_map (\<psi> (a', a) x') \<chi>) =
\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
"\<phi> (a', a) f''"]
by simp
qed
thus "x = x'" using x x' xx' by auto
qed
hence "inj_on ?F (Hom.set (a', a))"
using inj_onI [of "Hom.set (a', a)" ?F] by auto
moreover have "?F ` Hom.set (a', a) = \<iota> ` D.cones a'"
proof
show "?F ` Hom.set (a', a) \<subseteq> \<iota> ` D.cones a'"
proof
fix X'
assume X': "X' \<in> ?F ` Hom.set (a', a)"
from this obtain x' where x': "x' \<in> Hom.set (a', a) \<and> ?F x' = X'" by blast
show "X' \<in> \<iota> ` D.cones a'"
proof -
have "X' = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>)" using x' by blast
hence "X' = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>)" using x' by force
moreover have "\<guillemotleft>\<psi> (a', a) x' : a' \<rightarrow> a\<guillemotright>"
using ide_apex a' x' Hom.set_def Hom.\<psi>_\<phi> by auto
ultimately show ?thesis
using x' cone_\<chi> D.cones_map_mapsto by force
qed
qed
show "\<iota> ` D.cones a' \<subseteq> ?F ` Hom.set (a', a)"
proof
fix X'
assume X': "X' \<in> \<iota> ` D.cones a'"
hence "\<o> X' \<in> \<o> ` \<iota> ` D.cones a'" by simp
with S.\<o>_\<iota> have "\<o> X' \<in> D.cones a'"
by auto
hence "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<o> X'"
using a' is_universal by simp
from this obtain f where "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<o> X'"
by auto
hence f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f \<chi>) = X'"
using X' S.\<iota>_\<o> by auto
have "X' = ?F (\<phi> (a', a) f)"
using f Hom.\<psi>_\<phi> by presburger
thus "X' \<in> ?F ` Hom.set (a', a)"
using f Hom.set_def by force
qed
qed
ultimately show ?thesis
using bij_betw_def [of ?F "Hom.set (a', a)" "\<iota> ` D.cones a'"] inj_on_def by auto
qed
let ?f = "S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F"
have iso: "S.iso ?f"
proof -
have "?F \<in> Hom.set (a', a) \<rightarrow> \<iota> ` D.cones a'"
using bij bij_betw_imp_funcset by fast
hence "S.arr ?f"
using ide_apex a' Hom.set_subset_Univ S.\<iota>_mapsto S.arr_mkArr by auto
thus ?thesis using bij S.iso_char by fastforce
qed
moreover have "?f = \<Phi>.map a'"
using a' \<Phi>o_def by force
finally show ?thesis by auto
qed
qed
interpretation R: representation_of_functor
- C "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
+ C \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
\<phi> Cones.map a \<Phi>.map ..
lemma \<chi>_in_terms_of_\<Phi>:
shows "\<chi> = \<o> (\<Phi>.FUN a (\<phi> (a, a) a))"
proof -
have "\<Phi>.FUN a (\<phi> (a, a) a) =
(\<lambda>x \<in> Hom.set (a, a). \<iota> (D.cones_map (\<psi> (a, a) x) \<chi>)) (\<phi> (a, a) a)"
using ide_apex S.Fun_mkArr \<Phi>.map_simp_ide \<Phi>o_def \<Phi>.preserves_reflects_arr [of a]
by simp
also have "... = \<iota> (D.cones_map a \<chi>)"
proof -
have "\<phi> (a, a) a \<in> Hom.set (a, a)"
using ide_apex Hom.\<phi>_mapsto by fastforce
hence "(\<lambda>x \<in> Hom.set (a, a). \<iota> (D.cones_map (\<psi> (a, a) x) \<chi>)) (\<phi> (a, a) a)
= \<iota> (D.cones_map (\<psi> (a, a) (\<phi> (a, a) a)) \<chi>)"
using restrict_apply' [of "\<phi> (a, a) a" "Hom.set (a, a)"] by blast
also have "... = \<iota> (D.cones_map a \<chi>)"
proof -
have "\<psi> (a, a) (\<phi> (a, a) a) = a"
using ide_apex Hom.\<psi>_\<phi> [of a a a] by fastforce
thus ?thesis by metis
qed
finally show ?thesis by auto
qed
finally have "\<Phi>.FUN a (\<phi> (a, a) a) = \<iota> (D.cones_map a \<chi>)" by auto
also have "... = \<iota> \<chi>"
using ide_apex D.cones_map_ide [of \<chi> a] cone_\<chi> by simp
finally have "\<Phi>.FUN a (\<phi> (a, a) a) = \<iota> \<chi>" by blast
hence "\<o> (\<Phi>.FUN a (\<phi> (a, a) a)) = \<o> (\<iota> \<chi>)" by simp
thus ?thesis using cone_\<chi> S.\<o>_\<iota> by simp
qed
abbreviation Hom
where "Hom \<equiv> Hom.map"
abbreviation \<Phi>
where "\<Phi> \<equiv> \<Phi>.map"
lemma induces_limit_situation:
- shows "limit_situation J C D (SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp) \<phi> \<iota> a \<Phi> \<chi>"
+ shows "limit_situation J C D (SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp) \<phi> \<iota> a \<Phi> \<chi>"
proof
show "\<chi> = \<o> (\<Phi>.FUN a (\<phi> (a, a) a))" using \<chi>_in_terms_of_\<Phi> by auto
fix a'
show "Cop.ide a' \<Longrightarrow> \<Phi>.map a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a')
(\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>))"
using \<Phi>.map_simp_ide \<Phi>o_def [of a'] by force
qed
no_notation SetCat.comp (infixr "\<cdot>\<^sub>S" 55)
end
- sublocale limit_cone \<subseteq> limit_situation J C D "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) SetCat.arr comp"
+ sublocale limit_cone \<subseteq> limit_situation J C D "SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp"
\<phi> \<iota> a \<Phi> \<chi>
using induces_limit_situation by auto
subsection "Representations of the Cones Functor Induce Limit Situations"
context representation_of_cones_functor
begin
- interpretation \<Phi>: set_valued_transformation Cop.comp S "Y a" Cones.map \<Phi> ..
- interpretation \<Psi>: inverse_transformation Cop.comp S "Y a" Cones.map \<Phi> ..
- interpretation \<Psi>: set_valued_transformation Cop.comp S Cones.map "Y a" \<Psi>.map ..
+ interpretation \<Phi>: set_valued_transformation Cop.comp S \<open>Y a\<close> Cones.map \<Phi> ..
+ interpretation \<Psi>: inverse_transformation Cop.comp S \<open>Y a\<close> Cones.map \<Phi> ..
+ interpretation \<Psi>: set_valued_transformation Cop.comp S Cones.map \<open>Y a\<close> \<Psi>.map ..
abbreviation \<o>
where "\<o> \<equiv> Cones.\<o>"
abbreviation \<chi>
where "\<chi> \<equiv> \<o> (S.Fun (\<Phi> a) (\<phi> (a, a) a))"
lemma Cones_SET_eq_\<iota>_img_cones:
assumes "C.ide a'"
shows "Cones.SET a' = \<iota> ` D.cones a'"
proof -
have "\<iota> ` D.cones a' \<subseteq> S.Univ" using S.\<iota>_mapsto by auto
thus ?thesis using assms Cones.map_ide by auto
qed
lemma \<iota>\<chi>:
shows "\<iota> \<chi> = S.Fun (\<Phi> a) (\<phi> (a, a) a)"
proof -
have "S.Fun (\<Phi> a) (\<phi> (a, a) a) \<in> Cones.SET a"
using Ya.ide_a Hom.\<phi>_mapsto S.Fun_mapsto [of "\<Phi> a"] Hom.set_map by fastforce
thus ?thesis
using Ya.ide_a Cones_SET_eq_\<iota>_img_cones by auto
qed
interpretation \<chi>: cone J C D a \<chi>
proof -
have "\<iota> \<chi> \<in> \<iota> ` D.cones a"
using Ya.ide_a \<iota>\<chi> S.Fun_mapsto [of "\<Phi> a"] Hom.\<phi>_mapsto Hom.set_map
Cones_SET_eq_\<iota>_img_cones by fastforce
thus "D.cone a \<chi>"
by (metis S.\<o>_\<iota> UNIV_I imageE mem_Collect_eq)
qed
lemma cone_\<chi>:
shows "D.cone a \<chi>" ..
lemma \<Phi>_FUN_simp:
assumes a': "C.ide a'" and x: "x \<in> Hom.set (a', a)"
shows "\<Phi>.FUN a' x = Cones.FUN (\<psi> (a', a) x) (\<iota> \<chi>)"
proof -
have \<psi>x: "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>"
using Ya.ide_a a' x Hom.\<psi>_mapsto by blast
have \<phi>a: "\<phi> (a, a) a \<in> Hom.set (a, a)" using Ya.ide_a Hom.\<phi>_mapsto by fastforce
have "\<Phi>.FUN a' x = (\<Phi>.FUN a' o Ya.FUN (\<psi> (a', a) x)) (\<phi> (a, a) a)"
proof -
have "\<phi> (a', a) (a \<cdot> \<psi> (a', a) x) = x"
using Ya.ide_a a' x \<psi>x Hom.\<phi>_\<psi> C.comp_cod_arr by fastforce
moreover have "S.arr (S.mkArr (Hom.set (a, a)) (Hom.set (a', a))
(\<phi> (a', a) \<circ> Cop.comp (\<psi> (a', a) x) \<circ> \<psi> (a, a)))"
using Ya.ide_a a' Hom.set_subset_Univ Hom.\<psi>_mapsto [of a a] Hom.\<phi>_mapsto \<psi>x
by force
ultimately show ?thesis
using Ya.ide_a a' x Ya.Y_ide_arr \<psi>x \<phi>a C.ide_in_hom by auto
qed
also have "... = (Cones.FUN (\<psi> (a', a) x) o \<Phi>.FUN a) (\<phi> (a, a) a)"
proof -
have "(\<Phi>.FUN a' o Ya.FUN (\<psi> (a', a) x)) (\<phi> (a, a) a)
= S.Fun (\<Phi> a' \<cdot>\<^sub>S Y a (\<psi> (a', a) x)) (\<phi> (a, a) a)"
using \<psi>x a' \<phi>a Ya.ide_a Ya.map_simp Hom.set_map by (elim C.in_homE, auto)
also have "... = S.Fun (S (Cones.map (\<psi> (a', a) x)) (\<Phi> a)) (\<phi> (a, a) a)"
using \<psi>x is_natural_1 [of "\<psi> (a', a) x"] is_natural_2 [of "\<psi> (a', a) x"] by auto
also have "... = (Cones.FUN (\<psi> (a', a) x) o \<Phi>.FUN a) (\<phi> (a, a) a)"
proof -
have "S.seq (Cones.map (\<psi> (a', a) x)) (\<Phi> a)"
using Ya.ide_a \<psi>x Cones.map_preserves_dom [of "\<psi> (a', a) x"]
apply (intro S.seqI)
apply auto[2]
by fastforce
thus ?thesis
using Ya.ide_a \<phi>a Hom.set_map by auto
qed
finally show ?thesis by simp
qed
also have "... = Cones.FUN (\<psi> (a', a) x) (\<iota> \<chi>)" using \<iota>\<chi> by simp
finally show ?thesis by auto
qed
lemma \<chi>_is_universal:
assumes "D.cone a' \<chi>'"
shows "\<guillemotleft>\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>')) : a' \<rightarrow> a\<guillemotright>"
and "D.cones_map (\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))) \<chi> = \<chi>'"
and "\<lbrakk> \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>; D.cones_map f' \<chi> = \<chi>' \<rbrakk> \<Longrightarrow> f' = \<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
proof -
interpret \<chi>': cone J C D a' \<chi>' using assms by auto
have a': "C.ide a'" using \<chi>'.ide_apex by simp
have \<iota>\<chi>': "\<iota> \<chi>' \<in> Cones.SET a'" using assms a' Cones_SET_eq_\<iota>_img_cones by auto
let ?f = "\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
have A: "\<Psi>.FUN a' (\<iota> \<chi>') \<in> Hom.set (a', a)"
proof -
have "\<Psi>.FUN a' \<in> Cones.SET a' \<rightarrow> Ya.SET a'"
using a' \<Psi>.preserves_hom [of a' a' a'] S.Fun_mapsto [of "\<Psi>.map a'"] by fastforce
thus ?thesis using a' \<iota>\<chi>' Ya.ide_a Hom.set_map by auto
qed
show f: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright>" using A a' Ya.ide_a Hom.\<psi>_mapsto [of a' a] by auto
have E: "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> Cones.FUN f (\<iota> \<chi>) = \<Phi>.FUN a' (\<phi> (a', a) f)"
proof -
fix f
assume f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>"
have "\<phi> (a', a) f \<in> Hom.set (a', a)"
using a' Ya.ide_a f Hom.\<phi>_mapsto by auto
thus "Cones.FUN f (\<iota> \<chi>) = \<Phi>.FUN a' (\<phi> (a', a) f)"
using a' f \<Phi>_FUN_simp by simp
qed
have I: "\<Phi>.FUN a' (\<Psi>.FUN a' (\<iota> \<chi>')) = \<iota> \<chi>'"
proof -
have "\<Phi>.FUN a' (\<Psi>.FUN a' (\<iota> \<chi>')) =
compose (\<Psi>.DOM a') (\<Phi>.FUN a') (\<Psi>.FUN a') (\<iota> \<chi>')"
using a' \<iota>\<chi>' Cones.map_ide \<Psi>.preserves_hom [of a' a' a'] by force
also have "... = (\<lambda>x \<in> \<Psi>.DOM a'. x) (\<iota> \<chi>')"
using a' \<Psi>.inverts_components S.inverse_arrows_char by force
also have "... = \<iota> \<chi>'"
using a' \<iota>\<chi>' Cones.map_ide \<Psi>.preserves_hom [of a' a' a'] by force
finally show ?thesis by auto
qed
show f\<chi>: "D.cones_map ?f \<chi> = \<chi>'"
proof -
have "D.cones_map ?f \<chi> = (\<o> o Cones.FUN ?f o \<iota>) \<chi>"
using f Cones.preserves_arr [of ?f] cone_\<chi>
by (cases "D.cone a \<chi>", auto)
also have "... = \<chi>'"
using f Ya.ide_a a' A E I by auto
finally show ?thesis by auto
qed
show "\<lbrakk> \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>; D.cones_map f' \<chi> = \<chi>' \<rbrakk> \<Longrightarrow> f' = ?f"
proof -
assume f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>" and f'\<chi>: "D.cones_map f' \<chi> = \<chi>'"
show "f' = ?f"
proof -
have 1: "\<phi> (a', a) f' \<in> Hom.set (a', a) \<and> \<phi> (a', a) ?f \<in> Hom.set (a', a)"
using Ya.ide_a a' f f' Hom.\<phi>_mapsto by auto
have "S.iso (\<Phi> a')" using \<chi>'.ide_apex components_are_iso by auto
hence 2: "S.arr (\<Phi> a') \<and> bij_betw (\<Phi>.FUN a') (Hom.set (a', a)) (Cones.SET a')"
using Ya.ide_a a' S.iso_char Hom.set_map by auto
have "\<Phi>.FUN a' (\<phi> (a', a) f') = \<Phi>.FUN a' (\<phi> (a', a) ?f)"
proof -
have "\<Phi>.FUN a' (\<phi> (a', a) ?f) = \<iota> \<chi>'"
using A I Hom.\<phi>_\<psi> Ya.ide_a a' by simp
also have "... = Cones.FUN f' (\<iota> \<chi>)"
using f f' A E cone_\<chi> Cones.preserves_arr f\<chi> f'\<chi> by (elim C.in_homE, auto)
also have "... = \<Phi>.FUN a' (\<phi> (a', a) f')"
using f' E by simp
finally show ?thesis by argo
qed
moreover have "inj_on (\<Phi>.FUN a') (Hom.set (a', a))"
using 2 bij_betw_imp_inj_on by blast
ultimately have 3: "\<phi> (a', a) f' = \<phi> (a', a) ?f"
using 1 inj_on_def [of "\<Phi>.FUN a'" "Hom.set (a', a)"] by blast
show ?thesis
proof -
have "f' = \<psi> (a', a) (\<phi> (a', a) f')"
using Ya.ide_a a' f' Hom.\<psi>_\<phi> by simp
also have "... = \<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
using Ya.ide_a a' Hom.\<psi>_\<phi> A 3 by simp
finally show ?thesis by blast
qed
qed
qed
qed
interpretation \<chi>: limit_cone J C D a \<chi>
proof
show "\<And>a' \<chi>'. D.cone a' \<chi>' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
proof -
fix a' \<chi>'
assume 1: "D.cone a' \<chi>'"
show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
proof
show "\<guillemotleft>\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>')) : a' \<rightarrow> a\<guillemotright> \<and>
D.cones_map (\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))) \<chi> = \<chi>'"
using 1 \<chi>_is_universal by blast
show "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' \<Longrightarrow> f = \<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
using 1 \<chi>_is_universal by blast
qed
qed
qed
lemma \<chi>_is_limit_cone:
shows "D.limit_cone a \<chi>" ..
lemma induces_limit_situation:
shows "limit_situation J C D S \<phi> \<iota> a \<Phi> \<chi>"
proof
show "\<chi> = \<chi>" by simp
fix a'
assume a': "Cop.ide a'"
let ?F = "\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
show "\<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F"
proof -
have 1: "\<guillemotleft>\<Phi> a' : S.mkIde (Hom.set (a', a)) \<rightarrow>\<^sub>S S.mkIde (\<iota> ` D.cones a')\<guillemotright>"
using a' Cones.map_ide Ya.ide_a by auto
moreover have "\<Phi>.DOM a' = Hom.set (a', a)"
using 1 Hom.set_subset_Univ a' Ya.ide_a by (elim S.in_homE, auto)
moreover have "\<Phi>.COD a' = \<iota> ` D.cones a'"
using a' Cones_SET_eq_\<iota>_img_cones by fastforce
ultimately have 2: "\<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<Phi>.FUN a')"
using S.mkArr_Fun [of "\<Phi> a'"] by fastforce
also have "... = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F"
proof
show "S.arr (S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<Phi>.FUN a'))"
using 1 2 by auto
show "\<And>x. x \<in> Hom.set (a', a) \<Longrightarrow> \<Phi>.FUN a' x = ?F x"
proof -
fix x
assume x: "x \<in> Hom.set (a', a)"
hence \<psi>x: "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>"
using a' Ya.ide_a Hom.\<psi>_mapsto by auto
show "\<Phi>.FUN a' x = ?F x"
proof -
have "\<Phi>.FUN a' x = Cones.FUN (\<psi> (a', a) x) (\<iota> \<chi>)"
using a' x \<Phi>_FUN_simp by simp
also have "... = restrict (\<iota> o D.cones_map (\<psi> (a', a) x) o \<o>) (\<iota> ` D.cones a) (\<iota> \<chi>)"
using \<psi>x Cones.map_simp Cones.preserves_arr [of "\<psi> (a', a) x"] S.Fun_mkArr
by (elim C.in_homE, auto)
also have "... = ?F x" using cone_\<chi> by simp
ultimately show ?thesis by simp
qed
qed
qed
finally show "\<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F" by auto
qed
qed
end
sublocale representation_of_cones_functor \<subseteq> limit_situation J C D S \<phi> \<iota> a \<Phi> \<chi>
using induces_limit_situation by auto
section "Categories with Limits"
context category
begin
text\<open>
A category @{term[source=true] C} has limits of shape @{term J} if every diagram of shape
@{term J} admits a limit cone.
\<close>
definition has_limits_of_shape
where "has_limits_of_shape J \<equiv> \<forall>D. diagram J C D \<longrightarrow> (\<exists>a \<chi>. limit_cone J C D a \<chi>)"
text\<open>
A category has limits at a type @{typ 'j} if it has limits of shape @{term J}
for every category @{term J} whose arrows are of type @{typ 'j}.
\<close>
definition has_limits
where "has_limits (_ :: 'j) \<equiv> \<forall>J :: 'j comp. category J \<longrightarrow> has_limits_of_shape J"
lemma has_limits_preserved_by_isomorphism:
assumes "has_limits_of_shape J" and "isomorphic_categories J J'"
shows "has_limits_of_shape J'"
proof -
interpret J: category J
using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
interpret J': category J'
using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
from assms(2) obtain \<phi> \<psi> where IF: "inverse_functors J J' \<phi> \<psi>"
using isomorphic_categories_def isomorphic_categories_axioms_def by blast
interpret IF: inverse_functors J J' \<phi> \<psi> using IF by auto
have \<psi>\<phi>: "\<psi> o \<phi> = J.map" using IF.inv by metis
have \<phi>\<psi>: "\<phi> o \<psi> = J'.map" using IF.inv' by metis
have "\<And>D'. diagram J' C D' \<Longrightarrow> \<exists>a \<chi>. limit_cone J' C D' a \<chi>"
proof -
fix D'
assume D': "diagram J' C D'"
interpret D': diagram J' C D' using D' by auto
interpret D: composite_functor J J' C \<phi> D' ..
- interpret D: diagram J C "D' o \<phi>" ..
+ interpret D: diagram J C \<open>D' o \<phi>\<close> ..
have D: "diagram J C (D' o \<phi>)" ..
from assms(1) obtain a \<chi> where \<chi>: "D.limit_cone a \<chi>"
using D has_limits_of_shape_def by blast
- interpret \<chi>: limit_cone J C "D' o \<phi>" a \<chi> using \<chi> by auto
+ interpret \<chi>: limit_cone J C \<open>D' o \<phi>\<close> a \<chi> using \<chi> by auto
interpret A': constant_functor J' C a
using \<chi>.ide_apex by (unfold_locales, auto)
have \<chi>o\<psi>: "cone J' C (D' o \<phi> o \<psi>) a (\<chi> o \<psi>)"
using comp_cone_functor IF.G.functor_axioms \<chi>.cone_axioms by fastforce
hence \<chi>o\<psi>: "cone J' C D' a (\<chi> o \<psi>)"
using \<phi>\<psi> by (metis D'.functor_axioms Fun.comp_assoc comp_functor_identity)
- interpret \<chi>o\<psi>: cone J' C D' a "\<chi> o \<psi>" using \<chi>o\<psi> by auto
- interpret \<chi>o\<psi>: limit_cone J' C D' a "\<chi> o \<psi>"
+ interpret \<chi>o\<psi>: cone J' C D' a \<open>\<chi> o \<psi>\<close> using \<chi>o\<psi> by auto
+ interpret \<chi>o\<psi>: limit_cone J' C D' a \<open>\<chi> o \<psi>\<close>
proof
fix a' \<chi>'
assume \<chi>': "D'.cone a' \<chi>'"
interpret \<chi>': cone J' C D' a' \<chi>' using \<chi>' by auto
have \<chi>'o\<phi>: "cone J C (D' o \<phi>) a' (\<chi>' o \<phi>)"
using \<chi>' comp_cone_functor IF.F.functor_axioms by fastforce
- interpret \<chi>'o\<phi>: cone J C "D' o \<phi>" a' "\<chi>' o \<phi>" using \<chi>'o\<phi> by auto
+ interpret \<chi>'o\<phi>: cone J C \<open>D' o \<phi>\<close> a' \<open>\<chi>' o \<phi>\<close> using \<chi>'o\<phi> by auto
have "cone J C (D' o \<phi>) a' (\<chi>' o \<phi>)" ..
hence 1: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' o \<phi>"
using \<chi>.is_universal by simp
show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f (\<chi> o \<psi>) = \<chi>'"
proof
let ?f = "THE f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' o \<phi>"
have f: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map ?f \<chi> = \<chi>' o \<phi>"
using 1 theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' o \<phi>"] by blast
have f_in_hom: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright>" using f by blast
have "D'.cones_map ?f (\<chi> o \<psi>) = \<chi>'"
proof
fix j'
have "\<not>J'.arr j' \<Longrightarrow> D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'"
proof -
assume j': "\<not>J'.arr j'"
have "D'.cones_map ?f (\<chi> o \<psi>) j' = null"
using j' f_in_hom \<chi>o\<psi> by fastforce
thus ?thesis
using j' \<chi>'.is_extensional by simp
qed
moreover have "J'.arr j' \<Longrightarrow> D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'"
proof -
assume j': "J'.arr j'"
have "D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi> (\<psi> j') \<cdot> ?f"
using j' f \<chi>o\<psi> by fastforce
also have "... = D.cones_map ?f \<chi> (\<psi> j')"
using j' f_in_hom \<chi> \<chi>.cone_\<chi> by fastforce
also have "... = \<chi>' j'"
using j' f \<chi> \<phi>\<psi> Fun.comp_def J'.map_simp by metis
finally show "D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'" by auto
qed
ultimately show "D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'" by blast
qed
thus "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map ?f (\<chi> o \<psi>) = \<chi>'" using f by auto
fix f'
assume f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f' (\<chi> o \<psi>) = \<chi>'"
have "D.cones_map f' \<chi> = \<chi>' o \<phi>"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j"
using f' \<chi> \<chi>'o\<phi>.is_extensional \<chi>.cone_\<chi> mem_Collect_eq restrict_apply by auto
moreover have "J.arr j \<Longrightarrow> D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j"
proof -
assume j: "J.arr j"
have "D.cones_map f' \<chi> j = C (\<chi> j) f'"
using j f' \<chi>.cone_\<chi> by auto
also have "... = C ((\<chi> o \<psi>) (\<phi> j)) f'"
using j f' \<psi>\<phi> by (metis comp_apply J.map_simp)
also have "... = D'.cones_map f' (\<chi> o \<psi>) (\<phi> j)"
using j f' \<chi>o\<psi> by fastforce
also have "... = (\<chi>' o \<phi>) j"
using j f' by auto
finally show "D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j" by auto
qed
ultimately show "D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j" by blast
qed
hence "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f' \<chi> = \<chi>' o \<phi>"
using f' by auto
moreover have "\<And>P x x'. (\<exists>!x. P x) \<and> P x \<and> P x' \<Longrightarrow> x = x'"
by auto
ultimately show "f' = ?f" using 1 f by blast
qed
qed
have "limit_cone J' C D' a (\<chi> o \<psi>)" ..
thus "\<exists>a \<chi>. limit_cone J' C D' a \<chi>" by blast
qed
thus ?thesis using has_limits_of_shape_def by auto
qed
end
subsection "Diagonal Functors"
text\<open>
The existence of limits can also be expressed in terms of adjunctions: a category @{term C}
has limits of shape @{term J} if the diagonal functor taking each object @{term a}
in @{term C} to the constant-@{term a} diagram and each arrow \<open>f \<in> C.hom a a'\<close>
to the constant-@{term f} natural transformation between diagrams is a left adjoint functor.
\<close>
locale diagonal_functor =
C: category C +
J: category J +
J_C: functor_category J C
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
begin
notation J.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J _\<guillemotright>")
notation J_C.comp (infixr "\<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>]" 55)
notation J_C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] _\<guillemotright>")
definition map :: "'c \<Rightarrow> ('j, 'c) J_C.arr"
- where "map f = (if C.arr f then J_C.mkArr (constant_functor.map J C (C.dom f))
+ where "map f = (if C.arr f then J_C.MkArr (constant_functor.map J C (C.dom f))
(constant_functor.map J C (C.cod f))
(constant_transformation.map J C f)
else J_C.null)"
lemma is_functor:
shows "functor C J_C.comp map"
proof
fix f
show "\<not> C.arr f \<Longrightarrow> local.map f = J_C.null"
using map_def by simp
assume f: "C.arr f"
- interpret Dom_f: constant_functor J C "C.dom f"
+ interpret Dom_f: constant_functor J C \<open>C.dom f\<close>
using f by (unfold_locales, auto)
- interpret Cod_f: constant_functor J C "C.cod f"
+ interpret Cod_f: constant_functor J C \<open>C.cod f\<close>
using f by (unfold_locales, auto)
interpret Fun_f: constant_transformation J C f
using f by (unfold_locales, auto)
show 1: "J_C.arr (map f)"
using f map_def by (simp add: Fun_f.natural_transformation_axioms)
show "J_C.dom (map f) = map (C.dom f)"
proof -
have "constant_transformation J C (C.dom f)"
apply unfold_locales using f by auto
hence "constant_transformation.map J C (C.dom f) = Dom_f.map"
using Dom_f.map_def constant_transformation.map_def [of J C "C.dom f"] by auto
- thus ?thesis using f 1 by (simp add: map_def J_C.dom_simp)
+ thus ?thesis using f 1 by (simp add: map_def J_C.dom_char)
qed
show "J_C.cod (map f) = map (C.cod f)"
proof -
have "constant_transformation J C (C.cod f)"
apply unfold_locales using f by auto
hence "constant_transformation.map J C (C.cod f) = Cod_f.map"
using Cod_f.map_def constant_transformation.map_def [of J C "C.cod f"] by auto
- thus ?thesis using f 1 by (simp add: map_def J_C.cod_simp)
+ thus ?thesis using f 1 by (simp add: map_def J_C.cod_char)
qed
next
fix f g
assume g: "C.seq g f"
have f: "C.arr f" using g by auto
- interpret Dom_f: constant_functor J C "C.dom f"
+ interpret Dom_f: constant_functor J C \<open>C.dom f\<close>
using f by (unfold_locales, auto)
- interpret Cod_f: constant_functor J C "C.cod f"
+ interpret Cod_f: constant_functor J C \<open>C.cod f\<close>
using f by (unfold_locales, auto)
interpret Fun_f: constant_transformation J C f
using f by (unfold_locales, auto)
- interpret Cod_g: constant_functor J C "C.cod g"
+ interpret Cod_g: constant_functor J C \<open>C.cod g\<close>
using g by (unfold_locales, auto)
interpret Fun_g: constant_transformation J C g
using g by (unfold_locales, auto)
interpret Fun_g: natural_transformation J C Cod_f.map Cod_g.map Fun_g.map
apply unfold_locales
using f g C.seqE [of g f] C.comp_arr_dom C.comp_cod_arr Fun_g.is_extensional by auto
interpret Fun_fg: vertical_composite
J C Dom_f.map Cod_f.map Cod_g.map Fun_f.map Fun_g.map ..
have 1: "J_C.arr (map f)"
using f map_def by (simp add: Fun_f.natural_transformation_axioms)
show "map (g \<cdot> f) = map g \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map f"
proof -
- have "map (C g f) = J_C.mkArr Dom_f.map Cod_g.map
- (constant_transformation.map J C (C g f))"
+ have "map (C g f) = J_C.MkArr Dom_f.map Cod_g.map
+ (constant_transformation.map J C (C g f))"
using f g map_def by simp
- also have "... = J_C.mkArr Dom_f.map Cod_g.map (\<lambda>j. if J.arr j then C g f else C.null)"
+ also have "... = J_C.MkArr Dom_f.map Cod_g.map (\<lambda>j. if J.arr j then C g f else C.null)"
proof -
have "constant_transformation J C (g \<cdot> f)"
apply unfold_locales using g by auto
thus ?thesis using constant_transformation.map_def by metis
qed
- also have "... = J_C.comp (J_C.mkArr Cod_f.map Cod_g.map Fun_g.map)
- (J_C.mkArr Dom_f.map Cod_f.map Fun_f.map)"
+ also have "... = J_C.comp (J_C.MkArr Cod_f.map Cod_g.map Fun_g.map)
+ (J_C.MkArr Dom_f.map Cod_f.map Fun_f.map)"
proof -
- have "J_C.mkArr Cod_f.map Cod_g.map Fun_g.map \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>]
- J_C.mkArr Dom_f.map Cod_f.map Fun_f.map
- = J_C.mkArr Dom_f.map Cod_g.map Fun_fg.map"
- using J_C.comp_char J_C.comp_mkArr Fun_f.natural_transformation_axioms
+ have "J_C.MkArr Cod_f.map Cod_g.map Fun_g.map \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>]
+ J_C.MkArr Dom_f.map Cod_f.map Fun_f.map
+ = J_C.MkArr Dom_f.map Cod_g.map Fun_fg.map"
+ using J_C.comp_char J_C.comp_MkArr Fun_f.natural_transformation_axioms
Fun_g.natural_transformation_axioms
by blast
- also have "... = J_C.mkArr Dom_f.map Cod_g.map
+ also have "... = J_C.MkArr Dom_f.map Cod_g.map
(\<lambda>j. if J.arr j then g \<cdot> f else C.null)"
proof -
have "Fun_fg.map = (\<lambda>j. if J.arr j then g \<cdot> f else C.null)"
using 1 f g Fun_fg.map_def by auto
thus ?thesis by auto
qed
finally show ?thesis by auto
qed
also have "... = map g \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map f"
using f g map_def by fastforce
finally show ?thesis by auto
qed
qed
end
sublocale diagonal_functor \<subseteq> "functor" C J_C.comp map
using is_functor by auto
context diagonal_functor
begin
text\<open>
The objects of @{term J_C} correspond bijectively to diagrams of shape @{term J}
in @{term C}.
\<close>
lemma ide_determines_diagram:
assumes "J_C.ide d"
- shows "diagram J C (J_C.Fun d)" and "J_C.mkIde (J_C.Fun d) = d"
+ shows "diagram J C (J_C.Map d)" and "J_C.MkIde (J_C.Map d) = d"
proof -
- interpret \<delta>: natural_transformation J C "J_C.Fun d" "J_C.Fun d" "J_C.Fun d"
- using assms J_C.ide_char J_C.arr_mkArr J_C.mkArr_def by fastforce
- interpret D: "functor" J C "J_C.Fun d" ..
- show "diagram J C (J_C.Fun d)" ..
- show "J_C.mkIde (J_C.Fun d) = d"
- using assms J_C.ide_char by (metis J_C.ideD(1) J_C.mkArr_Fun)
+ interpret \<delta>: natural_transformation J C \<open>J_C.Map d\<close> \<open>J_C.Map d\<close> \<open>J_C.Map d\<close>
+ using assms J_C.ide_char J_C.arr_MkArr by fastforce
+ interpret D: "functor" J C \<open>J_C.Map d\<close> ..
+ show "diagram J C (J_C.Map d)" ..
+ show "J_C.MkIde (J_C.Map d) = d"
+ using assms J_C.ide_char by (metis J_C.ideD(1) J_C.MkArr_Map)
qed
lemma diagram_determines_ide:
assumes "diagram J C D"
- shows "J_C.ide (J_C.mkIde D)" and "J_C.Fun (J_C.mkIde D) = D"
+ shows "J_C.ide (J_C.MkIde D)" and "J_C.Map (J_C.MkIde D) = D"
proof -
interpret D: diagram J C D using assms by auto
- show "J_C.ide (J_C.mkIde D)" using J_C.ide_char
- by (metis D.functor_axioms J_C.Cod_mkArr J_C.Dom_mkArr J_C.Fun_mkArr J_C.arr_mkArr
- J_C.not_arr_null functor_is_transformation)
- thus "J_C.Fun (J_C.mkIde D) = D"
- using J_C.Fun_mkArr J_C.in_homE by (metis J_C.ideD(1))
+ show "J_C.ide (J_C.MkIde D)" using J_C.ide_char
+ using D.functor_axioms J_C.ide_MkIde by auto
+ thus "J_C.Map (J_C.MkIde D) = D"
+ using J_C.in_homE by simp
qed
lemma bij_betw_ide_diagram:
- shows "bij_betw J_C.Fun (Collect J_C.ide) (Collect (diagram J C))"
+ shows "bij_betw J_C.Map (Collect J_C.ide) (Collect (diagram J C))"
proof (intro bij_betwI)
- show "J_C.Fun \<in> Collect J_C.ide \<rightarrow> Collect (diagram J C)"
+ show "J_C.Map \<in> Collect J_C.ide \<rightarrow> Collect (diagram J C)"
using ide_determines_diagram by blast
- show "J_C.mkIde \<in> Collect (diagram J C) \<rightarrow> Collect J_C.ide"
+ show "J_C.MkIde \<in> Collect (diagram J C) \<rightarrow> Collect J_C.ide"
using diagram_determines_ide by blast
- show "\<And>d. d \<in> Collect J_C.ide \<Longrightarrow> J_C.mkIde (J_C.Fun d) = d"
+ show "\<And>d. d \<in> Collect J_C.ide \<Longrightarrow> J_C.MkIde (J_C.Map d) = d"
using ide_determines_diagram by blast
- show "\<And>D. D \<in> Collect (diagram J C) \<Longrightarrow> J_C.Fun (J_C.mkIde D) = D"
+ show "\<And>D. D \<in> Collect (diagram J C) \<Longrightarrow> J_C.Map (J_C.MkIde D) = D"
using diagram_determines_ide by blast
qed
text\<open>
Arrows from from the diagonal functor correspond bijectively to cones.
\<close>
lemma arrow_determines_cone:
assumes "J_C.ide d" and "arrow_from_functor C J_C.comp map a d x"
- shows "cone J C (J_C.Fun d) a (J_C.Fun x)"
- and "J_C.mkArr (constant_functor.map J C a) (J_C.Fun d) (J_C.Fun x) = x"
+ shows "cone J C (J_C.Map d) a (J_C.Map x)"
+ and "J_C.MkArr (constant_functor.map J C a) (J_C.Map d) (J_C.Map x) = x"
proof -
- interpret D: diagram J C "J_C.Fun d"
+ interpret D: diagram J C \<open>J_C.Map d\<close>
using assms ide_determines_diagram by auto
interpret x: arrow_from_functor C J_C.comp map a d x
using assms by auto
interpret A: constant_functor J C a
using x.arrow by (unfold_locales, auto)
interpret \<alpha>: constant_transformation J C a
using x.arrow by (unfold_locales, auto)
have Dom_x: "J_C.Dom x = A.map"
proof -
have "J_C.dom x = map a" using x.arrow by blast
- hence "J_C.Fun (J_C.dom x) = J_C.Fun (map a)" by simp
- hence "J_C.Dom x = J_C.Fun (map a)"
- using A.value_is_ide x.arrow J_C.in_homE by (metis J_C.Fun_dom)
- moreover have "J_C.Fun (map a) = \<alpha>.map"
- using A.value_is_ide preserves_ide map_def J_C.Fun_mkArr
- by (metis J_C.arr_char J_C.ideD(1))
+ hence "J_C.Map (J_C.dom x) = J_C.Map (map a)" by simp
+ hence "J_C.Dom x = J_C.Map (map a)"
+ using A.value_is_ide x.arrow J_C.in_homE by (metis J_C.Map_dom)
+ moreover have "J_C.Map (map a) = \<alpha>.map"
+ using A.value_is_ide preserves_ide map_def by simp
ultimately show ?thesis using \<alpha>.map_def A.map_def by auto
qed
- have Cod_x: "J_C.Cod x = J_C.Fun d"
+ have Cod_x: "J_C.Cod x = J_C.Map d"
using x.arrow by auto
- interpret \<chi>: natural_transformation J C A.map "J_C.Fun d" "J_C.Fun x"
+ interpret \<chi>: natural_transformation J C A.map \<open>J_C.Map d\<close> \<open>J_C.Map x\<close>
using x.arrow J_C.arr_char [of x] Dom_x Cod_x by force
- show "D.cone a (J_C.Fun x)" ..
- show "J_C.mkArr A.map (J_C.Fun d) (J_C.Fun x) = x"
+ show "D.cone a (J_C.Map x)" ..
+ show "J_C.MkArr A.map (J_C.Map d) (J_C.Map x) = x"
using x.arrow Dom_x Cod_x \<chi>.natural_transformation_axioms
by (intro J_C.arr_eqI, auto)
qed
lemma cone_determines_arrow:
- assumes "J_C.ide d" and "cone J C (J_C.Fun d) a \<chi>"
+ assumes "J_C.ide d" and "cone J C (J_C.Map d) a \<chi>"
shows "arrow_from_functor C J_C.comp map a d
- (J_C.mkArr (constant_functor.map J C a) (J_C.Fun d) \<chi>)"
- and "J_C.Fun (J_C.mkArr (constant_functor.map J C a) (J_C.Fun d) \<chi>) = \<chi>"
+ (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) \<chi>)"
+ and "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) \<chi>) = \<chi>"
proof -
- interpret \<chi>: cone J C "J_C.Fun d" a \<chi> using assms(2) by auto
- let ?x = "J_C.mkArr \<chi>.A.map (J_C.Fun d) \<chi>"
+ interpret \<chi>: cone J C \<open>J_C.Map d\<close> a \<chi> using assms(2) by auto
+ let ?x = "J_C.MkArr \<chi>.A.map (J_C.Map d) \<chi>"
interpret x: arrow_from_functor C J_C.comp map a d ?x
proof
- have "\<guillemotleft>J_C.mkArr \<chi>.A.map (J_C.Fun d) \<chi> :
- J_C.mkIde \<chi>.A.map \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.mkIde (J_C.Fun d)\<guillemotright>"
- using J_C.mkArr_in_hom \<chi>.natural_transformation_axioms by simp
- moreover have "J_C.mkIde \<chi>.A.map = map a"
- using \<chi>.A.value_is_ide map_def \<chi>.A.map_def
- by (metis C.ide_char J_C.Fun_dom J_C.Fun_mkArr J_C.Dom_mkArr
- preserves_arr preserves_dom)
- moreover have "J_C.mkIde (J_C.Fun d) = d"
+ have "\<guillemotleft>J_C.MkArr \<chi>.A.map (J_C.Map d) \<chi> :
+ J_C.MkIde \<chi>.A.map \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.MkIde (J_C.Map d)\<guillemotright>"
+ using \<chi>.natural_transformation_axioms by auto
+ moreover have "J_C.MkIde \<chi>.A.map = map a"
+ using \<chi>.A.value_is_ide map_def \<chi>.A.map_def C.ide_char
+ by (metis (no_types, lifting) J_C.dom_MkArr preserves_arr preserves_dom)
+ moreover have "J_C.MkIde (J_C.Map d) = d"
using assms ide_determines_diagram(2) by simp
- ultimately show "C.ide a \<and> \<guillemotleft>J_C.mkArr \<chi>.A.map (J_C.Fun d) \<chi> : map a \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] d\<guillemotright>"
+ ultimately show "C.ide a \<and> \<guillemotleft>J_C.MkArr \<chi>.A.map (J_C.Map d) \<chi> : map a \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] d\<guillemotright>"
using \<chi>.A.value_is_ide by simp
qed
show "arrow_from_functor C J_C.comp map a d ?x" ..
- show "J_C.Fun (J_C.mkArr (constant_functor.map J C a) (J_C.Fun d) \<chi>) = \<chi>"
+ show "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) \<chi>) = \<chi>"
by (simp add: \<chi>.natural_transformation_axioms)
qed
text\<open>
Transforming a cone by composing at the apex with an arrow @{term g} corresponds,
via the preceding bijections, to composition in \<open>[J, C]\<close> with the image of @{term g}
under the diagonal functor.
\<close>
lemma cones_map_is_composition:
assumes "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>" and "cone J C D a \<chi>"
- shows "J_C.mkArr (constant_functor.map J C a') D (diagram.cones_map J C D g \<chi>)
- = J_C.mkArr (constant_functor.map J C a) D \<chi> \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
+ shows "J_C.MkArr (constant_functor.map J C a') D (diagram.cones_map J C D g \<chi>)
+ = J_C.MkArr (constant_functor.map J C a) D \<chi> \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
proof -
interpret A: constant_transformation J C a
using assms(1) by (unfold_locales, auto)
interpret \<chi>: cone J C D a \<chi> using assms(2) by auto
have cone_\<chi>: "cone J C D a \<chi>" ..
interpret A': constant_transformation J C a'
using assms(1) by (unfold_locales, auto)
let ?\<chi>' = "\<chi>.D.cones_map g \<chi>"
interpret \<chi>': cone J C D a' ?\<chi>'
using assms(1) cone_\<chi> \<chi>.D.cones_map_mapsto by blast
- let ?x = "J_C.mkArr \<chi>.A.map D \<chi>"
- let ?x' = "J_C.mkArr \<chi>'.A.map D ?\<chi>'"
+ let ?x = "J_C.MkArr \<chi>.A.map D \<chi>"
+ let ?x' = "J_C.MkArr \<chi>'.A.map D ?\<chi>'"
show "?x' = J_C.comp ?x (map g)"
proof (intro J_C.arr_eqI)
have x: "J_C.arr ?x"
using \<chi>.natural_transformation_axioms J_C.arr_char [of ?x] by simp
show x': "J_C.arr ?x'"
using \<chi>'.natural_transformation_axioms J_C.arr_char [of ?x'] by simp
- have 3: "\<guillemotleft>?x : map a \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.mkIde D\<guillemotright>"
+ have 3: "\<guillemotleft>?x : map a \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.MkIde D\<guillemotright>"
proof -
- have 1: "map a = J_C.mkIde A.map"
+ have 1: "map a = J_C.MkIde A.map"
using \<chi>.ide_apex A.equals_dom_if_value_is_ide A.equals_cod_if_value_is_ide map_def
by auto
have "J_C.arr ?x" using x by blast
moreover have "J_C.dom ?x = map a"
- using x J_C.dom_simp 1 x \<chi>.ide_apex A.equals_dom_if_value_is_ide \<chi>.D.functor_axioms
+ using x J_C.dom_char 1 x \<chi>.ide_apex A.equals_dom_if_value_is_ide \<chi>.D.functor_axioms
J_C.ide_char
by auto
- moreover have "J_C.cod ?x = J_C.mkIde D" using x J_C.cod_simp by auto
+ moreover have "J_C.cod ?x = J_C.MkIde D" using x J_C.cod_char by auto
ultimately show ?thesis by fast
qed
- have 4: "\<guillemotleft>?x' : map a' \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.mkIde D\<guillemotright>"
+ have 4: "\<guillemotleft>?x' : map a' \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.MkIde D\<guillemotright>"
proof -
- have 1: "map a' = J_C.mkIde A'.map"
+ have 1: "map a' = J_C.MkIde A'.map"
using \<chi>'.ide_apex A'.equals_dom_if_value_is_ide A'.equals_cod_if_value_is_ide map_def
by auto
have "J_C.arr ?x'" using x' by blast
moreover have "J_C.dom ?x' = map a'"
- using x' J_C.dom_simp 1 x' \<chi>'.ide_apex A'.equals_dom_if_value_is_ide \<chi>.D.functor_axioms
+ using x' J_C.dom_char 1 x' \<chi>'.ide_apex A'.equals_dom_if_value_is_ide \<chi>.D.functor_axioms
J_C.ide_char
by force
- moreover have "J_C.cod ?x' = J_C.mkIde D" using x' J_C.cod_simp by auto
+ moreover have "J_C.cod ?x' = J_C.MkIde D" using x' J_C.cod_char by auto
ultimately show ?thesis by fast
qed
have seq_xg: "J_C.seq ?x (map g)"
using assms(1) 3 preserves_hom [of g] by (intro J_C.seqI', auto)
show 2: "J_C.seq ?x (map g)"
using seq_xg J_C.seqI' by blast
show "J_C.Dom ?x' = J_C.Dom (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
proof -
have "J_C.Dom ?x' = J_C.Dom (J_C.dom ?x')"
using x' J_C.Dom_dom by simp
also have "... = J_C.Dom (map a')"
using 4 by force
also have "... = J_C.Dom (J_C.dom (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g))"
using assms(1) 2 by auto
also have "... = J_C.Dom (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
using seq_xg J_C.Dom_dom J_C.seqI' by blast
finally show ?thesis by auto
qed
show "J_C.Cod ?x' = J_C.Cod (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
proof -
have "J_C.Cod ?x' = J_C.Cod (J_C.cod ?x')"
using x' J_C.Cod_cod by simp
- also have "... = J_C.Cod (J_C.mkIde D)"
+ also have "... = J_C.Cod (J_C.MkIde D)"
using 4 by force
also have "... = J_C.Cod (J_C.cod (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g))"
using 2 3 J_C.cod_comp J_C.in_homE by metis
also have "... = J_C.Cod (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
using seq_xg J_C.Cod_cod J_C.seqI' by blast
finally show ?thesis by auto
qed
- show "J_C.Fun ?x' = J_C.Fun (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
+ show "J_C.Map ?x' = J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
proof -
interpret g: constant_transformation J C g
apply unfold_locales using assms(1) by auto
interpret \<chi>og: vertical_composite J C A'.map \<chi>.A.map D g.map \<chi>
using assms(1) C.comp_arr_dom C.comp_cod_arr A'.is_extensional g.is_extensional
apply (unfold_locales, auto)
by (elim J.seqE, auto)
- have "J_C.Fun (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g) = \<chi>og.map"
- using assms(1) 2 J_C.comp_char
- by (metis C.arrI J_C.Fun_mkArr J_C.arr_mkArr g.natural_transformation_axioms
- map_def x)
- also have "... = J_C.Fun ?x'"
+ have "J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g) = \<chi>og.map"
+ using assms(1) 2 J_C.comp_char map_def by auto
+ also have "... = J_C.Map ?x'"
using x' \<chi>og.map_def J_C.arr_char [of ?x'] natural_transformation.is_extensional
assms(1) cone_\<chi> \<chi>og.map_simp_2
by fastforce
finally show ?thesis by auto
qed
qed
qed
text\<open>
Coextension along an arrow from a functor is equivalent to a transformation of cones.
\<close>
lemma coextension_iff_cones_map:
assumes x: "arrow_from_functor C J_C.comp map a d x"
and g: "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>"
and x': "\<guillemotleft>x' : map a' \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] d\<guillemotright>"
shows "arrow_from_functor.is_coext C J_C.comp map a x a' x' g
- \<longleftrightarrow> J_C.Fun x' = diagram.cones_map J C (J_C.Fun d) g (J_C.Fun x)"
+ \<longleftrightarrow> J_C.Map x' = diagram.cones_map J C (J_C.Map d) g (J_C.Map x)"
proof -
interpret x: arrow_from_functor C J_C.comp map a d x
using assms by auto
interpret A': constant_functor J C a'
using assms(2) by (unfold_locales, auto)
have x': "arrow_from_functor C J_C.comp map a' d x'"
using A'.value_is_ide assms(3) by (unfold_locales, blast)
have d: "J_C.ide d" using J_C.ide_cod x.arrow by blast
- let ?D = "J_C.Fun d"
- let ?\<chi> = "J_C.Fun x"
- let ?\<chi>' = "J_C.Fun x'"
+ let ?D = "J_C.Map d"
+ let ?\<chi> = "J_C.Map x"
+ let ?\<chi>' = "J_C.Map x'"
interpret D: diagram J C ?D
using ide_determines_diagram J_C.ide_cod x.arrow by blast
interpret \<chi>: cone J C ?D a ?\<chi>
using assms(1) d arrow_determines_cone by simp
interpret \<gamma>: constant_transformation J C g
using g \<chi>.ide_apex by (unfold_locales, auto)
interpret \<chi>og: vertical_composite J C A'.map \<chi>.A.map ?D \<gamma>.map ?\<chi>
using g C.comp_arr_dom C.comp_cod_arr \<gamma>.is_extensional by (unfold_locales, auto)
show ?thesis
proof
assume 0: "x.is_coext a' x' g"
show "?\<chi>' = D.cones_map g ?\<chi>"
proof -
have 1: "x' = x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
using 0 x.is_coext_def by blast
- hence "?\<chi>' = J_C.Fun x'"
+ hence "?\<chi>' = J_C.Map x'"
using 0 x.is_coext_def by fast
moreover have "... = D.cones_map g ?\<chi>"
proof -
- have "J_C.mkArr A'.map (J_C.Fun d) (D.cones_map g (J_C.Fun x)) = x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
+ have "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) = x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
using d g cones_map_is_composition arrow_determines_cone(2) \<chi>.cone_axioms
x.arrow_from_functor_axioms
by auto
- hence f1: "J_C.mkArr A'.map (J_C.Fun d) (D.cones_map g (J_C.Fun x)) = x'"
+ hence f1: "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) = x'"
by (metis 1)
- have "J_C.arr (J_C.mkArr A'.map (J_C.Fun d) (D.cones_map g (J_C.Fun x)))"
+ have "J_C.arr (J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)))"
using 1 d g cones_map_is_composition preserves_arr arrow_determines_cone(2)
\<chi>.cone_axioms x.arrow_from_functor_axioms assms(3)
by auto
thus ?thesis
- using f1 J_C.Fun_mkArr by blast
+ using f1 by auto
qed
ultimately show ?thesis by blast
qed
next
assume X': "?\<chi>' = D.cones_map g ?\<chi>"
show "x.is_coext a' x' g"
proof -
have 4: "J_C.seq x (map g)"
using g x.arrow mem_Collect_eq preserves_arr preserves_cod
by (elim C.in_homE, auto)
hence 1: "x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g =
- J_C.mkArr (J_C.Dom (map g)) (J_C.Cod x)
- (vertical_composite.map J C (J_C.Fun (map g)) ?\<chi>)"
+ J_C.MkArr (J_C.Dom (map g)) (J_C.Cod x)
+ (vertical_composite.map J C (J_C.Map (map g)) ?\<chi>)"
using J_C.comp_char [of x "map g"] by simp
- have 2: "vertical_composite.map J C (J_C.Fun (map g)) ?\<chi> = \<chi>og.map"
+ have 2: "vertical_composite.map J C (J_C.Map (map g)) ?\<chi> = \<chi>og.map"
by (simp add: map_def \<gamma>.value_is_arr \<gamma>.natural_transformation_axioms)
have 3: "... = D.cones_map g ?\<chi>"
using g \<chi>og.map_simp_2 \<chi>.cone_axioms \<chi>og.is_extensional by auto
- have "J_C.mkArr A'.map ?D ?\<chi>' = J_C.comp x (map g)"
+ have "J_C.MkArr A'.map ?D ?\<chi>' = J_C.comp x (map g)"
proof -
have f1: "A'.map = J_C.Dom (map g)"
using \<gamma>.natural_transformation_axioms map_def g by auto
- have "J_C.Fun d = J_C.Cod x"
- by (metis J_C.Cod_mkArr J_C.arr_mkArr \<chi>.natural_transformation_axioms
- arrow_determines_cone(2) d x.arrow_from_functor_axioms)
+ have "J_C.Map d = J_C.Cod x"
+ using x.arrow by auto
thus ?thesis using f1 X' 1 2 3 by argo
qed
- moreover have "J_C.mkArr A'.map ?D ?\<chi>' = x'"
+ moreover have "J_C.MkArr A'.map ?D ?\<chi>' = x'"
using d x' arrow_determines_cone by blast
ultimately show ?thesis
using g x.is_coext_def by simp
qed
qed
qed
end
locale right_adjoint_to_diagonal_functor =
C: category C +
J: category J +
J_C: functor_category J C +
\<Delta>: diagonal_functor J C +
"functor" J_C.comp C G +
Adj: meta_adjunction J_C.comp C \<Delta>.map G \<phi> \<psi>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and G :: "('j, 'c) functor_category.arr \<Rightarrow> 'c"
and \<phi> :: "'c \<Rightarrow> ('j, 'c) functor_category.arr \<Rightarrow> 'c"
and \<psi> :: "('j, 'c) functor_category.arr \<Rightarrow> 'c \<Rightarrow> ('j, 'c) functor_category.arr" +
assumes adjoint: "adjoint_functors J_C.comp C \<Delta>.map G"
begin
text\<open>
A right adjoint @{term G} to a diagonal functor maps each object @{term d} of
\<open>[J, C]\<close> (corresponding to a diagram @{term D} of shape @{term J} in @{term C}
to an object of @{term C}. This object is the limit object, and the component at @{term d}
of the counit of the adjunction determines the limit cone.
\<close>
lemma gives_limit_cones:
assumes "diagram J C D"
- shows "limit_cone J C D (G (J_C.mkIde D)) (J_C.Fun (Adj.\<epsilon> (J_C.mkIde D)))"
+ shows "limit_cone J C D (G (J_C.MkIde D)) (J_C.Map (Adj.\<epsilon> (J_C.MkIde D)))"
proof -
interpret D: diagram J C D using assms by auto
- let ?d = "J_C.mkIde D"
+ let ?d = "J_C.MkIde D"
let ?a = "G ?d"
let ?x = "Adj.\<epsilon> ?d"
- let ?\<chi> = "J_C.Fun ?x"
+ let ?\<chi> = "J_C.Map ?x"
have "diagram J C D" ..
hence 1: "J_C.ide ?d" using \<Delta>.diagram_determines_ide by auto
- hence 2: "J_C.Fun (J_C.mkIde D) = D"
- using assms 1 J_C.Fun_mkArr J_C.in_homE \<Delta>.diagram_determines_ide(2) by simp
+ hence 2: "J_C.Map (J_C.MkIde D) = D"
+ using assms 1 J_C.in_homE \<Delta>.diagram_determines_ide(2) by simp
interpret x: terminal_arrow_from_functor C J_C.comp \<Delta>.map ?a ?d ?x
apply unfold_locales
apply (metis (no_types, lifting) "1" preserves_ide Adj.\<epsilon>_in_terms_of_\<psi>
Adj.\<epsilon>o_def Adj.\<epsilon>o_in_hom)
by (metis 1 Adj.has_terminal_arrows_from_functor(1)
terminal_arrow_from_functor.is_terminal)
have 3: "arrow_from_functor C J_C.comp \<Delta>.map ?a ?d ?x" ..
interpret \<chi>: cone J C D ?a ?\<chi>
using 1 2 3 \<Delta>.arrow_determines_cone [of ?d] by auto
have cone_\<chi>: "D.cone ?a ?\<chi>" ..
interpret \<chi>: limit_cone J C D ?a ?\<chi>
proof
fix a' \<chi>'
assume cone_\<chi>': "D.cone a' \<chi>'"
interpret \<chi>': cone J C D a' \<chi>' using cone_\<chi>' by auto
- let ?x' = "J_C.mkArr \<chi>'.A.map D \<chi>'"
+ let ?x' = "J_C.MkArr \<chi>'.A.map D \<chi>'"
interpret x': arrow_from_functor C J_C.comp \<Delta>.map a' ?d ?x'
using 1 2 by (metis \<Delta>.cone_determines_arrow(1) cone_\<chi>')
have "arrow_from_functor C J_C.comp \<Delta>.map a' ?d ?x'" ..
hence 4: "\<exists>!g. x.is_coext a' ?x' g"
using x.is_terminal by simp
have 5: "\<And>g. \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright> \<Longrightarrow> x.is_coext a' ?x' g \<longleftrightarrow> D.cones_map g ?\<chi> = \<chi>'"
proof -
fix g
assume g: "\<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright>"
show "x.is_coext a' ?x' g \<longleftrightarrow> D.cones_map g ?\<chi> = \<chi>'"
proof -
have "\<guillemotleft>?x' : \<Delta>.map a' \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] ?d\<guillemotright>"
using x'.arrow by simp
thus ?thesis
using 3 g \<Delta>.coextension_iff_cones_map [of ?a ?d]
by (metis (no_types, lifting) 1 2 \<Delta>.cone_determines_arrow(2) cone_\<chi>')
qed
qed
have 6: "\<And>g. x.is_coext a' ?x' g \<Longrightarrow> \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright>"
using x.is_coext_def by simp
show "\<exists>!g. \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright> \<and> D.cones_map g ?\<chi> = \<chi>'"
proof -
have "\<exists>g. \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright> \<and> D.cones_map g ?\<chi> = \<chi>'"
using 4 5 6 by meson
thus ?thesis
using 4 5 6 by blast
qed
qed
show "D.limit_cone ?a ?\<chi>" ..
qed
corollary gives_limits:
assumes "diagram J C D"
- shows "diagram.has_as_limit J C D (G (J_C.mkIde D))"
+ shows "diagram.has_as_limit J C D (G (J_C.MkIde D))"
using assms gives_limit_cones by fastforce
end
lemma (in category) has_limits_iff_left_adjoint_diagonal:
assumes "category J"
shows "has_limits_of_shape J \<longleftrightarrow>
left_adjoint_functor C (functor_category.comp J C) (diagonal_functor.map J C)"
proof -
interpret J: category J using assms by auto
interpret J_C: functor_category J C ..
interpret \<Delta>: diagonal_functor J C ..
show ?thesis
proof
assume A: "left_adjoint_functor C J_C.comp \<Delta>.map"
interpret \<Delta>: left_adjoint_functor C J_C.comp \<Delta>.map using A by auto
interpret Adj: meta_adjunction J_C.comp C \<Delta>.map \<Delta>.G \<Delta>.\<phi> \<Delta>.\<psi>
using \<Delta>.induces_meta_adjunction by auto
have "meta_adjunction J_C.comp C \<Delta>.map \<Delta>.G \<Delta>.\<phi> \<Delta>.\<psi>" ..
hence 1: "adjoint_functors J_C.comp C \<Delta>.map \<Delta>.G"
using adjoint_functors_def by blast
interpret G: right_adjoint_to_diagonal_functor J C \<Delta>.G \<Delta>.\<phi> \<Delta>.\<psi>
using 1 by (unfold_locales, auto)
have "\<And>D. diagram J C D \<Longrightarrow> \<exists>a. diagram.has_as_limit J C D a"
using A G.gives_limits by blast
hence "\<And>D. diagram J C D \<Longrightarrow> \<exists>a \<chi>. limit_cone J C D a \<chi>"
by metis
thus "has_limits_of_shape J" using has_limits_of_shape_def by blast
next
text\<open>
If @{term "has_limits J"}, then every diagram @{term D} from @{term J} to
@{term[source=true] C} has a limit cone.
This means that, for every object @{term d} of the functor category
\<open>[J, C]\<close>, there exists an object @{term a} of @{term C} and a terminal arrow from
\<open>\<Delta> a\<close> to @{term d} in \<open>[J, C]\<close>. The terminal arrow is given by the
limit cone.
\<close>
assume A: "has_limits_of_shape J"
show "left_adjoint_functor C J_C.comp \<Delta>.map"
proof
fix d
assume D: "J_C.ide d"
- interpret D: diagram J C "J_C.Fun d"
+ interpret D: diagram J C \<open>J_C.Map d\<close>
using D \<Delta>.ide_determines_diagram by auto
- let ?D = "J_C.Fun d"
- have "diagram J C (J_C.Fun d)" ..
+ let ?D = "J_C.Map d"
+ have "diagram J C (J_C.Map d)" ..
from this obtain a \<chi> where limit: "limit_cone J C ?D a \<chi>"
using A has_limits_of_shape_def by blast
+ interpret A: constant_functor J C a
+ using limit by (simp add: Limit.cone_def limit_cone_def)
interpret \<chi>: limit_cone J C ?D a \<chi> using limit by auto
have cone_\<chi>: "cone J C ?D a \<chi>" ..
- let ?x = "J_C.mkArr \<chi>.A.map ?D \<chi>"
+ let ?x = "J_C.MkArr A.map ?D \<chi>"
interpret x: arrow_from_functor C J_C.comp \<Delta>.map a d ?x
using D cone_\<chi> \<Delta>.cone_determines_arrow by auto
have "terminal_arrow_from_functor C J_C.comp \<Delta>.map a d ?x"
proof
show "\<And>a' x'. arrow_from_functor C J_C.comp \<Delta>.map a' d x' \<Longrightarrow> \<exists>!g. x.is_coext a' x' g"
- proof
+ proof -
fix a' x'
assume x': "arrow_from_functor C J_C.comp \<Delta>.map a' d x'"
interpret x': arrow_from_functor C J_C.comp \<Delta>.map a' d x' using x' by auto
interpret A': constant_functor J C a'
by (unfold_locales, simp add: x'.arrow)
- let ?\<chi>' = "J_C.Fun x'"
+ let ?\<chi>' = "J_C.Map x'"
interpret \<chi>': cone J C ?D a' ?\<chi>'
using D x' \<Delta>.arrow_determines_cone by auto
have cone_\<chi>': "cone J C ?D a' ?\<chi>'" ..
let ?g = "\<chi>.induced_arrow a' ?\<chi>'"
- show "x.is_coext a' x' ?g"
- proof (unfold x.is_coext_def)
- have 1: "\<guillemotleft>?g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map ?g \<chi> = ?\<chi>'"
- using \<chi>.induced_arrow_def \<chi>.is_universal cone_\<chi>'
- theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = ?\<chi>'"]
- by presburger
- hence 2: "x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map ?g"
- proof -
- have "x' = J_C.mkArr A'.map ?D ?\<chi>'"
- using D \<Delta>.arrow_determines_cone(2) x'.arrow_from_functor_axioms by auto
- thus ?thesis
- using 1 cone_\<chi> \<Delta>.cones_map_is_composition [of ?g a' a ?D \<chi>] by simp
+ show "\<exists>!g. x.is_coext a' x' g"
+ proof
+ show "x.is_coext a' x' ?g"
+ proof (unfold x.is_coext_def)
+ have 1: "\<guillemotleft>?g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map ?g \<chi> = ?\<chi>'"
+ using \<chi>.induced_arrow_def \<chi>.is_universal cone_\<chi>'
+ theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = ?\<chi>'"]
+ by presburger
+ hence 2: "x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map ?g"
+ proof -
+ have "x' = J_C.MkArr A'.map ?D ?\<chi>'"
+ using D \<Delta>.arrow_determines_cone(2) x'.arrow_from_functor_axioms by auto
+ thus ?thesis
+ using 1 cone_\<chi> \<Delta>.cones_map_is_composition [of ?g a' a ?D \<chi>] by simp
+ qed
+ show "\<guillemotleft>?g : a' \<rightarrow> a\<guillemotright> \<and> x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map ?g"
+ using 1 2 by auto
qed
- show "\<guillemotleft>?g : a' \<rightarrow> a\<guillemotright> \<and> x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map ?g"
- using 1 2 by auto
- qed
- next
- fix a' x' g
- assume A: "arrow_from_functor C J_C.comp \<Delta>.map a' d x'"
- and X: "x.is_coext a' x' g"
- let ?\<chi>' = "J_C.Fun x'"
- interpret \<chi>': cone J C "J_C.Fun d" a' ?\<chi>'
- using D A \<Delta>.arrow_determines_cone by auto
- have cone_\<chi>': "cone J C (J_C.Fun d) a' ?\<chi>'" ..
- let ?g = "\<chi>.induced_arrow a' ?\<chi>'"
- show "g = ?g"
- proof -
- have "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map g \<chi> = ?\<chi>'"
- proof
- show G: "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>" using X x.is_coext_def by blast
- show "D.cones_map g \<chi> = ?\<chi>'"
- proof -
- have 1: "x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map g"
- using X x.is_coext_def by blast
- hence "?\<chi>' = J_C.Fun (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map g)"
- using X x.is_coext_def by fast
- also have "... = D.cones_map g \<chi>"
- using 1 G cone_\<chi> \<Delta>.cones_map_is_composition
- by (metis (no_types, lifting) A D J_C.Fun_mkArr J_C.arr_mkArr
- \<Delta>.arrow_determines_cone(2) \<chi>'.natural_transformation_axioms)
- finally show ?thesis by auto
+ next
+ fix g
+ assume X: "x.is_coext a' x' g"
+ show "g = ?g"
+ proof -
+ have "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map g \<chi> = ?\<chi>'"
+ proof
+ show G: "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>" using X x.is_coext_def by blast
+ show "D.cones_map g \<chi> = ?\<chi>'"
+ proof -
+ have "?\<chi>' = J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map g)"
+ using X x.is_coext_def [of a' x' g] by fast
+ also have "... = D.cones_map g \<chi>"
+ proof -
+ interpret map_g: constant_transformation J C g
+ using G by (unfold_locales, auto)
+ interpret \<chi>': vertical_composite J C
+ map_g.F.map A.map \<open>\<chi>.\<Phi>.Ya.Cop_S.Map d\<close>
+ map_g.map \<chi>
+ proof (intro_locales)
+ have "map_g.G.map = A.map"
+ using G by blast
+ thus "natural_transformation_axioms J (\<cdot>) map_g.F.map A.map map_g.map"
+ using map_g.natural_transformation_axioms
+ by (simp add: natural_transformation_def)
+ qed
+ have "J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map g) = vertical_composite.map J C map_g.map \<chi>"
+ proof -
+ have "J_C.seq ?x (\<Delta>.map g)"
+ using G x.arrow by auto
+ thus ?thesis
+ using G \<Delta>.map_def J_C.Map_comp' [of ?x "\<Delta>.map g"] by auto
+ qed
+ also have "... = D.cones_map g \<chi>"
+ using G cone_\<chi> \<chi>'.map_def map_g.map_def \<chi>.is_natural_2 \<chi>'.map_simp_2
+ by auto
+ finally show ?thesis by blast
+ qed
+ finally show ?thesis by auto
+ qed
qed
+ thus ?thesis
+ using cone_\<chi>' \<chi>.is_universal \<chi>.induced_arrow_def
+ theI_unique [of "\<lambda>g. \<guillemotleft>g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map g \<chi> = ?\<chi>'" g]
+ by presburger
qed
- thus ?thesis
- using cone_\<chi>' \<chi>.is_universal \<chi>.induced_arrow_def
- theI_unique [of "\<lambda>g. \<guillemotleft>g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map g \<chi> = ?\<chi>'" g]
- by presburger
qed
qed
qed
thus "\<exists>a x. terminal_arrow_from_functor C J_C.comp \<Delta>.map a d x" by auto
qed
qed
qed
section "Right Adjoint Functors Preserve Limits"
context right_adjoint_functor
begin
lemma preserves_limits:
fixes J :: "'j comp"
assumes "diagram J C E" and "diagram.has_as_limit J C E a"
shows "diagram.has_as_limit J D (G o E) (G a)"
proof -
text\<open>
From the assumption that @{term E} has a limit, obtain a limit cone @{term \<chi>}.
\<close>
interpret J: category J using assms(1) diagram_def by auto
interpret E: diagram J C E using assms(1) by auto
from assms(2) obtain \<chi> where \<chi>: "limit_cone J C E a \<chi>" by auto
interpret \<chi>: limit_cone J C E a \<chi> using \<chi> by auto
have a: "C.ide a" using \<chi>.ide_apex by auto
text\<open>
Form the @{term E}-image \<open>GE\<close> of the diagram @{term E}.
\<close>
interpret GE: composite_functor J C D E G ..
interpret GE: diagram J D GE.map ..
text\<open>Let \<open>G\<chi>\<close> be the @{term G}-image of the cone @{term \<chi>},
and note that it is a cone over \<open>GE\<close>.\<close>
let ?G\<chi> = "G o \<chi>"
- interpret G\<chi>: cone J D GE.map "G a" ?G\<chi>
+ interpret G\<chi>: cone J D GE.map \<open>G a\<close> ?G\<chi>
using \<chi>.cone_axioms preserves_cones by blast
text\<open>
Claim that \<open>G\<chi>\<close> is a limit cone for diagram \<open>GE\<close>.
\<close>
- interpret G\<chi>: limit_cone J D GE.map "G a" ?G\<chi>
+ interpret G\<chi>: limit_cone J D GE.map \<open>G a\<close> ?G\<chi>
proof
text \<open>
Let @{term \<kappa>} be an arbitrary cone over \<open>GE\<close>.
\<close>
fix b \<kappa>
assume \<kappa>: "GE.cone b \<kappa>"
interpret \<kappa>: cone J D GE.map b \<kappa> using \<kappa> by auto
- interpret Fb: constant_functor J C "F b"
+ interpret Fb: constant_functor J C \<open>F b\<close>
apply unfold_locales
by (meson F_is_functor \<kappa>.ide_apex functor.preserves_ide)
interpret Adj: meta_adjunction C D F G \<phi> \<psi>
using induces_meta_adjunction by auto
text\<open>
For each arrow @{term j} of @{term J}, let @{term "\<chi>' j"} be defined to be
the adjunct of @{term "\<chi> j"}. We claim that @{term \<chi>'} is a cone over @{term E}.
\<close>
let ?\<chi>' = "\<lambda>j. if J.arr j then Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j) else C.null"
have cone_\<chi>': "E.cone (F b) ?\<chi>'"
proof
show "\<And>j. \<not>J.arr j \<Longrightarrow> ?\<chi>' j = C.null" by simp
fix j
assume j: "J.arr j"
show "C.dom (?\<chi>' j) = Fb.map (J.dom j)" using j \<psi>_in_hom by simp
show "C.cod (?\<chi>' j) = E (J.cod j)" using j \<psi>_in_hom by simp
show "E j \<cdot>\<^sub>C ?\<chi>' (J.dom j) = ?\<chi>' j"
proof -
have "E j \<cdot>\<^sub>C ?\<chi>' (J.dom j) = (E j \<cdot>\<^sub>C Adj.\<epsilon> (E (J.dom j))) \<cdot>\<^sub>C F (\<kappa> (J.dom j))"
using j C.comp_assoc by simp
also have "... = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> j)"
proof -
have "(E j \<cdot>\<^sub>C Adj.\<epsilon> (E (J.dom j))) \<cdot>\<^sub>C F (\<kappa> (J.dom j))
= (Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C Adj.FG.map (E j)) \<cdot>\<^sub>C F (\<kappa> (J.dom j))"
using j Adj.\<epsilon>.naturality [of "E j"] by fastforce
also have "... = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C Adj.FG.map (E j) \<cdot>\<^sub>C F (\<kappa> (J.dom j))"
using C.comp_assoc by simp
also have "... = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> j)"
proof -
have "Adj.FG.map (E j) \<cdot>\<^sub>C F (\<kappa> (J.dom j)) = F (GE.map j \<cdot>\<^sub>D \<kappa> (J.dom j))"
using j by simp
hence "Adj.FG.map (E j) \<cdot>\<^sub>C F (\<kappa> (J.dom j)) = F (\<kappa> j)"
using j \<kappa>.is_natural_1 by metis
thus ?thesis using j by simp
qed
finally show ?thesis by auto
qed
also have "... = ?\<chi>' j"
using j by simp
finally show ?thesis by auto
qed
show "?\<chi>' (J.cod j) \<cdot>\<^sub>C Fb.map j = ?\<chi>' j"
proof -
have "?\<chi>' (J.cod j) \<cdot>\<^sub>C Fb.map j = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> (J.cod j))"
using j Fb.value_is_ide Adj.\<epsilon>.preserves_hom C.comp_arr_dom [of "F (\<kappa> (J.cod j))"]
C.comp_assoc
by simp
also have "... = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> j)"
using j \<kappa>.is_natural_1 \<kappa>.is_natural_2 Adj.\<epsilon>.naturality J.arr_cod_iff_arr
by (metis J.cod_cod \<kappa>.A.map_simp)
also have "... = ?\<chi>' j" using j by simp
finally show ?thesis by auto
qed
qed
text\<open>
Using the universal property of the limit cone @{term \<chi>}, obtain the unique arrow
@{term f} that transforms @{term \<chi>} into @{term \<chi>'}.
\<close>
from this \<chi>.is_universal [of "F b" ?\<chi>'] obtain f
where f: "\<guillemotleft>f : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map f \<chi> = ?\<chi>'"
by auto
text\<open>
Let @{term g} be the adjunct of @{term f}, and show that @{term g} transforms
@{term G\<chi>} into @{term \<kappa>}.
\<close>
let ?g = "G f \<cdot>\<^sub>D Adj.\<eta> b"
have 1: "\<guillemotleft>?g : b \<rightarrow>\<^sub>D G a\<guillemotright>" using f \<kappa>.ide_apex by fastforce
moreover have "GE.cones_map ?g ?G\<chi> = \<kappa>"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> GE.cones_map ?g ?G\<chi> j = \<kappa> j"
using 1 G\<chi>.cone_axioms \<kappa>.is_extensional by auto
moreover have "J.arr j \<Longrightarrow> GE.cones_map ?g ?G\<chi> j = \<kappa> j"
proof -
fix j
assume j: "J.arr j"
have "GE.cones_map ?g ?G\<chi> j = G (\<chi> j) \<cdot>\<^sub>D ?g"
using j 1 G\<chi>.cone_axioms mem_Collect_eq restrict_apply by auto
also have "... = G (\<chi> j \<cdot>\<^sub>C f) \<cdot>\<^sub>D Adj.\<eta> b"
using j f \<chi>.preserves_hom [of j "J.dom j" "J.cod j"] D.comp_assoc by fastforce
also have "... = G (E.cones_map f \<chi> j) \<cdot>\<^sub>D Adj.\<eta> b"
proof -
have "\<chi> j \<cdot>\<^sub>C f = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j)"
proof -
have "E.cone (C.cod f) \<chi>"
using f \<chi>.cone_axioms by blast
hence "\<chi> j \<cdot>\<^sub>C f = E.cones_map f \<chi> j"
using \<chi>.is_extensional by simp
also have "... = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j)"
using j f by simp
finally show ?thesis by blast
qed
thus ?thesis
using f mem_Collect_eq restrict_apply Adj.F.is_extensional by simp
qed
also have "... = (G (Adj.\<epsilon> (C.cod (E j))) \<cdot>\<^sub>D Adj.\<eta> (D.cod (GE.map j))) \<cdot>\<^sub>D \<kappa> j"
using j f Adj.\<eta>.naturality [of "\<kappa> j"] D.comp_assoc by auto
also have "... = D.cod (\<kappa> j) \<cdot>\<^sub>D \<kappa> j"
using j Adj.\<eta>\<epsilon>.triangle_G Adj.\<epsilon>_in_terms_of_\<psi> Adj.\<epsilon>o_def
Adj.\<eta>_in_terms_of_\<phi> Adj.\<eta>o_def Adj.unit_counit_G
by fastforce
also have "... = \<kappa> j"
using j D.comp_cod_arr by simp
finally show "GE.cones_map ?g ?G\<chi> j = \<kappa> j" by metis
qed
ultimately show "GE.cones_map ?g ?G\<chi> j = \<kappa> j" by auto
qed
ultimately have "\<guillemotleft>?g : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map ?g ?G\<chi> = \<kappa>" by auto
text\<open>
It remains to be shown that @{term g} is the unique such arrow.
Given any @{term g'} that transforms @{term G\<chi>} into @{term \<kappa>},
its adjunct transforms @{term \<chi>} into @{term \<chi>'}.
The adjunct of @{term g'} is therefore equal to @{term f},
which implies @{term g'} = @{term g}.
\<close>
moreover have "\<And>g'. \<guillemotleft>g' : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map g' ?G\<chi> = \<kappa> \<Longrightarrow> g' = ?g"
proof -
fix g'
assume g': "\<guillemotleft>g' : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map g' ?G\<chi> = \<kappa>"
have 1: "\<guillemotleft>\<psi> a g' : F b \<rightarrow>\<^sub>C a\<guillemotright>"
using g' a \<psi>_in_hom by simp
have 2: "E.cones_map (\<psi> a g') \<chi> = ?\<chi>'"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j"
using 1 \<chi>.cone_axioms by auto
moreover have "J.arr j \<Longrightarrow> E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j"
proof -
fix j
assume j: "J.arr j"
have "E.cones_map (\<psi> a g') \<chi> j = \<chi> j \<cdot>\<^sub>C \<psi> a g'"
using 1 \<chi>.cone_axioms \<chi>.is_extensional by auto
also have "... = (\<chi> j \<cdot>\<^sub>C Adj.\<epsilon> a) \<cdot>\<^sub>C F g'"
- using j a g' Adj.\<psi>_in_terms_of_\<epsilon> C.comp_assoc by force
+ using j a g' Adj.\<psi>_in_terms_of_\<epsilon> C.comp_assoc Adj.\<epsilon>_def by auto
also have "... = (Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (G (\<chi> j))) \<cdot>\<^sub>C F g'"
using j a g' Adj.\<epsilon>.naturality [of "\<chi> j"] by simp
also have "... = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j)"
using j a g' G\<chi>.cone_axioms C.comp_assoc by auto
finally show "E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j" by (simp add: j)
qed
ultimately show "E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j" by auto
qed
have "\<psi> a g' = f"
proof -
have "\<exists>!f. \<guillemotleft>f : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map f \<chi> = ?\<chi>'"
using cone_\<chi>' \<chi>.is_universal by simp
moreover have "\<guillemotleft>\<psi> a g' : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map (\<psi> a g') \<chi> = ?\<chi>'"
using 1 2 by simp
ultimately show ?thesis
using ex1E [of "\<lambda>f. \<guillemotleft>f : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map f \<chi> = ?\<chi>'" "\<psi> a g' = f"]
using 1 2 Adj.\<epsilon>.is_extensional C.comp_null(2) C.ex_un_null \<chi>.cone_axioms f
mem_Collect_eq restrict_apply
by blast
qed
hence "\<phi> b (\<psi> a g') = \<phi> b f" by auto
hence "g' = \<phi> b f" using \<chi>.ide_apex g' by (simp add: \<phi>_\<psi>)
- moreover have "?g = \<phi> b f" using f Adj.\<phi>_in_terms_of_\<eta> \<kappa>.ide_apex by auto
+ moreover have "?g = \<phi> b f" using f Adj.\<phi>_in_terms_of_\<eta> \<kappa>.ide_apex Adj.\<eta>_def by auto
ultimately show "g' = ?g" by argo
qed
ultimately show "\<exists>!g. \<guillemotleft>g : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map g ?G\<chi> = \<kappa>" by blast
qed
have "GE.limit_cone (G a) ?G\<chi>" ..
thus ?thesis by auto
qed
end
section "Special Kinds of Limits"
subsection "Terminal Objects"
text\<open>
An object of a category @{term C} is a terminal object if and only if it is a limit of the
empty diagram in @{term C}.
\<close>
locale empty_diagram =
diagram J C D
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c" +
assumes is_empty: "\<not>J.arr j"
begin
lemma has_as_limit_iff_terminal:
shows "has_as_limit a \<longleftrightarrow> C.terminal a"
proof
assume a: "has_as_limit a"
show "C.terminal a"
proof
have "\<exists>\<chi>. limit_cone a \<chi>" using a by auto
from this obtain \<chi> where \<chi>: "limit_cone a \<chi>" by blast
interpret \<chi>: limit_cone J C D a \<chi> using \<chi> by auto
have cone_\<chi>: "cone a \<chi>" ..
show "C.ide a" using \<chi>.ide_apex by auto
have 1: "\<chi> = (\<lambda>j. C.null)" using is_empty \<chi>.is_extensional by auto
show "\<And>a'. C.ide a' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>"
proof -
fix a'
assume a': "C.ide a'"
interpret A': constant_functor J C a'
apply unfold_locales using a' by auto
let ?\<chi>' = "\<lambda>j. C.null"
have cone_\<chi>': "cone a' ?\<chi>'"
using a' is_empty apply unfold_locales by auto
hence "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> cones_map f \<chi> = ?\<chi>'"
using \<chi>.is_universal by force
moreover have "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> cones_map f \<chi> = ?\<chi>'"
using 1 cone_\<chi> by auto
ultimately show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" by blast
qed
qed
next
assume a: "C.terminal a"
show "has_as_limit a"
proof -
let ?\<chi> = "\<lambda>j. C.null"
have "C.ide a" using a C.terminal_def by simp
interpret A: constant_functor J C a
apply unfold_locales using \<open>C.ide a\<close> by simp
interpret \<chi>: cone J C D a ?\<chi>
using \<open>C.ide a\<close> is_empty by (unfold_locales, auto)
have cone_\<chi>: "cone a ?\<chi>" ..
have 1: "\<And>a' \<chi>'. cone a' \<chi>' \<Longrightarrow> \<chi>' = (\<lambda>j. C.null)"
proof -
fix a' \<chi>'
assume \<chi>': "cone a' \<chi>'"
interpret \<chi>': cone J C D a' \<chi>' using \<chi>' by auto
show "\<chi>' = (\<lambda>j. C.null)"
using is_empty \<chi>'.is_extensional by metis
qed
have "limit_cone a ?\<chi>"
proof
fix a' \<chi>'
assume \<chi>': "cone a' \<chi>'"
have 2: "\<chi>' = (\<lambda>j. C.null)" using 1 \<chi>' by simp
interpret \<chi>': cone J C D a' \<chi>' using \<chi>' by auto
have "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" using a C.terminal_def \<chi>'.ide_apex by simp
moreover have "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> cones_map f ?\<chi> = \<chi>'"
using 1 2 cones_map_mapsto cone_\<chi> \<chi>'.cone_axioms mem_Collect_eq by blast
ultimately show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> cones_map f (\<lambda>j. C.null) = \<chi>'"
by blast
qed
thus ?thesis by auto
qed
qed
end
subsection "Products"
text\<open>
A \emph{product} in a category @{term C} is a limit of a discrete diagram in @{term C}.
\<close>
locale discrete_diagram =
J: category J +
diagram J C D
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c" +
assumes is_discrete: "J.arr = J.ide"
begin
abbreviation mkCone
where "mkCone F \<equiv> (\<lambda>j. if J.arr j then F j else C.null)"
lemma cone_mkCone:
assumes "C.ide a" and "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>F j : a \<rightarrow> D j\<guillemotright>"
shows "cone a (mkCone F)"
proof -
interpret A: constant_functor J C a
apply unfold_locales using assms(1) by auto
show "cone a (mkCone F)"
using assms(2) is_discrete
apply unfold_locales
apply auto
apply (metis C.in_homE C.comp_cod_arr)
using C.comp_arr_ide by fastforce
qed
lemma mkCone_cone:
assumes "cone a \<pi>"
shows "mkCone \<pi> = \<pi>"
proof -
interpret \<pi>: cone J C D a \<pi>
using assms by auto
show "mkCone \<pi> = \<pi>" using \<pi>.is_extensional by auto
qed
end
text\<open>
The following locale defines a discrete diagram in a category @{term C},
given an index set @{term I} and a function @{term D} mapping @{term I}
to objects of @{term C}. Here we obtain the diagram shape @{term J}
using a discrete category construction that allows us to directly identify
the objects of @{term J} with the elements of @{term I}, however this construction
can only be applied in case the set @{term I} is not the universe of its
element type.
\<close>
locale discrete_diagram_from_map =
J: discrete_category I null +
C: category C
for I :: "'i set"
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'i \<Rightarrow> 'c"
and null :: 'i +
assumes maps_to_ide: "i \<in> I \<Longrightarrow> C.ide (D i)"
begin
definition map
where "map j \<equiv> if J.arr j then D j else C.null"
end
sublocale discrete_diagram_from_map \<subseteq> discrete_diagram J.comp C map
using map_def maps_to_ide J.arr_char J.Null_not_in_Obj J.null_char
by (unfold_locales, auto)
locale product_cone =
J: category J +
C: category C +
D: discrete_diagram J C D +
limit_cone J C D a \<pi>
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and C :: "'c comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 'c"
and a :: 'c
and \<pi> :: "'j \<Rightarrow> 'c"
begin
lemma is_cone:
shows "D.cone a \<pi>" ..
text\<open>
The following versions of @{prop is_universal} and @{prop induced_arrowI}
from the \<open>limit_cone\<close> locale are specialized to the case in which the
underlying diagram is a product diagram.
\<close>
lemma is_universal':
assumes "C.ide b" and "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>F j: b \<rightarrow> D j\<guillemotright>"
shows "\<exists>!f. \<guillemotleft>f : b \<rightarrow> a\<guillemotright> \<and> (\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j)"
proof -
let ?\<chi> = "D.mkCone F"
interpret B: constant_functor J C b
apply unfold_locales using assms(1) by auto
have cone_\<chi>: "D.cone b ?\<chi>"
using assms D.is_discrete
apply unfold_locales
apply auto
apply (meson C.comp_ide_arr C.ide_in_hom C.seqI' D.preserves_ide)
using C.comp_arr_dom by blast
interpret \<chi>: cone J C D b ?\<chi> using cone_\<chi> by auto
have "\<exists>!f. \<guillemotleft>f : b \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<pi> = ?\<chi>"
using cone_\<chi> is_universal by force
moreover have
"\<And>f. \<guillemotleft>f : b \<rightarrow> a\<guillemotright> \<Longrightarrow> D.cones_map f \<pi> = ?\<chi> \<longleftrightarrow> (\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j)"
proof -
fix f
assume f: "\<guillemotleft>f : b \<rightarrow> a\<guillemotright>"
show "D.cones_map f \<pi> = ?\<chi> \<longleftrightarrow> (\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j)"
proof
assume 1: "D.cones_map f \<pi> = ?\<chi>"
show "\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j"
proof -
have "\<And>j. J.arr j \<Longrightarrow> \<pi> j \<cdot> f = F j"
proof -
fix j
assume j: "J.arr j"
have "\<pi> j \<cdot> f = D.cones_map f \<pi> j"
using j f cone_axioms by force
also have "... = F j" using j 1 by simp
finally show "\<pi> j \<cdot> f = F j" by auto
qed
thus ?thesis by auto
qed
next
assume 1: "\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j"
show "D.cones_map f \<pi> = ?\<chi>"
using 1 f is_cone \<chi>.is_extensional D.is_discrete is_cone cone_\<chi> by auto
qed
qed
ultimately show ?thesis by blast
qed
abbreviation induced_arrow' :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) \<Rightarrow> 'c"
where "induced_arrow' b F \<equiv> induced_arrow b (D.mkCone F)"
lemma induced_arrowI':
assumes "C.ide b" and "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>F j : b \<rightarrow> D j\<guillemotright>"
shows "\<And>j. J.arr j \<Longrightarrow> \<pi> j \<cdot> induced_arrow' b F = F j"
proof -
interpret B: constant_functor J C b
apply unfold_locales using assms(1) by auto
- interpret \<chi>: cone J C D b "D.mkCone F"
+ interpret \<chi>: cone J C D b \<open>D.mkCone F\<close>
using assms D.cone_mkCone by blast
have cone_\<chi>: "D.cone b (D.mkCone F)" ..
hence 1: "D.cones_map (induced_arrow' b F) \<pi> = D.mkCone F"
using induced_arrowI by blast
fix j
assume j: "J.arr j"
have "\<pi> j \<cdot> induced_arrow' b F = D.cones_map (induced_arrow' b F) \<pi> j"
using induced_arrowI(1) cone_\<chi> is_cone is_extensional by force
also have "... = F j"
using j 1 by auto
finally show "\<pi> j \<cdot> induced_arrow' b F = F j"
by auto
qed
end
context discrete_diagram
begin
lemma product_coneI:
assumes "limit_cone a \<pi>"
shows "product_cone J C D a \<pi>"
proof -
interpret L: limit_cone J C D a \<pi>
using assms by auto
show "product_cone J C D a \<pi>" ..
qed
end
context category
begin
definition has_as_product
where "has_as_product J D a \<equiv> (\<exists>\<pi>. product_cone J C D a \<pi>)"
text\<open>
A category has @{term I}-indexed products for an @{typ 'i}-set @{term I}
if every @{term I}-indexed discrete diagram has a product.
In order to reap the benefits of being able to directly identify the elements
of a set I with the objects of discrete category it generates (thereby avoiding
the use of coercion maps), it is necessary to assume that @{term "I \<noteq> UNIV"}.
If we want to assert that a category has products indexed by the universe of
some type @{typ 'i}, we have to pass to a larger type, such as @{typ "'i option"}.
\<close>
definition has_products
where "has_products (I :: 'i set) \<equiv>
I \<noteq> UNIV \<and>
(\<forall>J D. discrete_diagram J C D \<and> Collect (partial_magma.arr J) = I
\<longrightarrow> (\<exists>a. has_as_product J D a))"
lemma ex_productE:
assumes "\<exists>a. has_as_product J D a"
obtains a \<pi> where "product_cone J C D a \<pi>"
using assms has_as_product_def someI_ex [of "\<lambda>a. has_as_product J D a"] by metis
lemma has_products_if_has_limits:
assumes "has_limits (undefined :: 'j)" and "I \<noteq> (UNIV :: 'j set)"
shows "has_products I"
proof -
have "\<And>J D. \<lbrakk> discrete_diagram J C D; Collect (partial_magma.arr J) = I \<rbrakk>
\<Longrightarrow> (\<exists>a. has_as_product J D a)"
proof -
fix J :: "'j comp" and D
assume D: "discrete_diagram J C D"
interpret J: category J
using D discrete_diagram.axioms by auto
interpret D: discrete_diagram J C D
using D by auto
assume J: "Collect J.arr = I"
obtain a \<pi> where \<pi>: "D.limit_cone a \<pi>"
using assms(1) J has_limits_def has_limits_of_shape_def [of J]
D.diagram_axioms J.category_axioms
by metis
have "product_cone J C D a \<pi>"
using \<pi> D.product_coneI by auto
hence "has_as_product J D a"
using has_as_product_def by blast
thus "\<exists>a. has_as_product J D a"
by auto
qed
thus ?thesis
unfolding has_products_def using assms(2) by auto
qed
end
subsection "Equalizers"
text\<open>
An \emph{equalizer} in a category @{term C} is a limit of a parallel pair
of arrows in @{term C}.
\<close>
locale parallel_pair_diagram =
J: parallel_pair +
C: category C
for C :: "'c comp" (infixr "\<cdot>" 55)
and f0 :: 'c
and f1 :: 'c +
assumes is_parallel: "C.par f0 f1"
begin
no_notation J.comp (infixr "\<cdot>" 55)
notation J.comp (infixr "\<cdot>\<^sub>J" 55)
definition map
where "map \<equiv> (\<lambda>j. if j = J.Zero then C.dom f0
else if j = J.One then C.cod f0
else if j = J.j0 then f0
else if j = J.j1 then f1
else C.null)"
lemma map_simp:
shows "map J.Zero = C.dom f0"
and "map J.One = C.cod f0"
and "map J.j0 = f0"
and "map J.j1 = f1"
proof -
show "map J.Zero = C.dom f0"
using map_def by metis
show "map J.One = C.cod f0"
using map_def J.Zero_not_eq_One by metis
show "map J.j0 = f0"
using map_def J.Zero_not_eq_j0 J.One_not_eq_j0 by metis
show "map J.j1 = f1"
using map_def J.Zero_not_eq_j1 J.One_not_eq_j1 J.j0_not_eq_j1 by metis
qed
end
sublocale parallel_pair_diagram \<subseteq> diagram J.comp C map
apply unfold_locales
apply (simp add: J.arr_char map_def)
using map_def is_parallel J.arr_char J.cod_simp J.dom_simp
apply auto[2]
proof -
show 1: "\<And>j. J.arr j \<Longrightarrow> C.cod (map j) = map (J.cod j)"
proof -
fix j
assume j: "J.arr j"
show "C.cod (map j) = map (J.cod j)"
proof -
have "j = J.Zero \<or> j = J.One \<Longrightarrow> ?thesis" using is_parallel map_def by auto
moreover have "j = J.j0 \<or> j = J.j1 \<Longrightarrow> ?thesis"
using is_parallel map_def J.Zero_not_eq_j0 J.One_not_eq_j0 J.Zero_not_eq_One
J.Zero_not_eq_j1 J.One_not_eq_j1 J.Zero_not_eq_One J.cod_simp
by presburger
ultimately show ?thesis using j J.arr_char by fast
qed
qed
next
fix j j'
assume jj': "J.seq j' j"
show "map (j' \<cdot>\<^sub>J j) = map j' \<cdot> map j"
proof -
have 1: "(j = J.Zero \<and> j' \<noteq> J.One) \<or> (j \<noteq> J.Zero \<and> j' = J.One)"
using jj' J.seq_char by blast
moreover have "j = J.Zero \<and> j' \<noteq> J.One \<Longrightarrow> ?thesis"
using jj' map_def is_parallel J.arr_char J.cod_simp J.dom_simp J.seq_char
by (metis (no_types, lifting) C.arr_dom_iff_arr C.comp_arr_dom C.dom_dom
J.comp_arr_dom)
moreover have "j \<noteq> J.Zero \<and> j' = J.One \<Longrightarrow> ?thesis"
using jj' J.ide_char map_def J.Zero_not_eq_One is_parallel
by (metis (no_types, lifting) C.arr_cod_iff_arr C.comp_arr_dom C.comp_cod_arr
C.comp_ide_arr C.ext C.ide_cod J.comp_simp(2))
ultimately show ?thesis by blast
qed
qed
context parallel_pair_diagram
begin
definition mkCone
where "mkCone e \<equiv> \<lambda>j. if J.arr j then if j = J.Zero then e else f0 \<cdot> e else C.null"
abbreviation is_equalized_by
where "is_equalized_by e \<equiv> C.seq f0 e \<and> f0 \<cdot> e = f1 \<cdot> e"
abbreviation has_as_equalizer
where "has_as_equalizer e \<equiv> limit_cone (C.dom e) (mkCone e)"
lemma cone_mkCone:
assumes "is_equalized_by e"
shows "cone (C.dom e) (mkCone e)"
proof -
- interpret E: constant_functor J.comp C "C.dom e"
+ interpret E: constant_functor J.comp C \<open>C.dom e\<close>
apply unfold_locales using assms by auto
show "cone (C.dom e) (mkCone e)"
using assms mkCone_def apply unfold_locales
apply auto[2]
- using C.dom_comp
- apply (metis C.seqE C.cod_comp J.Zero_not_eq_One J.arr_char J.cod_simp map_def)
+ using C.dom_comp C.seqE C.cod_comp J.Zero_not_eq_One J.arr_char' J.cod_char map_def
+ apply (metis (no_types, lifting) C.not_arr_null parallel_pair.cod_simp(1) preserves_arr)
proof -
fix j
assume j: "J.arr j"
show "map j \<cdot> mkCone e (J.dom j) = mkCone e j"
proof -
have 1: "\<forall>a. if a = J.Zero then map a = C.dom f0
else if a = J.One then map a = C.cod f0
else if a = J.j0 then map a = f0
else if a = J.j1 then map a = f1
else map a = C.null"
using map_def by auto
hence 2: "map j = f1 \<or> j = J.One \<or> j = J.Zero \<or> j = J.j0"
- using j by (meson J.arr_char)
- have "j = J.Zero \<or> C (map j) (mkCone e (J.dom j)) = mkCone e j"
+ using j parallel_pair.arr_char by meson
+ have "j = J.Zero \<or> map j \<cdot> mkCone e (J.dom j) = mkCone e j"
using assms j 1 2 mkCone_def C.cod_comp
by (metis (no_types, lifting) C.comp_cod_arr J.arr_char J.dom_simp(2-4) is_parallel)
thus ?thesis
using assms 1 j
- by (metis C.seqE C.comp_cod_arr J.dom_simp(1) mkCone_def)
+ by (metis (no_types, lifting) C.comp_cod_arr C.seqE mkCone_def J.dom_simp(1))
qed
next
show "\<And>j. J.arr j \<Longrightarrow> mkCone e (J.cod j) \<cdot> E.map j = mkCone e j"
- by (metis C.arr_dom_iff_arr C.comp_arr_dom E.map_simp J.Zero_not_eq_One J.arr_char
- J.cod_char J.cod_simp(1) C.dom_comp assms mkCone_def)
+ proof -
+ fix j
+ assume j: "J.arr j"
+ have "J.cod j = J.Zero \<Longrightarrow> mkCone e (J.cod j) \<cdot> E.map j = mkCone e j"
+ unfolding mkCone_def
+ using assms j J.arr_char J.cod_char C.comp_arr_dom mkCone_def J.Zero_not_eq_One
+ by (metis (no_types, lifting) C.seqE E.map_simp)
+ moreover have "J.cod j \<noteq> J.Zero \<Longrightarrow> mkCone e (J.cod j) \<cdot> E.map j = mkCone e j"
+ unfolding mkCone_def
+ using assms j C.comp_arr_dom by auto
+ ultimately show "mkCone e (J.cod j) \<cdot> E.map j = mkCone e j" by blast
+ qed
qed
qed
lemma is_equalized_by_cone:
assumes "cone a \<chi>"
shows "is_equalized_by (\<chi> (J.Zero))"
proof -
interpret \<chi>: cone J.comp C map a \<chi>
using assms by auto
show ?thesis
- by (metis J.One_not_eq_j0 J.One_not_eq_j1 J.Zero_not_eq_j0 J.Zero_not_eq_j1 J.arr_char
- J.cod_simp(3-4) J.dom_simp(3-4) J.j0_not_eq_j1
- Limit.cone_def \<chi>.is_natural_2 \<chi>.naturality \<chi>.preserves_reflects_arr assms
- constant_functor.map_simp map_def)
+ using assms J.arr_char J.dom_char J.cod_char
+ J.One_not_eq_j0 J.One_not_eq_j1 J.Zero_not_eq_j0 J.Zero_not_eq_j1 J.j0_not_eq_j1
+ by (metis (no_types, lifting) Limit.cone_def \<chi>.is_natural_1 \<chi>.naturality
+ \<chi>.preserves_reflects_arr constant_functor.map_simp map_simp(3) map_simp(4))
qed
lemma mkCone_cone:
assumes "cone a \<chi>"
shows "mkCone (\<chi> J.Zero) = \<chi>"
proof -
interpret \<chi>: cone J.comp C map a \<chi>
using assms by auto
have 1: "is_equalized_by (\<chi> J.Zero)"
using assms is_equalized_by_cone by blast
show ?thesis
proof
fix j
have "j = J.Zero \<Longrightarrow> mkCone (\<chi> J.Zero) j = \<chi> j"
using mkCone_def \<chi>.is_extensional by simp
moreover have "j = J.One \<or> j = J.j0 \<or> j = J.j1 \<Longrightarrow> mkCone (\<chi> J.Zero) j = \<chi> j"
using J.arr_char J.cod_char J.dom_char J.seq_char mkCone_def
\<chi>.is_natural_1 \<chi>.is_natural_2 \<chi>.A.map_simp map_def
by (metis (no_types, lifting) J.Zero_not_eq_j0 J.dom_simp(2))
ultimately have "J.arr j \<Longrightarrow> mkCone (\<chi> J.Zero) j = \<chi> j"
using J.arr_char by auto
thus "mkCone (\<chi> J.Zero) j = \<chi> j"
using mkCone_def \<chi>.is_extensional by fastforce
qed
qed
end
locale equalizer_cone =
J: parallel_pair +
C: category C +
D: parallel_pair_diagram C f0 f1 +
limit_cone J.comp C D.map "C.dom e" "D.mkCone e"
for C :: "'c comp" (infixr "\<cdot>" 55)
and f0 :: 'c
and f1 :: 'c
and e :: 'c
begin
lemma equalizes:
shows "D.is_equalized_by e"
proof
show 1: "C.seq f0 e"
proof (intro C.seqI)
show "C.arr e" using ide_apex C.arr_dom_iff_arr by fastforce
show "C.arr f0"
using D.map_simp D.preserves_arr J.arr_char by metis
show "C.dom f0 = C.cod e"
using J.arr_char J.ide_char D.mkCone_def D.map_simp preserves_cod [of J.Zero]
by auto
qed
hence 2: "C.seq f1 e"
using D.is_parallel by fastforce
show "f0 \<cdot> e = f1 \<cdot> e"
using D.map_simp D.mkCone_def J.arr_char naturality [of J.j0] naturality [of J.j1]
by force
qed
lemma is_universal':
assumes "D.is_equalized_by e'"
shows "\<exists>!h. \<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright> \<and> e \<cdot> h = e'"
proof -
have "D.cone (C.dom e') (D.mkCone e')"
using assms D.cone_mkCone by blast
moreover have 0: "D.cone (C.dom e) (D.mkCone e)" ..
ultimately have 1: "\<exists>!h. \<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright> \<and>
D.cones_map h (D.mkCone e) = D.mkCone e'"
using is_universal [of "C.dom e'" "D.mkCone e'"] by auto
have 2: "\<And>h. \<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright> \<Longrightarrow>
D.cones_map h (D.mkCone e) = D.mkCone e' \<longleftrightarrow> e \<cdot> h = e'"
proof -
fix h
assume h: "\<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright>"
show "D.cones_map h (D.mkCone e) = D.mkCone e' \<longleftrightarrow> e \<cdot> h = e'"
proof
assume 3: "D.cones_map h (D.mkCone e) = D.mkCone e'"
show "e \<cdot> h = e'"
proof -
have "e' = D.mkCone e' J.Zero"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone e) J.Zero"
using 3 by simp
also have "... = e \<cdot> h"
using 0 h D.mkCone_def J.arr_char by auto
finally show ?thesis by auto
qed
next
assume e': "e \<cdot> h = e'"
show "D.cones_map h (D.mkCone e) = D.mkCone e'"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> D.cones_map h (D.mkCone e) j = D.mkCone e' j"
using h cone_axioms D.mkCone_def by auto
moreover have "j = J.Zero \<Longrightarrow> D.cones_map h (D.mkCone e) j = D.mkCone e' j"
using h e' cone_\<chi> D.mkCone_def J.arr_char [of J.Zero] by force
moreover have
"J.arr j \<and> j \<noteq> J.Zero \<Longrightarrow> D.cones_map h (D.mkCone e) j = D.mkCone e' j"
proof -
assume j: "J.arr j \<and> j \<noteq> J.Zero"
have "D.cones_map h (D.mkCone e) j = C (D.mkCone e j) h"
using j h equalizes D.mkCone_def D.cone_mkCone J.arr_char
J.Zero_not_eq_One J.Zero_not_eq_j0 J.Zero_not_eq_j1
by auto
also have "... = (f0 \<cdot> e) \<cdot> h"
using j D.mkCone_def J.arr_char J.Zero_not_eq_One J.Zero_not_eq_j0
J.Zero_not_eq_j1
- by metis
+ by auto
also have "... = f0 \<cdot> e \<cdot> h"
using h equalizes C.comp_assoc by blast
also have "... = D.mkCone e' j"
using j e' h equalizes D.mkCone_def J.arr_char [of J.One] J.Zero_not_eq_One
by auto
finally show ?thesis by auto
qed
ultimately show "D.cones_map h (D.mkCone e) j = D.mkCone e' j" by blast
qed
qed
qed
thus ?thesis using 1 by blast
qed
lemma induced_arrowI':
assumes "D.is_equalized_by e'"
shows "\<guillemotleft>induced_arrow (C.dom e') (D.mkCone e') : C.dom e' \<rightarrow> C.dom e\<guillemotright>"
and "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') = e'"
proof -
- interpret A': constant_functor J.comp C "C.dom e'"
+ interpret A': constant_functor J.comp C \<open>C.dom e'\<close>
using assms by (unfold_locales, auto)
have cone: "D.cone (C.dom e') (D.mkCone e')"
using assms D.cone_mkCone [of e'] by blast
have "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') =
D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) J.Zero"
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
also have "... = e'"
proof -
have
"D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) = D.mkCone e'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally have 1: "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') = e'"
by auto
show "\<guillemotleft>induced_arrow (C.dom e') (D.mkCone e') : C.dom e' \<rightarrow> C.dom e\<guillemotright>"
using 1 cone induced_arrowI by simp
show "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') = e'"
using 1 cone induced_arrowI by simp
qed
end
context category
begin
definition has_as_equalizer
where "has_as_equalizer f0 f1 e \<equiv> par f0 f1 \<and> parallel_pair_diagram.has_as_equalizer C f0 f1 e"
definition has_equalizers
where "has_equalizers = (\<forall>f0 f1. par f0 f1 \<longrightarrow> (\<exists>e. has_as_equalizer f0 f1 e))"
end
section "Limits by Products and Equalizers"
text\<open>
A category with equalizers has limits of shape @{term J} if it has products
indexed by the set of arrows of @{term J} and the set of objects of @{term J}.
The proof is patterned after \cite{MacLane}, Theorem 2, page 109:
\begin{quotation}
``The limit of \<open>F: J \<rightarrow> C\<close> is the equalizer \<open>e\<close>
of \<open>f, g: \<Pi>\<^sub>i F\<^sub>i \<rightarrow> \<Pi>\<^sub>u F\<^sub>c\<^sub>o\<^sub>d \<^sub>u (u \<in> arr J, i \<in> J)\<close>
where \<open>p\<^sub>u f = p\<^sub>c\<^sub>o\<^sub>d \<^sub>u\<close>, \<open>p\<^sub>u g = F\<^sub>u o p\<^sub>d\<^sub>o\<^sub>m \<^sub>u\<close>;
the limiting cone \<open>\<mu>\<close> is \<open>\<mu>\<^sub>j = p\<^sub>j e\<close>, for \<open>j \<in> J\<close>.''
\end{quotation}
\<close>
locale category_with_equalizers =
category C
for C :: "'c comp" (infixr "\<cdot>" 55) +
assumes has_equalizers: "has_equalizers"
begin
lemma has_limits_if_has_products:
fixes J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
assumes "category J" and "has_products (Collect (partial_magma.ide J))"
and "has_products (Collect (partial_magma.arr J))"
shows "has_limits_of_shape J"
proof (unfold has_limits_of_shape_def)
interpret J: category J using assms(1) by auto
have "\<And>D. diagram J C D \<Longrightarrow> (\<exists>a \<chi>. limit_cone J C D a \<chi>)"
proof -
fix D
assume D: "diagram J C D"
interpret D: diagram J C D using D by auto
text\<open>
First, construct the two required products and their cones.
\<close>
- interpret Obj: discrete_category "Collect J.ide" J.null
+ interpret Obj: discrete_category \<open>Collect J.ide\<close> J.null
using J.not_arr_null J.ideD(1) mem_Collect_eq by (unfold_locales, blast)
- interpret \<Delta>o: discrete_diagram_from_map "Collect J.ide" C D J.null
+ interpret \<Delta>o: discrete_diagram_from_map \<open>Collect J.ide\<close> C D J.null
using D.preserves_ide by (unfold_locales, auto)
have "\<exists>p. has_as_product Obj.comp \<Delta>o.map p"
using assms(2) \<Delta>o.diagram_axioms has_products_def Obj.arr_char
by (metis (no_types, lifting) Collect_cong \<Delta>o.discrete_diagram_axioms mem_Collect_eq)
from this obtain \<Pi>o \<pi>o where \<pi>o: "product_cone Obj.comp C \<Delta>o.map \<Pi>o \<pi>o"
using ex_productE [of Obj.comp \<Delta>o.map] by auto
interpret \<pi>o: product_cone Obj.comp C \<Delta>o.map \<Pi>o \<pi>o using \<pi>o by auto
have \<pi>o_in_hom: "\<And>j. Obj.arr j \<Longrightarrow> \<guillemotleft>\<pi>o j : \<Pi>o \<rightarrow> D j\<guillemotright>"
using \<pi>o.preserves_dom \<pi>o.preserves_cod \<Delta>o.map_def by auto
- interpret Arr: discrete_category "Collect J.arr" J.null
+ interpret Arr: discrete_category \<open>Collect J.arr\<close> J.null
using J.not_arr_null by (unfold_locales, blast)
- interpret \<Delta>a: discrete_diagram_from_map "Collect J.arr" C "D o J.cod" J.null
+ interpret \<Delta>a: discrete_diagram_from_map \<open>Collect J.arr\<close> C \<open>D o J.cod\<close> J.null
by (unfold_locales, auto)
have "\<exists>p. has_as_product Arr.comp \<Delta>a.map p"
using assms(3) has_products_def [of "Collect J.arr"] \<Delta>a.discrete_diagram_axioms
by blast
from this obtain \<Pi>a \<pi>a where \<pi>a: "product_cone Arr.comp C \<Delta>a.map \<Pi>a \<pi>a"
using ex_productE [of Arr.comp \<Delta>a.map] by auto
interpret \<pi>a: product_cone Arr.comp C \<Delta>a.map \<Pi>a \<pi>a using \<pi>a by auto
have \<pi>a_in_hom: "\<And>j. Arr.arr j \<Longrightarrow> \<guillemotleft>\<pi>a j : \<Pi>a \<rightarrow> D (J.cod j)\<guillemotright>"
using \<pi>a.preserves_cod \<pi>a.preserves_dom \<Delta>a.map_def by auto
text\<open>
Next, construct a parallel pair of arrows \<open>f, g: \<Pi>o \<rightarrow> \<Pi>a\<close>
that expresses the commutativity constraints imposed by the diagram.
\<close>
interpret \<Pi>o: constant_functor Arr.comp C \<Pi>o
using \<pi>o.ide_apex by (unfold_locales, auto)
let ?\<chi> = "\<lambda>j. if Arr.arr j then \<pi>o (J.cod j) else null"
interpret \<chi>: cone Arr.comp C \<Delta>a.map \<Pi>o ?\<chi>
using \<pi>o.ide_apex \<pi>o_in_hom \<Delta>a.map_def \<Delta>o.map_def \<Delta>o.is_discrete \<pi>o.is_natural_2
comp_cod_arr
by (unfold_locales, auto)
let ?f = "\<pi>a.induced_arrow \<Pi>o ?\<chi>"
have f_in_hom: "\<guillemotleft>?f : \<Pi>o \<rightarrow> \<Pi>a\<guillemotright>"
using \<chi>.cone_axioms \<pi>a.induced_arrowI by blast
have f_map: "\<Delta>a.cones_map ?f \<pi>a = ?\<chi>"
using \<chi>.cone_axioms \<pi>a.induced_arrowI by blast
have ff: "\<And>j. J.arr j \<Longrightarrow> \<pi>a j \<cdot> ?f = \<pi>o (J.cod j)"
proof -
fix j
assume j: "J.arr j"
have "\<pi>a j \<cdot> ?f = \<Delta>a.cones_map ?f \<pi>a j"
using f_in_hom \<pi>a.is_cone \<pi>a.is_extensional by auto
also have "... = \<pi>o (J.cod j)"
using j f_map by fastforce
finally show "\<pi>a j \<cdot> ?f = \<pi>o (J.cod j)" by auto
qed
let ?\<chi>' = "\<lambda>j. if Arr.arr j then D j \<cdot> \<pi>o (J.dom j) else null"
interpret \<chi>': cone Arr.comp C \<Delta>a.map \<Pi>o ?\<chi>'
using \<pi>o.ide_apex \<pi>o_in_hom \<Delta>o.map_def \<Delta>a.map_def comp_arr_dom comp_cod_arr
by (unfold_locales, auto)
let ?g = "\<pi>a.induced_arrow \<Pi>o ?\<chi>'"
have g_in_hom: "\<guillemotleft>?g : \<Pi>o \<rightarrow> \<Pi>a\<guillemotright>"
using \<chi>'.cone_axioms \<pi>a.induced_arrowI by blast
have g_map: "\<Delta>a.cones_map ?g \<pi>a = ?\<chi>'"
using \<chi>'.cone_axioms \<pi>a.induced_arrowI by blast
have gg: "\<And>j. J.arr j \<Longrightarrow> \<pi>a j \<cdot> ?g = D j \<cdot> \<pi>o (J.dom j)"
proof -
fix j
assume j: "J.arr j"
have "\<pi>a j \<cdot> ?g = \<Delta>a.cones_map ?g \<pi>a j"
using g_in_hom \<pi>a.is_cone \<pi>a.is_extensional by force
also have "... = D j \<cdot> \<pi>o (J.dom j)"
using j g_map by fastforce
finally show "\<pi>a j \<cdot> ?g = D j \<cdot> \<pi>o (J.dom j)" by auto
qed
interpret PP: parallel_pair_diagram C ?f ?g
using f_in_hom g_in_hom
by (elim in_homE, unfold_locales, auto)
from PP.is_parallel obtain e where equ: "PP.has_as_equalizer e"
using has_equalizers has_equalizers_def has_as_equalizer_def by blast
- interpret EQU: limit_cone PP.J.comp C PP.map "dom e" "PP.mkCone e"
+ interpret EQU: limit_cone PP.J.comp C PP.map \<open>dom e\<close> \<open>PP.mkCone e\<close>
using equ by auto
interpret EQU: equalizer_cone C ?f ?g e ..
text\<open>
An arrow @{term h} with @{term "cod h = \<Pi>o"} equalizes @{term f} and @{term g}
if and only if it satisfies the commutativity condition required for a cone over
@{term D}.
\<close>
have E: "\<And>h. \<guillemotleft>h : dom h \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow>
?f \<cdot> h = ?g \<cdot> h \<longleftrightarrow> (\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h)"
proof
fix h
assume h: "\<guillemotleft>h : dom h \<rightarrow> \<Pi>o\<guillemotright>"
show "?f \<cdot> h = ?g \<cdot> h \<Longrightarrow> \<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h"
proof -
assume E: "?f \<cdot> h = ?g \<cdot> h"
have "\<And>j. J.arr j \<Longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h"
proof -
fix j
assume j: "J.arr j"
have "?\<chi> j \<cdot> h = \<Delta>a.cones_map ?f \<pi>a j \<cdot> h"
using j f_map by fastforce
also have "... = \<pi>a j \<cdot> ?f \<cdot> h"
using j f_in_hom \<Delta>a.map_def \<pi>a.cone_\<chi> comp_assoc by auto
also have "... = \<pi>a j \<cdot> ?g \<cdot> h"
using j E by simp
also have "... = \<Delta>a.cones_map ?g \<pi>a j \<cdot> h"
using j g_in_hom \<Delta>a.map_def \<pi>a.cone_\<chi> comp_assoc by auto
also have "... = ?\<chi>' j \<cdot> h"
using j g_map by force
finally show "?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h" by auto
qed
thus "\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h" by blast
qed
show "\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h \<Longrightarrow> ?f \<cdot> h = ?g \<cdot> h"
proof -
assume 1: "\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h"
have 2: "\<And>j. j \<in> Collect J.arr \<Longrightarrow> \<pi>a j \<cdot> ?f \<cdot> h = \<pi>a j \<cdot> ?g \<cdot> h"
proof -
fix j
assume j: "j \<in> Collect J.arr"
have "\<pi>a j \<cdot> ?f \<cdot> h = (\<pi>a j \<cdot> ?f) \<cdot> h"
using comp_assoc by simp
also have "... = ?\<chi> j \<cdot> h"
proof -
have "\<pi>a j \<cdot> ?f = \<Delta>a.cones_map ?f \<pi>a j"
using j f_in_hom \<pi>a.cone_axioms \<Delta>a.map_def \<pi>a.cone_\<chi> by auto
thus ?thesis using f_map by fastforce
qed
also have "... = ?\<chi>' j \<cdot> h"
using 1 j by auto
also have "... = (\<pi>a j \<cdot> ?g) \<cdot> h"
proof -
have "\<pi>a j \<cdot> ?g = \<Delta>a.cones_map ?g \<pi>a j"
using j g_in_hom \<pi>a.cone_axioms \<Delta>a.map_def \<pi>a.cone_\<chi> by auto
thus ?thesis using g_map by simp
qed
also have "... = \<pi>a j \<cdot> ?g \<cdot> h"
using comp_assoc by simp
finally show "\<pi>a j \<cdot> ?f \<cdot> h = \<pi>a j \<cdot> ?g \<cdot> h"
by auto
qed
show "C ?f h = C ?g h"
proof -
have "\<And>j. Arr.arr j \<Longrightarrow> \<guillemotleft>\<pi>a j \<cdot> ?f \<cdot> h : dom h \<rightarrow> \<Delta>a.map j\<guillemotright>"
using f_in_hom h \<pi>a_in_hom by (elim in_homE, auto)
hence 3: "\<exists>!k. \<guillemotleft>k : dom h \<rightarrow> \<Pi>a\<guillemotright> \<and> (\<forall>j. Arr.arr j \<longrightarrow> \<pi>a j \<cdot> k = \<pi>a j \<cdot> ?f \<cdot> h)"
using h \<pi>a \<pi>a.is_universal' [of "dom h" "\<lambda>j. \<pi>a j \<cdot> ?f \<cdot> h"] \<Delta>a.map_def
ide_dom [of h]
by blast
have 4: "\<And>P x x'. \<exists>!k. P k x \<Longrightarrow> P x x \<Longrightarrow> P x' x \<Longrightarrow> x' = x" by auto
let ?P = "\<lambda> k x. \<guillemotleft>k : dom h \<rightarrow> \<Pi>a\<guillemotright> \<and>
(\<forall>j. j \<in> Collect J.arr \<longrightarrow> \<pi>a j \<cdot> k = \<pi>a j \<cdot> x)"
have "?P (?g \<cdot> h) (?g \<cdot> h)"
using g_in_hom h by force
moreover have "?P (?f \<cdot> h) (?g \<cdot> h)"
using 2 f_in_hom g_in_hom h by force
ultimately show ?thesis
using 3 4 [of ?P "?f \<cdot> h" "?g \<cdot> h"] by auto
qed
qed
qed
have E': "\<And>e. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow>
?f \<cdot> e = ?g \<cdot> e \<longleftrightarrow>
(\<forall>j. J.arr j \<longrightarrow>
(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e)"
proof -
have 1: "\<And>e j. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow> J.arr j \<Longrightarrow>
?\<chi> j \<cdot> e = (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e"
proof -
fix e j
assume e: "\<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright>"
assume j: "J.arr j"
have "\<guillemotleft>\<pi>o (J.cod j) \<cdot> e : dom e \<rightarrow> D (J.cod j)\<guillemotright>"
using e j \<pi>o_in_hom by auto
thus "?\<chi> j \<cdot> e = (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e"
using j comp_arr_dom comp_cod_arr by (elim in_homE, auto)
qed
have 2: "\<And>e j. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow> J.arr j \<Longrightarrow> ?\<chi>' j \<cdot> e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e"
proof -
fix e j
assume e: "\<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright>"
assume j: "J.arr j"
show "?\<chi>' j \<cdot> e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e"
using j comp_assoc by fastforce
qed
show "\<And>e. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow>
?f \<cdot> e = ?g \<cdot> e \<longleftrightarrow>
(\<forall>j. J.arr j \<longrightarrow>
(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e)"
using 1 2 E by presburger
qed
text\<open>
The composites of @{term e} with the projections from the product @{term \<Pi>o}
determine a limit cone @{term \<mu>} for @{term D}. The component of @{term \<mu>}
at an object @{term j} of @{term[source=true] J} is the composite @{term "C (\<pi>o j) e"}.
However, we need to extend @{term \<mu>} to all arrows @{term j} of @{term[source=true] J},
so the correct definition is @{term "\<mu> j = C (D j) (C (\<pi>o (J.dom j)) e)"}.
\<close>
have e_in_hom: "\<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright>"
using EQU.equalizes f_in_hom in_homI
by (metis (no_types, lifting) seqE in_homE)
have e_map: "C ?f e = C ?g e"
using EQU.equalizes f_in_hom in_homI by fastforce
- interpret domE: constant_functor J C "dom e"
+ interpret domE: constant_functor J C \<open>dom e\<close>
using e_in_hom by (unfold_locales, auto)
let ?\<mu> = "\<lambda>j. if J.arr j then D j \<cdot> \<pi>o (J.dom j) \<cdot> e else null"
have \<mu>: "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>?\<mu> j : dom e \<rightarrow> D (J.cod j)\<guillemotright>"
proof -
fix j
assume j: "J.arr j"
show "\<guillemotleft>?\<mu> j : dom e \<rightarrow> D (J.cod j)\<guillemotright>"
using j e_in_hom \<pi>o_in_hom [of "J.dom j"] by auto
qed
- interpret \<mu>: cone J C D "dom e" ?\<mu>
+ interpret \<mu>: cone J C D \<open>dom e\<close> ?\<mu>
apply unfold_locales
apply simp
proof -
fix j
assume j: "J.arr j"
show "dom (?\<mu> j) = domE.map (J.dom j)" using j \<mu> domE.map_simp by force
show "cod (?\<mu> j) = D (J.cod j)" using j \<mu> D.preserves_cod by blast
show "D j \<cdot> ?\<mu> (J.dom j) = ?\<mu> j"
using j \<mu> [of "J.dom j"] comp_cod_arr apply simp
by (elim in_homE, auto)
show "?\<mu> (J.cod j) \<cdot> domE.map j = ?\<mu> j"
using j e_map E' by (simp add: e_in_hom)
qed
text\<open>
If @{term \<tau>} is any cone over @{term D} then @{term \<tau>} restricts to a cone over
@{term \<Delta>o} for which the induced arrow to @{term \<Pi>o} equalizes @{term f} and @{term g}.
\<close>
have R: "\<And>a \<tau>. cone J C D a \<tau> \<Longrightarrow>
cone Obj.comp C \<Delta>o.map a (\<Delta>o.mkCone \<tau>) \<and>
?f \<cdot> \<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)
= ?g \<cdot> \<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)"
proof -
fix a \<tau>
assume cone_\<tau>: "cone J C D a \<tau>"
interpret \<tau>: cone J C D a \<tau> using cone_\<tau> by auto
interpret A: constant_functor Obj.comp C a
using \<tau>.ide_apex by (unfold_locales, auto)
- interpret \<tau>o: cone Obj.comp C \<Delta>o.map a "\<Delta>o.mkCone \<tau>"
+ interpret \<tau>o: cone Obj.comp C \<Delta>o.map a \<open>\<Delta>o.mkCone \<tau>\<close>
using A.value_is_ide \<Delta>o.map_def comp_cod_arr comp_arr_dom
by (unfold_locales, auto)
let ?e = "\<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)"
have mkCone_\<tau>: "\<Delta>o.mkCone \<tau> \<in> \<Delta>o.cones a"
proof -
have "\<And>j. Obj.arr j \<Longrightarrow> \<guillemotleft>\<tau> j : a \<rightarrow> \<Delta>o.map j\<guillemotright>"
using Obj.arr_char \<tau>.A.map_def \<Delta>o.map_def by force
thus ?thesis
using \<tau>.ide_apex \<Delta>o.cone_mkCone by simp
qed
have e: "\<guillemotleft>?e : a \<rightarrow> \<Pi>o\<guillemotright>"
using mkCone_\<tau> \<pi>o.induced_arrowI by simp
have ee: "\<And>j. J.ide j \<Longrightarrow> \<pi>o j \<cdot> ?e = \<tau> j"
proof -
fix j
assume j: "J.ide j"
have "\<pi>o j \<cdot> ?e = \<Delta>o.cones_map ?e \<pi>o j"
using j e \<pi>o.cone_axioms by force
also have "... = \<Delta>o.mkCone \<tau> j"
using j mkCone_\<tau> \<pi>o.induced_arrowI [of "\<Delta>o.mkCone \<tau>" a] by fastforce
also have "... = \<tau> j"
using j by simp
finally show "\<pi>o j \<cdot> ?e = \<tau> j" by auto
qed
have "\<And>j. J.arr j \<Longrightarrow>
(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e) \<cdot> dom ?e = D j \<cdot> \<pi>o (J.dom j) \<cdot> ?e"
proof -
fix j
assume j: "J.arr j"
have 1: "\<guillemotleft>\<pi>o (J.cod j) : \<Pi>o \<rightarrow> D (J.cod j)\<guillemotright>" using j \<pi>o_in_hom by simp
have 2: "(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e) \<cdot> dom ?e
= D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e"
proof -
have "seq (D (J.cod j)) (\<pi>o (J.cod j))"
using j 1 by auto
moreover have "seq (\<pi>o (J.cod j)) ?e"
using j e by fastforce
ultimately show ?thesis using comp_arr_dom by auto
qed
also have 3: "... = \<pi>o (J.cod j) \<cdot> ?e"
using j e 1 comp_cod_arr by (elim in_homE, auto)
also have "... = D j \<cdot> \<pi>o (J.dom j) \<cdot> ?e"
using j e ee 2 3 \<tau>.naturality \<tau>.A.map_simp \<tau>.ide_apex comp_cod_arr by auto
finally show "(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e) \<cdot> dom ?e = D j \<cdot> \<pi>o (J.dom j) \<cdot> ?e"
by auto
qed
hence "C ?f ?e = C ?g ?e"
using E' \<pi>o.induced_arrowI \<tau>o.cone_axioms mem_Collect_eq by blast
thus "cone Obj.comp C \<Delta>o.map a (\<Delta>o.mkCone \<tau>) \<and> C ?f ?e = C ?g ?e"
using \<tau>o.cone_axioms by auto
qed
text\<open>
Finally, show that @{term \<mu>} is a limit cone.
\<close>
- interpret \<mu>: limit_cone J C D "dom e" ?\<mu>
+ interpret \<mu>: limit_cone J C D \<open>dom e\<close> ?\<mu>
proof
fix a \<tau>
assume cone_\<tau>: "cone J C D a \<tau>"
interpret \<tau>: cone J C D a \<tau> using cone_\<tau> by auto
interpret A: constant_functor Obj.comp C a
apply unfold_locales using \<tau>.ide_apex by auto
have cone_\<tau>o: "cone Obj.comp C \<Delta>o.map a (\<Delta>o.mkCone \<tau>)"
using A.value_is_ide \<Delta>o.map_def D.preserves_ide comp_cod_arr comp_arr_dom
\<tau>.preserves_hom
by (unfold_locales, auto)
show "\<exists>!h. \<guillemotleft>h : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map h ?\<mu> = \<tau>"
proof
let ?e' = "\<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)"
have e'_in_hom: "\<guillemotleft>?e' : a \<rightarrow> \<Pi>o\<guillemotright>"
using cone_\<tau> R \<pi>o.induced_arrowI by auto
have e'_map: "?f \<cdot> ?e' = ?g \<cdot> ?e' \<and> \<Delta>o.cones_map ?e' \<pi>o = \<Delta>o.mkCone \<tau>"
using cone_\<tau> R \<pi>o.induced_arrowI [of "\<Delta>o.mkCone \<tau>" a] by auto
have equ: "PP.is_equalized_by ?e'"
using e'_map e'_in_hom f_in_hom seqI' by blast
let ?h = "EQU.induced_arrow a (PP.mkCone ?e')"
have h_in_hom: "\<guillemotleft>?h : a \<rightarrow> dom e\<guillemotright>"
using EQU.induced_arrowI PP.cone_mkCone [of ?e'] e'_in_hom equ by fastforce
have h_map: "PP.cones_map ?h (PP.mkCone e) = PP.mkCone ?e'"
using EQU.induced_arrowI [of "PP.mkCone ?e'" a] PP.cone_mkCone [of ?e']
e'_in_hom equ
by fastforce
have 3: "D.cones_map ?h ?\<mu> = \<tau>"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> D.cones_map ?h ?\<mu> j = \<tau> j"
using h_in_hom \<mu>.cone_axioms cone_\<tau> \<tau>.is_extensional by force
moreover have "J.arr j \<Longrightarrow> D.cones_map ?h ?\<mu> j = \<tau> j"
proof -
fix j
assume j: "J.arr j"
have 1: "\<guillemotleft>\<pi>o (J.dom j) \<cdot> e : dom e \<rightarrow> D (J.dom j)\<guillemotright>"
using j e_in_hom \<pi>o_in_hom [of "J.dom j"] by auto
have "D.cones_map ?h ?\<mu> j = ?\<mu> j \<cdot> ?h"
using h_in_hom j \<mu>.cone_axioms by auto
also have "... = D j \<cdot> (\<pi>o (J.dom j) \<cdot> e) \<cdot> ?h"
using j comp_assoc by simp
also have "... = D j \<cdot> \<tau> (J.dom j)"
proof -
have "(\<pi>o (J.dom j) \<cdot> e) \<cdot> ?h = \<tau> (J.dom j)"
proof -
have "(\<pi>o (J.dom j) \<cdot> e) \<cdot> ?h = \<pi>o (J.dom j) \<cdot> e \<cdot> ?h"
using j 1 e_in_hom h_in_hom \<pi>o arrI comp_assoc by auto
also have "... = \<pi>o (J.dom j) \<cdot> ?e'"
using equ e'_in_hom EQU.induced_arrowI' [of ?e']
by (elim in_homE, auto)
also have "... = \<Delta>o.cones_map ?e' \<pi>o (J.dom j)"
using j e'_in_hom \<pi>o.cone_axioms by (elim in_homE, auto)
also have "... = \<tau> (J.dom j)"
using j e'_map by simp
finally show ?thesis by auto
qed
thus ?thesis by simp
qed
also have "... = \<tau> j"
using j \<tau>.is_natural_1 by simp
finally show "D.cones_map ?h ?\<mu> j = \<tau> j" by auto
qed
ultimately show "D.cones_map ?h ?\<mu> j = \<tau> j" by auto
qed
show "\<guillemotleft>?h : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map ?h ?\<mu> = \<tau>"
using h_in_hom 3 by simp
show "\<And>h'. \<guillemotleft>h' : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map h' ?\<mu> = \<tau> \<Longrightarrow> h' = ?h"
proof -
fix h'
assume h': "\<guillemotleft>h' : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map h' ?\<mu> = \<tau>"
have h'_in_hom: "\<guillemotleft>h' : a \<rightarrow> dom e\<guillemotright>" using h' by simp
have h'_map: "D.cones_map h' ?\<mu> = \<tau>" using h' by simp
show "h' = ?h"
proof -
have 1: "\<guillemotleft>e \<cdot> h' : a \<rightarrow> \<Pi>o\<guillemotright> \<and> ?f \<cdot> e \<cdot> h' = ?g \<cdot> e \<cdot> h' \<and>
\<Delta>o.cones_map (C e h') \<pi>o = \<Delta>o.mkCone \<tau>"
proof -
have 2: "\<guillemotleft>e \<cdot> h' : a \<rightarrow> \<Pi>o\<guillemotright>" using h'_in_hom e_in_hom by auto
moreover have "?f \<cdot> e \<cdot> h' = ?g \<cdot> e \<cdot> h'"
proof -
have "?f \<cdot> e \<cdot> h' = (?f \<cdot> e) \<cdot> h'"
using comp_assoc by auto
also have "... = ?g \<cdot> e \<cdot> h'"
using EQU.equalizes comp_assoc by auto
finally show ?thesis by auto
qed
moreover have "\<Delta>o.cones_map (e \<cdot> h') \<pi>o = \<Delta>o.mkCone \<tau>"
proof
have "\<Delta>o.cones_map (e \<cdot> h') \<pi>o = \<Delta>o.cones_map h' (\<Delta>o.cones_map e \<pi>o)"
using \<pi>o.cone_axioms e_in_hom h'_in_hom \<Delta>o.cones_map_comp [of e h']
by fastforce
fix j
have "\<not>Obj.arr j \<Longrightarrow> \<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j"
using 2 e_in_hom h'_in_hom \<pi>o.cone_axioms
by (auto simp del: comp_in_hom_simp')
moreover have "Obj.arr j \<Longrightarrow> \<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j"
proof -
assume j: "Obj.arr j"
have "\<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<pi>o j \<cdot> e \<cdot> h'"
using 2 j \<pi>o.cone_axioms by auto
also have "... = (\<pi>o j \<cdot> e) \<cdot> h'"
using comp_assoc by auto
also have "... = \<Delta>o.mkCone ?\<mu> j \<cdot> h'"
using j e_in_hom \<pi>o_in_hom comp_ide_arr [of "D j" "\<pi>o j \<cdot> e"]
by fastforce
also have "... = \<Delta>o.mkCone \<tau> j"
using j h' \<mu>.cone_axioms mem_Collect_eq by auto
finally show "\<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j" by auto
qed
ultimately show "\<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j" by auto
qed
ultimately show ?thesis by auto
qed
have "\<guillemotleft>e \<cdot> h' : a \<rightarrow> \<Pi>o\<guillemotright>" using 1 by simp
moreover have "e \<cdot> h' = ?e'"
using 1 cone_\<tau>o e'_in_hom e'_map \<pi>o.is_universal \<pi>o by blast
ultimately show "h' = ?h"
using 1 h'_in_hom h'_map EQU.is_universal' [of "e \<cdot> h'"]
EQU.induced_arrowI' [of ?e'] equ
by (elim in_homE, auto)
qed
qed
qed
qed
have "limit_cone J C D (dom e) ?\<mu>" ..
thus "\<exists>a \<mu>. limit_cone J C D a \<mu>" by auto
qed
thus "\<forall>D. diagram J C D \<longrightarrow> (\<exists>a \<mu>. limit_cone J C D a \<mu>)" by blast
qed
end
section "Limits in a Set Category"
text\<open>
In this section, we consider the special case of limits in a set category.
\<close>
locale diagram_in_set_category =
J: category J +
S: set_category S +
diagram J S D
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and S :: "'s comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 's"
begin
notation S.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
text\<open>
An object @{term a} of a set category @{term[source=true] S} is a limit of a diagram in
@{term[source=true] S} if and only if there is a bijection between the set
@{term "S.hom S.unity a"} of points of @{term a} and the set of cones over the diagram
that have apex @{term S.unity}.
\<close>
lemma limits_are_sets_of_cones:
shows "has_as_limit a \<longleftrightarrow> S.ide a \<and> (\<exists>\<phi>. bij_betw \<phi> (S.hom S.unity a) (cones S.unity))"
proof
text\<open>
If \<open>has_limit a\<close>, then by the universal property of the limit cone,
composition in @{term[source=true] S} yields a bijection between @{term "S.hom S.unity a"}
and @{term "cones S.unity"}.
\<close>
assume a: "has_as_limit a"
hence "S.ide a"
using limit_cone_def cone.ide_apex by metis
from a obtain \<chi> where \<chi>: "limit_cone a \<chi>" by auto
interpret \<chi>: limit_cone J S D a \<chi> using \<chi> by auto
have "bij_betw (\<lambda>f. cones_map f \<chi>) (S.hom S.unity a) (cones S.unity)"
using \<chi>.bij_betw_hom_and_cones S.ide_unity by simp
thus "S.ide a \<and> (\<exists>\<phi>. bij_betw \<phi> (S.hom S.unity a) (cones S.unity))"
using \<open>S.ide a\<close> by blast
next
text\<open>
Conversely, an arbitrary bijection @{term \<phi>} between @{term "S.hom S.unity a"}
and cones unity extends pointwise to a natural bijection @{term "\<Phi> a'"} between
@{term "S.hom a' a"} and @{term "cones a'"}, showing that @{term a} is a limit.
In more detail, the hypotheses give us a correspondence between points of @{term a}
and cones with apex @{term "S.unity"}. We extend this to a correspondence between
functions to @{term a} and general cones, with each arrow from @{term a'} to @{term a}
determining a cone with apex @{term a'}. If @{term "f \<in> hom a' a"} then composition
with @{term f} takes each point @{term y} of @{term a'} to the point @{term "S f y"}
of @{term a}. To this we may apply the given bijection @{term \<phi>} to obtain
@{term "\<phi> (S f y) \<in> cones S.unity"}. The component @{term "\<phi> (S f y) j"} at @{term j}
of this cone is a point of @{term "S.cod (D j)"}. Thus, @{term "f \<in> hom a' a"} determines
a cone @{term \<chi>f} with apex @{term a'} whose component at @{term j} is the
unique arrow @{term "\<chi>f j"} of @{term[source=true] S} such that
@{term "\<chi>f j \<in> hom a' (cod (D j))"} and @{term "S (\<chi>f j) y = \<phi> (S f y) j"}
for all points @{term y} of @{term a'}.
The cone @{term \<chi>a} corresponding to @{term "a \<in> S.hom a a"} is then a limit cone.
\<close>
assume a: "S.ide a \<and> (\<exists>\<phi>. bij_betw \<phi> (S.hom S.unity a) (cones S.unity))"
hence ide_a: "S.ide a" by auto
show "has_as_limit a"
proof -
from a obtain \<phi> where \<phi>: "bij_betw \<phi> (S.hom S.unity a) (cones S.unity)" by blast
have X: "\<And>f j y. \<lbrakk> \<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>; J.arr j; \<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright> \<rbrakk>
\<Longrightarrow> \<guillemotleft>\<phi> (f \<cdot> y) j : S.unity \<rightarrow> S.cod (D j)\<guillemotright>"
proof -
fix f j y
assume f: "\<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>" and j: "J.arr j" and y: "\<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright>"
- interpret \<chi>: cone J S D S.unity "\<phi> (S f y)"
+ interpret \<chi>: cone J S D S.unity \<open>\<phi> (S f y)\<close>
using f y \<phi> bij_betw_imp_funcset funcset_mem by blast
show "\<guillemotleft>\<phi> (f \<cdot> y) j : S.unity \<rightarrow> S.cod (D j)\<guillemotright>" using j by auto
qed
text\<open>
We want to define the component @{term "\<chi>j \<in> S.hom (S.dom f) (S.cod (D j))"}
at @{term j} of a cone by specifying how it acts by composition on points
@{term "y \<in> S.hom S.unity (S.dom f)"}. We can do this because @{term[source=true] S}
is a set category.
\<close>
let ?P = "\<lambda>f j \<chi>j. \<guillemotleft>\<chi>j : S.dom f \<rightarrow> S.cod (D j)\<guillemotright> \<and>
(\<forall>y. \<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright> \<longrightarrow> \<chi>j \<cdot> y = \<phi> (f \<cdot> y) j)"
let ?\<chi> = "\<lambda>f j. if J.arr j then (THE \<chi>j. ?P f j \<chi>j) else S.null"
have \<chi>: "\<And>f j. \<lbrakk> \<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>; J.arr j \<rbrakk> \<Longrightarrow> ?P f j (?\<chi> f j)"
proof -
fix b f j
assume f: "\<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>" and j: "J.arr j"
- interpret B: constant_functor J S "S.dom f"
+ interpret B: constant_functor J S \<open>S.dom f\<close>
using f by (unfold_locales, auto)
have "(\<lambda>y. \<phi> (f \<cdot> y) j) \<in> S.hom S.unity (S.dom f) \<rightarrow> S.hom S.unity (S.cod (D j))"
using f j X Pi_I' by simp
hence "\<exists>!\<chi>j. ?P f j \<chi>j"
using f j S.fun_complete' [of "S.dom f" "S.cod (D j)" "\<lambda>y. \<phi> (f \<cdot> y) j"]
by (elim S.in_homE, auto)
thus "?P f j (?\<chi> f j)" using j theI' [of "?P f j"] by simp
qed
text\<open>
The arrows @{term "\<chi> f j"} are in fact the components of a cone with apex
@{term "S.dom f"}.
\<close>
have cone: "\<And>f. \<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright> \<Longrightarrow> cone (S.dom f) (?\<chi> f)"
proof -
fix f
assume f: "\<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>"
- interpret B: constant_functor J S "S.dom f"
+ interpret B: constant_functor J S \<open>S.dom f\<close>
using f by (unfold_locales, auto)
show "cone (S.dom f) (?\<chi> f)"
proof
show "\<And>j. \<not>J.arr j \<Longrightarrow> ?\<chi> f j = S.null" by simp
fix j
assume j: "J.arr j"
have 0: "\<guillemotleft>?\<chi> f j : S.dom f \<rightarrow> S.cod (D j)\<guillemotright>" using f j \<chi> by simp
show "S.dom (?\<chi> f j) = B.map (J.dom j)" using f j \<chi> by auto
show "S.cod (?\<chi> f j) = D (J.cod j)" using f j \<chi> by auto
have par1: "S.par (D j \<cdot> ?\<chi> f (J.dom j)) (?\<chi> f j)"
using f j 0 \<chi> [of f "J.dom j"] by (elim S.in_homE, auto)
have par2: "S.par (?\<chi> f (J.cod j) \<cdot> B.map j) (?\<chi> f j)"
using f j 0 \<chi> [of f "J.cod j"] by (elim S.in_homE, auto)
have nat: "\<And>y. \<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright> \<Longrightarrow>
(D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = ?\<chi> f j \<cdot> y \<and>
(?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f j \<cdot> y"
proof -
fix y
assume y: "\<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright>"
show "(D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = ?\<chi> f j \<cdot> y \<and>
(?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f j \<cdot> y"
proof
have 1: "\<phi> (f \<cdot> y) \<in> cones S.unity"
using f y \<phi> bij_betw_imp_funcset PiE
S.seqI S.cod_comp S.dom_comp mem_Collect_eq
by fastforce
- interpret \<chi>: cone J S D S.unity "\<phi> (f \<cdot> y)"
+ interpret \<chi>: cone J S D S.unity \<open>\<phi> (f \<cdot> y)\<close>
using 1 by simp
have "(D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = D j \<cdot> ?\<chi> f (J.dom j) \<cdot> y"
using S.comp_assoc by simp
also have "... = D j \<cdot> \<phi> (f \<cdot> y) (J.dom j)"
using f y \<chi> \<chi>.is_extensional by simp
also have "... = \<phi> (f \<cdot> y) j" using j by auto
also have "... = ?\<chi> f j \<cdot> y"
using f j y \<chi> by force
finally show "(D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = ?\<chi> f j \<cdot> y" by auto
have "(?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f (J.cod j) \<cdot> y"
using j B.map_simp par2 B.value_is_ide S.comp_arr_ide
by (metis (no_types, lifting))
also have "... = \<phi> (f \<cdot> y) (J.cod j)"
using f y \<chi> \<chi>.is_extensional by simp
also have "... = \<phi> (f \<cdot> y) j"
using j \<chi>.is_natural_2
by (metis J.arr_cod \<chi>.A.map_simp J.cod_cod)
also have "... = ?\<chi> f j \<cdot> y"
using f y \<chi> \<chi>.is_extensional by simp
finally show "(?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f j \<cdot> y" by auto
qed
qed
show "D j \<cdot> ?\<chi> f (J.dom j) = ?\<chi> f j"
using par1 nat 0
apply (intro S.arr_eqI' [of "D j \<cdot> ?\<chi> f (J.dom j)" "?\<chi> f j"])
apply force
by auto
show "?\<chi> f (J.cod j) \<cdot> B.map j = ?\<chi> f j"
using par2 nat 0 f j \<chi>
apply (intro S.arr_eqI' [of "?\<chi> f (J.cod j) \<cdot> B.map j" "?\<chi> f j"])
apply force
by (metis (no_types, lifting) S.in_homE)
qed
qed
- interpret \<chi>a: cone J S D a "?\<chi> a" using a cone [of a] by fastforce
+ interpret \<chi>a: cone J S D a \<open>?\<chi> a\<close> using a cone [of a] by fastforce
text\<open>
Finally, show that \<open>\<chi> a\<close> is a limit cone.
\<close>
- interpret \<chi>a: limit_cone J S D a "?\<chi> a"
+ interpret \<chi>a: limit_cone J S D a \<open>?\<chi> a\<close>
proof
fix a' \<chi>'
assume cone_\<chi>': "cone a' \<chi>'"
interpret \<chi>': cone J S D a' \<chi>' using cone_\<chi>' by auto
show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> cones_map f (?\<chi> a) = \<chi>'"
proof
let ?\<psi> = "inv_into (S.hom S.unity a) \<phi>"
have \<psi>: "?\<psi> \<in> cones S.unity \<rightarrow> S.hom S.unity a"
using \<phi> bij_betw_inv_into bij_betwE by blast
let ?P = "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and>
(\<forall>y. y \<in> S.hom S.unity a' \<longrightarrow> f \<cdot> y = ?\<psi> (cones_map y \<chi>'))"
have 1: "\<exists>!f. ?P f"
proof -
have "(\<lambda>y. ?\<psi> (cones_map y \<chi>')) \<in> S.hom S.unity a' \<rightarrow> S.hom S.unity a"
proof
fix x
assume "x \<in> S.hom S.unity a'"
hence "\<guillemotleft>x : S.unity \<rightarrow> a'\<guillemotright>" by simp
hence "cones_map x \<in> cones a' \<rightarrow> cones S.unity"
using cones_map_mapsto [of x] by (elim S.in_homE, auto)
hence "cones_map x \<chi>' \<in> cones S.unity"
using cone_\<chi>' by blast
thus "?\<psi> (cones_map x \<chi>') \<in> S.hom S.unity a"
using \<psi> by auto
qed
thus ?thesis
using S.fun_complete' a \<chi>'.ide_apex by simp
qed
let ?f = "THE f. ?P f"
have f: "?P ?f" using 1 theI' [of ?P] by simp
have f_in_hom: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright>" using f by simp
have f_map: "cones_map ?f (?\<chi> a) = \<chi>'"
proof -
have 1: "cone a' (cones_map ?f (?\<chi> a))"
proof -
have "cones_map ?f \<in> cones a \<rightarrow> cones a'"
using f_in_hom cones_map_mapsto [of ?f] by (elim S.in_homE, auto)
hence "cones_map ?f (?\<chi> a) \<in> cones a'"
using \<chi>a.cone_axioms by blast
thus ?thesis by simp
qed
- interpret f\<chi>a: cone J S D a' "cones_map ?f (?\<chi> a)"
+ interpret f\<chi>a: cone J S D a' \<open>cones_map ?f (?\<chi> a)\<close>
using 1 by simp
show ?thesis
proof
fix j
have "\<not>J.arr j \<Longrightarrow> cones_map ?f (?\<chi> a) j = \<chi>' j"
using 1 \<chi>'.is_extensional f\<chi>a.is_extensional by presburger
moreover have "J.arr j \<Longrightarrow> cones_map ?f (?\<chi> a) j = \<chi>' j"
proof -
assume j: "J.arr j"
show "cones_map ?f (?\<chi> a) j = \<chi>' j"
proof (intro S.arr_eqI' [of "cones_map ?f (?\<chi> a) j" "\<chi>' j"])
show par: "S.par (cones_map ?f (?\<chi> a) j) (\<chi>' j)"
using j \<chi>'.preserves_cod \<chi>'.preserves_dom \<chi>'.preserves_reflects_arr
f\<chi>a.preserves_cod f\<chi>a.preserves_dom f\<chi>a.preserves_reflects_arr
by presburger
fix y
assume "\<guillemotleft>y : S.unity \<rightarrow> S.dom (cones_map ?f (?\<chi> a) j)\<guillemotright>"
hence y: "\<guillemotleft>y : S.unity \<rightarrow> a'\<guillemotright>"
using j f\<chi>a.preserves_dom by simp
have 1: "\<guillemotleft>?\<chi> a j : a \<rightarrow> D (J.cod j)\<guillemotright>"
using j \<chi>a.preserves_hom by force
have 2: "\<guillemotleft>?f \<cdot> y : S.unity \<rightarrow> a\<guillemotright>"
using f_in_hom y by blast
have "cones_map ?f (?\<chi> a) j \<cdot> y = (?\<chi> a j \<cdot> ?f) \<cdot> y"
proof -
have "S.cod ?f = a" using f_in_hom by blast
thus ?thesis using j \<chi>a.cone_axioms by simp
qed
also have "... = ?\<chi> a j \<cdot> ?f \<cdot> y"
using 1 j y f_in_hom S.comp_assoc S.seqI' by blast
also have "... = \<phi> (a \<cdot> ?f \<cdot> y) j"
using 1 2 ide_a f j y \<chi> [of a] by (simp add: S.ide_in_hom)
also have "... = \<phi> (?f \<cdot> y) j"
using a 2 y S.comp_cod_arr by (elim S.in_homE, auto)
also have "... = \<phi> (?\<psi> (cones_map y \<chi>')) j"
using j y f by simp
also have "... = cones_map y \<chi>' j"
proof -
have "cones_map y \<chi>' \<in> cones S.unity"
using cone_\<chi>' y cones_map_mapsto by force
hence "\<phi> (?\<psi> (cones_map y \<chi>')) = cones_map y \<chi>'"
using \<phi> bij_betw_inv_into_right [of \<phi>] by simp
thus ?thesis by auto
qed
also have "... = \<chi>' j \<cdot> y"
using cone_\<chi>' j y by auto
finally show "cones_map ?f (?\<chi> a) j \<cdot> y = \<chi>' j \<cdot> y"
by auto
qed
qed
ultimately show "cones_map ?f (?\<chi> a) j = \<chi>' j" by blast
qed
qed
show "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright> \<and> cones_map ?f (?\<chi> a) = \<chi>'"
using f_in_hom f_map by simp
show "\<And>f'. \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> cones_map f' (?\<chi> a) = \<chi>' \<Longrightarrow> f' = ?f"
proof -
fix f'
assume f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> cones_map f' (?\<chi> a) = \<chi>'"
have f'_in_hom: "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>" using f' by simp
have f'_map: "cones_map f' (?\<chi> a) = \<chi>'" using f' by simp
show "f' = ?f"
proof (intro S.arr_eqI' [of f' ?f])
show "S.par f' ?f"
using f_in_hom f'_in_hom by (elim S.in_homE, auto)
show "\<And>y'. \<guillemotleft>y' : S.unity \<rightarrow> S.dom f'\<guillemotright> \<Longrightarrow> f' \<cdot> y' = ?f \<cdot> y'"
proof -
fix y'
assume y': "\<guillemotleft>y' : S.unity \<rightarrow> S.dom f'\<guillemotright>"
have 0: "\<phi> (f' \<cdot> y') = cones_map y' \<chi>'"
proof
fix j
have 1: "\<guillemotleft>f' \<cdot> y' : S.unity \<rightarrow> a\<guillemotright>" using f'_in_hom y' by auto
hence 2: "\<phi> (f' \<cdot> y') \<in> cones S.unity"
using \<phi> bij_betw_imp_funcset [of \<phi> "S.hom S.unity a" "cones S.unity"]
by auto
- interpret \<chi>'': cone J S D S.unity "\<phi> (f' \<cdot> y')" using 2 by auto
+ interpret \<chi>'': cone J S D S.unity \<open>\<phi> (f' \<cdot> y')\<close> using 2 by auto
have "\<not>J.arr j \<Longrightarrow> \<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j"
using f' y' cone_\<chi>' \<chi>''.is_extensional mem_Collect_eq restrict_apply
by (elim S.in_homE, auto)
moreover have "J.arr j \<Longrightarrow> \<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j"
proof -
assume j: "J.arr j"
have 3: "\<guillemotleft>?\<chi> a j : a \<rightarrow> D (J.cod j)\<guillemotright>"
using j \<chi>a.preserves_hom by force
have "\<phi> (f' \<cdot> y') j = \<phi> (a \<cdot> f' \<cdot> y') j"
using a f' y' j S.comp_cod_arr by (elim S.in_homE, auto)
also have "... = ?\<chi> a j \<cdot> f' \<cdot> y'"
using 1 3 \<chi> [of a] a f' y' j by fastforce
also have "... = (?\<chi> a j \<cdot> f') \<cdot> y'"
using S.comp_assoc by simp
also have "... = cones_map f' (?\<chi> a) j \<cdot> y'"
using f' y' j \<chi>a.cone_axioms by auto
also have "... = \<chi>' j \<cdot> y'"
using f' by blast
also have "... = cones_map y' \<chi>' j"
using y' j cone_\<chi>' f' mem_Collect_eq restrict_apply by force
finally show "\<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j" by auto
qed
ultimately show "\<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j" by auto
qed
hence "f' \<cdot> y' = ?\<psi> (cones_map y' \<chi>')"
using \<phi> f'_in_hom y' S.comp_in_homI
bij_betw_inv_into_left [of \<phi> "S.hom S.unity a" "cones S.unity" "f' \<cdot> y'"]
by (elim S.in_homE, auto)
moreover have "?f \<cdot> y' = ?\<psi> (cones_map y' \<chi>')"
using \<phi> 0 1 f f_in_hom f'_in_hom y' S.comp_in_homI
bij_betw_inv_into_left [of \<phi> "S.hom S.unity a" "cones S.unity" "?f \<cdot> y'"]
by (elim S.in_homE, auto)
ultimately show "f' \<cdot> y' = ?f \<cdot> y'" by auto
qed
qed
qed
qed
qed
have "limit_cone a (?\<chi> a)" ..
thus ?thesis by auto
qed
qed
end
context set_category
begin
text\<open>
A set category has an equalizer for any parallel pair of arrows.
\<close>
lemma has_equalizers:
shows "has_equalizers"
proof (unfold has_equalizers_def)
have "\<And>f0 f1. par f0 f1 \<Longrightarrow> \<exists>e. has_as_equalizer f0 f1 e"
proof -
fix f0 f1
assume par: "par f0 f1"
- interpret J: parallel_pair
- apply unfold_locales by auto
+ interpret J: parallel_pair .
interpret PP: parallel_pair_diagram S f0 f1
apply unfold_locales using par by auto
interpret PP: diagram_in_set_category J.comp S PP.map ..
text\<open>
Let @{term a} be the object corresponding to the set of all images of equalizing points
of @{term "dom f0"}, and let @{term e} be the inclusion of @{term a} in @{term "dom f0"}.
\<close>
let ?a = "mkIde (img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e})"
have "{e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e} \<subseteq> hom unity (dom f0)"
by auto
hence 1: "img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e} \<subseteq> Univ"
using img_point_in_Univ by auto
have ide_a: "ide ?a" using 1 by auto
have set_a: "set ?a = img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
using 1 by simp
have incl_in_a: "incl_in ?a (dom f0)"
proof -
have "ide (dom f0)"
using PP.is_parallel by simp
moreover have "set ?a \<subseteq> set (dom f0)"
proof -
have "set ?a = img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
using img_point_in_Univ set_a by blast
thus ?thesis
using imageE img_point_elem_set mem_Collect_eq subsetI by auto
qed
ultimately show ?thesis
using incl_in_def \<open>ide ?a\<close> by simp
qed
text\<open>
Then @{term "set a"} is in bijective correspondence with @{term "PP.cones unity"}.
\<close>
let ?\<phi> = "\<lambda>t. PP.mkCone (mkPoint (dom f0) t)"
let ?\<psi> = "\<lambda>\<chi>. img (\<chi> (J.Zero))"
have bij: "bij_betw ?\<phi> (set ?a) (PP.cones unity)"
proof (intro bij_betwI)
show "?\<phi> \<in> set ?a \<rightarrow> PP.cones unity"
proof
fix t
assume t: "t \<in> set ?a"
hence 1: "t \<in> img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
using set_a by blast
then have 2: "mkPoint (dom f0) t \<in> hom unity (dom f0)"
using mkPoint_in_hom imageE mem_Collect_eq mkPoint_img(2) by auto
with 1 have 3: "mkPoint (dom f0) t \<in> {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
using mkPoint_img(2) by auto
then have "PP.is_equalized_by (mkPoint (dom f0) t)"
using CollectD par by fastforce
thus "PP.mkCone (mkPoint (dom f0) t) \<in> PP.cones unity"
using 2 PP.cone_mkCone [of "mkPoint (dom f0) t"] by auto
qed
show "?\<psi> \<in> PP.cones unity \<rightarrow> set ?a"
proof
fix \<chi>
assume \<chi>: "\<chi> \<in> PP.cones unity"
interpret \<chi>: cone J.comp S PP.map unity \<chi> using \<chi> by auto
have "\<chi> (J.Zero) \<in> hom unity (dom f0) \<and> f0 \<cdot> \<chi> (J.Zero) = f1 \<cdot> \<chi> (J.Zero)"
using \<chi> PP.map_def PP.is_equalized_by_cone J.arr_char by auto
hence "img (\<chi> (J.Zero)) \<in> set ?a"
using set_a by simp
thus "?\<psi> \<chi> \<in> set ?a" by blast
qed
show "\<And>t. t \<in> set ?a \<Longrightarrow> ?\<psi> (?\<phi> t) = t"
using set_a J.arr_char PP.mkCone_def imageE mem_Collect_eq mkPoint_img(2)
by auto
show "\<And>\<chi>. \<chi> \<in> PP.cones unity \<Longrightarrow> ?\<phi> (?\<psi> \<chi>) = \<chi>"
proof -
fix \<chi>
assume \<chi>: "\<chi> \<in> PP.cones unity"
interpret \<chi>: cone J.comp S PP.map unity \<chi> using \<chi> by auto
have 1: "\<chi> (J.Zero) \<in> hom unity (dom f0) \<and> f0 \<cdot> \<chi> (J.Zero) = f1 \<cdot> \<chi> (J.Zero)"
using \<chi> PP.map_def PP.is_equalized_by_cone J.arr_char by auto
hence "img (\<chi> (J.Zero)) \<in> set ?a"
using set_a by simp
hence "img (\<chi> (J.Zero)) \<in> set (dom f0)"
using incl_in_a incl_in_def by auto
hence "mkPoint (dom f0) (img (\<chi> J.Zero)) = \<chi> J.Zero"
using 1 mkPoint_img(2) by blast
hence "?\<phi> (?\<psi> \<chi>) = PP.mkCone (\<chi> J.Zero)" by simp
also have "... = \<chi>"
using \<chi> PP.mkCone_cone by simp
finally show "?\<phi> (?\<psi> \<chi>) = \<chi>" by auto
qed
qed
text\<open>
It follows that @{term a} is a limit of \<open>PP\<close>, and that the limit cone gives an
equalizer of @{term f0} and @{term f1}.
\<close>
have "\<exists>\<mu>. bij_betw \<mu> (hom unity ?a) (set ?a)"
using bij_betw_points_and_set ide_a by auto
from this obtain \<mu> where \<mu>: "bij_betw \<mu> (hom unity ?a) (set ?a)" by blast
have "bij_betw (?\<phi> o \<mu>) (hom unity ?a) (PP.cones unity)"
using bij \<mu> bij_betw_comp_iff by blast
hence "\<exists>\<phi>. bij_betw \<phi> (hom unity ?a) (PP.cones unity)" by auto
hence "PP.has_as_limit ?a"
using ide_a PP.limits_are_sets_of_cones by simp
from this obtain \<epsilon> where \<epsilon>: "limit_cone J.comp S PP.map ?a \<epsilon>" by auto
interpret \<epsilon>: limit_cone J.comp S PP.map ?a \<epsilon> using \<epsilon> by auto
have "PP.mkCone (\<epsilon> (J.Zero)) = \<epsilon>"
using \<epsilon> PP.mkCone_cone \<epsilon>.cone_axioms by simp
moreover have "dom (\<epsilon> (J.Zero)) = ?a"
using J.ide_char \<epsilon>.preserves_hom \<epsilon>.A.map_def by simp
ultimately have "PP.has_as_equalizer (\<epsilon> J.Zero)"
using \<epsilon> by simp
thus "\<exists>e. has_as_equalizer f0 f1 e"
using par has_as_equalizer_def by auto
qed
thus "\<forall>f0 f1. par f0 f1 \<longrightarrow> (\<exists>e. has_as_equalizer f0 f1 e)" by auto
qed
end
sublocale set_category \<subseteq> category_with_equalizers S
apply unfold_locales using has_equalizers by auto
context set_category
begin
text\<open>
The aim of the next results is to characterize the conditions under which a set
category has products. In a traditional development of category theory,
one shows that the category \textbf{Set} of \emph{all} sets has all small
(\emph{i.e.}~set-indexed) products. In the present context we do not have a
category of \emph{all} sets, but rather only a category of all sets with
elements at a particular type. Clearly, we cannot expect such a category
to have products indexed by arbitrarily large sets. The existence of
@{term I}-indexed products in a set category @{term[source=true] S} implies that the universe
\<open>S.Univ\<close> of @{term[source=true] S} must be large enough to admit the formation of
@{term I}-tuples of its elements. Conversely, for a set category @{term[source=true] S}
the ability to form @{term I}-tuples in @{term Univ} implies that
@{term[source=true] S} has @{term I}-indexed products. Below we make this precise by
defining the notion of when a set category @{term[source=true] S}
``admits @{term I}-indexed tupling'' and we show that @{term[source=true] S}
has @{term I}-indexed products if and only if it admits @{term I}-indexed tupling.
The definition of ``@{term[source=true] S} admits @{term I}-indexed tupling'' says that
there is an injective map, from the space of extensional functions from
@{term I} to @{term Univ}, to @{term Univ}. However for a convenient
statement and proof of the desired result, the definition of extensional
function from theory @{theory "HOL-Library.FuncSet"} needs to be modified.
The theory @{theory "HOL-Library.FuncSet"} uses the definite, but arbitrarily chosen value
@{term undefined} as the value to be assumed by an extensional function outside
of its domain. In the context of the \<open>set_category\<close>, though, it is
more natural to use \<open>S.unity\<close>, which is guaranteed to be an element of the
universe of @{term[source=true] S}, for this purpose. Doing things that way makes it
simpler to establish a bijective correspondence between cones over @{term D} with apex
@{term unity} and the set of extensional functions @{term d} that map
each arrow @{term j} of @{term J} to an element @{term "d j"} of @{term "set (D j)"}.
Possibly it makes sense to go back and make this change in \<open>set_category\<close>,
but that would mean completely abandoning @{theory "HOL-Library.FuncSet"} and essentially
introducing a duplicate version for use with \<open>set_category\<close>.
As a compromise, what I have done here is to locally redefine the few notions from
@{theory "HOL-Library.FuncSet"} that I need in order to prove the next set of results.
\<close>
definition extensional
where "extensional A \<equiv> {f. \<forall>x. x \<notin> A \<longrightarrow> f x = unity}"
abbreviation PiE
where "PiE A B \<equiv> Pi A B \<inter> extensional A"
abbreviation restrict
where "restrict f A \<equiv> \<lambda>x. if x \<in> A then f x else unity"
lemma extensionalI [intro]:
assumes "\<And>x. x \<notin> A \<Longrightarrow> f x = unity"
shows "f \<in> extensional A"
using assms extensional_def by auto
lemma extensional_arb:
assumes "f \<in> extensional A" and "x \<notin> A"
shows "f x = unity"
using assms extensional_def by fast
lemma extensional_monotone:
assumes "A \<subseteq> B"
shows "extensional A \<subseteq> extensional B"
proof
fix f
assume f: "f \<in> extensional A"
have 1: "\<forall>x. x \<notin> A \<longrightarrow> f x = unity" using f extensional_def by fast
hence "\<forall>x. x \<notin> B \<longrightarrow> f x = unity" using assms by auto
thus "f \<in> extensional B" using extensional_def by blast
qed
lemma PiE_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> PiE A B \<subseteq> PiE A C"
by auto
end
locale discrete_diagram_in_set_category =
S: set_category S +
discrete_diagram J S D +
diagram_in_set_category J S D
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and S :: "'s comp" (infixr "\<cdot>" 55)
and D :: "'j \<Rightarrow> 's"
begin
text\<open>
For @{term D} a discrete diagram in a set category, there is a bijective correspondence
between cones over @{term D} with apex unity and the set of extensional functions @{term d}
that map each arrow @{term j} of @{term[source=true] J} to an element of
@{term "S.set (D j)"}.
\<close>
abbreviation I
where "I \<equiv> Collect J.arr"
definition funToCone
where "funToCone F \<equiv> \<lambda>j. if J.arr j then S.mkPoint (D j) (F j) else S.null"
definition coneToFun
where "coneToFun \<chi> \<equiv> \<lambda>j. if J.arr j then S.img (\<chi> j) else S.unity"
lemma funToCone_mapsto:
shows "funToCone \<in> S.PiE I (S.set o D) \<rightarrow> cones S.unity"
proof
fix F
assume F: "F \<in> S.PiE I (S.set o D)"
interpret U: constant_functor J S S.unity
apply unfold_locales using S.ide_unity by auto
have 1: "S.ide (S.mkIde S.Univ)" by simp
have "cone S.unity (funToCone F)"
proof
show "\<And>j. \<not>J.arr j \<Longrightarrow> funToCone F j = S.null"
using funToCone_def by simp
fix j
assume j: "J.arr j"
have "funToCone F j = S.mkPoint (D j) (F j)"
using j funToCone_def by simp
moreover have "... \<in> S.hom S.unity (D j)"
using F j is_discrete S.img_mkPoint(1) [of "D j"] by force
ultimately have 2: "funToCone F j \<in> S.hom S.unity (D j)" by auto
show 3: "S.dom (funToCone F j) = U.map (J.dom j)"
using 2 j U.map_simp by auto
show 4: "S.cod (funToCone F j) = D (J.cod j)"
using 2 j is_discrete by auto
show "D j \<cdot> funToCone F (J.dom j) = funToCone F j"
using 2 j is_discrete S.comp_cod_arr by auto
show "funToCone F (J.cod j) \<cdot> (U.map j) = funToCone F j"
using 3 j is_discrete U.map_simp S.arr_dom_iff_arr S.comp_arr_dom U.preserves_arr
by (metis J.ide_char)
qed
thus "funToCone F \<in> cones S.unity" by auto
qed
lemma coneToFun_mapsto:
shows "coneToFun \<in> cones S.unity \<rightarrow> S.PiE I (S.set o D)"
proof
fix \<chi>
assume \<chi>: "\<chi> \<in> cones S.unity"
interpret \<chi>: cone J S D S.unity \<chi> using \<chi> by auto
show "coneToFun \<chi> \<in> S.PiE I (S.set o D)"
proof
show "coneToFun \<chi> \<in> Pi I (S.set o D)"
using S.mkPoint_img(1) coneToFun_def is_discrete \<chi>.component_in_hom
by (simp add: S.img_point_elem_set restrict_apply')
show "coneToFun \<chi> \<in> S.extensional I"
proof
fix x
show "x \<notin> I \<Longrightarrow> coneToFun \<chi> x = S.unity"
using coneToFun_def by simp
qed
qed
qed
lemma funToCone_coneToFun:
assumes "\<chi> \<in> cones S.unity"
shows "funToCone (coneToFun \<chi>) = \<chi>"
proof
interpret \<chi>: cone J S D S.unity \<chi> using assms by auto
fix j
have "\<not>J.arr j \<Longrightarrow> funToCone (coneToFun \<chi>) j = \<chi> j"
using funToCone_def \<chi>.is_extensional by simp
moreover have "J.arr j \<Longrightarrow> funToCone (coneToFun \<chi>) j = \<chi> j"
using funToCone_def coneToFun_def S.mkPoint_img(2) is_discrete \<chi>.component_in_hom
by auto
ultimately show "funToCone (coneToFun \<chi>) j = \<chi> j" by blast
qed
lemma coneToFun_funToCone:
assumes "F \<in> S.PiE I (S.set o D)"
shows "coneToFun (funToCone F) = F"
proof
fix i
have "i \<notin> I \<Longrightarrow> coneToFun (funToCone F) i = F i"
using assms coneToFun_def S.extensional_arb [of F I i] by auto
moreover have "i \<in> I \<Longrightarrow> coneToFun (funToCone F) i = F i"
proof -
assume i: "i \<in> I"
have "coneToFun (funToCone F) i = S.img (funToCone F i)"
using i coneToFun_def by simp
also have "... = S.img (S.mkPoint (D i) (F i))"
using i funToCone_def by auto
also have "... = F i"
using assms i is_discrete S.img_mkPoint(2) by force
finally show "coneToFun (funToCone F) i = F i" by auto
qed
ultimately show "coneToFun (funToCone F) i = F i" by auto
qed
lemma bij_coneToFun:
shows "bij_betw coneToFun (cones S.unity) (S.PiE I (S.set o D))"
using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
bij_betwI
by blast
lemma bij_funToCone:
shows "bij_betw funToCone (S.PiE I (S.set o D)) (cones S.unity)"
using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
bij_betwI
by blast
end
context set_category
begin
text\<open>
A set category admits @{term I}-indexed tupling if there is an injective map that takes
each extensional function from @{term I} to @{term Univ} to an element of @{term Univ}.
\<close>
definition admits_tupling
where "admits_tupling I \<equiv> \<exists>\<pi>. \<pi> \<in> PiE I (\<lambda>_. Univ) \<rightarrow> Univ \<and> inj_on \<pi> (PiE I (\<lambda>_. Univ))"
lemma admits_tupling_monotone:
assumes "admits_tupling I" and "I' \<subseteq> I"
shows "admits_tupling I'"
proof -
from assms(1) obtain \<pi>
where \<pi>: "\<pi> \<in> PiE I (\<lambda>_. Univ) \<rightarrow> Univ \<and> inj_on \<pi> (PiE I (\<lambda>_. Univ))"
using admits_tupling_def by metis
have "\<pi> \<in> PiE I' (\<lambda>_. Univ) \<rightarrow> Univ"
proof
fix f
assume f: "f \<in> PiE I' (\<lambda>_. Univ)"
have "f \<in> PiE I (\<lambda>_. Univ)"
using assms(2) f extensional_def [of I'] terminal_unity extensional_monotone by auto
thus "\<pi> f \<in> Univ" using \<pi> by auto
qed
moreover have "inj_on \<pi> (PiE I' (\<lambda>_. Univ))"
proof -
have 1: "\<And>F A A'. inj_on F A \<and> A' \<subseteq> A \<Longrightarrow> inj_on F A'"
using subset_inj_on by blast
moreover have "PiE I' (\<lambda>_. Univ) \<subseteq> PiE I (\<lambda>_. Univ)"
using assms(2) extensional_def [of I'] terminal_unity by auto
ultimately show ?thesis using \<pi> assms(2) by blast
qed
ultimately show ?thesis using admits_tupling_def by metis
qed
lemma has_products_iff_admits_tupling:
fixes I :: "'i set"
shows "has_products I \<longleftrightarrow> I \<noteq> UNIV \<and> admits_tupling I"
proof
text\<open>
If @{term[source=true] S} has @{term I}-indexed products, then for every @{term I}-indexed
discrete diagram @{term D} in @{term[source=true] S} there is an object @{term \<Pi>D}
of @{term[source=true] S} whose points are in bijective correspondence with the set of
cones over @{term D} with apex @{term unity}. In particular this is true for
the diagram @{term D} that assigns to each element of @{term I} the
``universal object'' @{term "mkIde Univ"}.
\<close>
assume has_products: "has_products I"
have I: "I \<noteq> UNIV" using has_products has_products_def by auto
- interpret J: discrete_category I "SOME x. x \<notin> I"
+ interpret J: discrete_category I \<open>SOME x. x \<notin> I\<close>
using I someI_ex [of "\<lambda>x. x \<notin> I"] by (unfold_locales, auto)
let ?D = "\<lambda>i. mkIde Univ"
- interpret D: discrete_diagram_from_map I S ?D "SOME j. j \<notin> I"
+ interpret D: discrete_diagram_from_map I S ?D \<open>SOME j. j \<notin> I\<close>
using J.not_arr_null J.arr_char
by (unfold_locales, auto)
interpret D: discrete_diagram_in_set_category J.comp S D.map ..
have "discrete_diagram J.comp S D.map" ..
from this obtain \<Pi>D \<chi> where \<chi>: "product_cone J.comp S D.map \<Pi>D \<chi>"
using has_products has_products_def [of I] ex_productE [of "J.comp" D.map]
D.diagram_axioms
by blast
interpret \<chi>: product_cone J.comp S D.map \<Pi>D \<chi>
using \<chi> by auto
have "D.has_as_limit \<Pi>D"
using \<chi>.limit_cone_axioms by auto
hence \<Pi>D: "ide \<Pi>D \<and> (\<exists>\<phi>. bij_betw \<phi> (hom unity \<Pi>D) (D.cones unity))"
using D.limits_are_sets_of_cones by simp
from this obtain \<phi> where \<phi>: "bij_betw \<phi> (hom unity \<Pi>D) (D.cones unity)"
by blast
have \<phi>': "inv_into (hom unity \<Pi>D) \<phi> \<in> D.cones unity \<rightarrow> hom unity \<Pi>D \<and>
inj_on (inv_into (hom unity \<Pi>D) \<phi>) (D.cones unity)"
using \<phi> bij_betw_inv_into bij_betw_imp_inj_on bij_betw_imp_funcset by blast
let ?\<pi> = "img o (inv_into (hom unity \<Pi>D) \<phi>) o D.funToCone"
have 1: "D.funToCone \<in> PiE I (set o D.map) \<rightarrow> D.cones unity"
using D.funToCone_mapsto extensional_def [of I] by auto
have 2: "inv_into (hom unity \<Pi>D) \<phi> \<in> D.cones unity \<rightarrow> hom unity \<Pi>D"
using \<phi>' by auto
have 3: "img \<in> hom unity \<Pi>D \<rightarrow> Univ"
using img_point_in_Univ by blast
have 4: "inj_on D.funToCone (PiE I (set o D.map))"
proof -
have "D.I = I" by auto
thus ?thesis
using D.bij_funToCone bij_betw_imp_inj_on by auto
qed
have 5: "inj_on (inv_into (hom unity \<Pi>D) \<phi>) (D.cones unity)"
using \<phi>' by auto
have 6: "inj_on img (hom unity \<Pi>D)"
using \<Pi>D bij_betw_points_and_set bij_betw_imp_inj_on [of img "hom unity \<Pi>D" "set \<Pi>D"]
by simp
have "?\<pi> \<in> PiE I (set o D.map) \<rightarrow> Univ"
using 1 2 3 by force
moreover have "inj_on ?\<pi> (PiE I (set o D.map))"
proof -
have 7: "\<And>A B C D F G H. F \<in> A \<rightarrow> B \<and> G \<in> B \<rightarrow> C \<and> H \<in> C \<rightarrow> D
\<and> inj_on F A \<and> inj_on G B \<and> inj_on H C
\<Longrightarrow> inj_on (H o G o F) A"
proof (intro inj_onI)
fix A :: "'a set" and B :: "'b set" and C :: "'c set" and D :: "'d set"
and F :: "'a \<Rightarrow> 'b" and G :: "'b \<Rightarrow> 'c" and H :: "'c \<Rightarrow> 'd"
assume a1: "F \<in> A \<rightarrow> B \<and> G \<in> B \<rightarrow> C \<and> H \<in> C \<rightarrow> D \<and>
inj_on F A \<and> inj_on G B \<and> inj_on H C"
fix a a'
assume a: "a \<in> A" and a': "a' \<in> A" and eq: "(H o G o F) a = (H o G o F) a'"
have "H (G (F a)) = H (G (F a'))" using eq by simp
moreover have "G (F a) \<in> C \<and> G (F a') \<in> C" using a a' a1 by auto
ultimately have "G (F a) = G (F a')" using a1 inj_onD by metis
moreover have "F a \<in> B \<and> F a' \<in> B" using a a' a1 by auto
ultimately have "F a = F a'" using a1 inj_onD by metis
thus "a = a'" using a a' a1 inj_onD by metis
qed
show ?thesis
using 1 2 3 4 5 6 7 [of D.funToCone "PiE I (set o D.map)" "D.cones unity"
"inv_into (hom unity \<Pi>D) \<phi>" "hom unity \<Pi>D"
img Univ]
by fastforce
qed
moreover have "PiE I (set o D.map) = PiE I (\<lambda>x. Univ)"
proof -
have "\<And>i. i \<in> I \<Longrightarrow> (set o D.map) i = Univ"
using J.arr_char D.map_def by simp
thus ?thesis by blast
qed
ultimately have "?\<pi> \<in> (PiE I (\<lambda>x. Univ)) \<rightarrow> Univ \<and> inj_on ?\<pi> (PiE I (\<lambda>x. Univ))"
by auto
thus "I \<noteq> UNIV \<and> admits_tupling I"
using I admits_tupling_def by auto
next
assume ex_\<pi>: "I \<noteq> UNIV \<and> admits_tupling I"
show "has_products I"
proof (unfold has_products_def)
from ex_\<pi> obtain \<pi>
where \<pi>: "\<pi> \<in> (PiE I (\<lambda>x. Univ)) \<rightarrow> Univ \<and> inj_on \<pi> (PiE I (\<lambda>x. Univ))"
using admits_tupling_def by metis
text\<open>
Given an @{term I}-indexed discrete diagram @{term D}, obtain the object @{term \<Pi>D}
of @{term[source=true] S} corresponding to the set @{term "\<pi> ` PiE I D"} of all
@{term "\<pi> d"} where \<open>d \<in> d \<in> J \<rightarrow>\<^sub>E Univ\<close> and @{term "d i \<in> D i"}
for all @{term "i \<in> I"}.
The elements of @{term \<Pi>D} are in bijective correspondence with the set of cones
over @{term D}, hence @{term \<Pi>D} is a limit of @{term D}.
\<close>
have "\<And>J D. discrete_diagram J S D \<and> Collect (partial_magma.arr J) = I
\<Longrightarrow> \<exists>\<Pi>D. has_as_product J D \<Pi>D"
proof
fix J :: "'i comp" and D
assume D: "discrete_diagram J S D \<and> Collect (partial_magma.arr J) = I"
interpret J: category J
using D discrete_diagram.axioms(1) by blast
interpret D: discrete_diagram J S D
using D by simp
interpret D: discrete_diagram_in_set_category J S D ..
let ?\<Pi>D = "mkIde (\<pi> ` PiE I (set o D))"
have 0: "ide ?\<Pi>D"
proof -
have "set o D \<in> I \<rightarrow> Pow Univ"
using Pow_iff incl_in_def o_apply elem_set_implies_incl_in
set_subset_Univ subsetI
by (metis (mono_tags, lifting) Pi_I')
hence "\<pi> ` PiE I (set o D) \<subseteq> Univ"
using \<pi> by blast
thus ?thesis using \<pi> ide_mkIde by simp
qed
hence set_\<Pi>D: "\<pi> ` PiE I (set o D) = set ?\<Pi>D"
using 0 ide_in_hom by auto
text\<open>
The elements of @{term \<Pi>D} are all values of the form @{term "\<pi> d"},
where @{term d} satisfies @{term "d i \<in> set (D i)"} for all @{term "i \<in> I"}.
Such @{term d} correspond bijectively to cones.
Since @{term \<pi>} is injective, the values @{term "\<pi> d"} correspond bijectively to cones.
\<close>
let ?\<phi> = "mkPoint ?\<Pi>D o \<pi> o D.coneToFun"
let ?\<phi>' = "D.funToCone o inv_into (PiE I (set o D)) \<pi> o img"
have 1: "\<pi> \<in> PiE I (set o D) \<rightarrow> set ?\<Pi>D \<and> inj_on \<pi> (PiE I (set o D))"
proof -
have "PiE I (set o D) \<subseteq> PiE I (\<lambda>x. Univ)"
using set_subset_Univ elem_set_implies_incl_in elem_set_implies_set_eq_singleton
incl_in_def PiE_mono
by (metis comp_apply subsetI)
thus ?thesis using \<pi> subset_inj_on set_\<Pi>D Pi_I' imageI by fastforce
qed
have 2: "inv_into (PiE I (set o D)) \<pi> \<in> set ?\<Pi>D \<rightarrow> PiE I (set o D)"
proof
fix y
assume y: "y \<in> set ?\<Pi>D"
have "y \<in> \<pi> ` (PiE I (set o D))" using y set_\<Pi>D by auto
thus "inv_into (PiE I (set o D)) \<pi> y \<in> PiE I (set o D)"
using inv_into_into [of y \<pi> "PiE I (set o D)"] by simp
qed
have 3: "\<And>x. x \<in> set ?\<Pi>D \<Longrightarrow> \<pi> (inv_into (PiE I (set o D)) \<pi> x) = x"
using set_\<Pi>D by (simp add: f_inv_into_f)
have 4: "\<And>d. d \<in> PiE I (set o D) \<Longrightarrow> inv_into (PiE I (set o D)) \<pi> (\<pi> d) = d"
using 1 by auto
have 5: "D.I = I"
using D by auto
have "bij_betw ?\<phi> (D.cones unity) (hom unity ?\<Pi>D)"
proof (intro bij_betwI)
show "?\<phi> \<in> D.cones unity \<rightarrow> hom unity ?\<Pi>D"
proof
fix \<chi>
assume \<chi>: "\<chi> \<in> D.cones unity"
show "?\<phi> \<chi> \<in> hom unity ?\<Pi>D"
using \<chi> 0 1 5 D.coneToFun_mapsto mkPoint_in_hom [of ?\<Pi>D]
by (simp, blast)
qed
show "?\<phi>' \<in> hom unity ?\<Pi>D \<rightarrow> D.cones unity"
proof
fix x
assume x: "x \<in> hom unity ?\<Pi>D"
hence "img x \<in> set ?\<Pi>D"
using img_point_elem_set by blast
hence "inv_into (PiE I (set o D)) \<pi> (img x) \<in> Pi I (set \<circ> D) \<inter> local.extensional I"
using 2 by blast
thus "?\<phi>' x \<in> D.cones unity"
using 5 D.funToCone_mapsto by auto
qed
show "\<And>x. x \<in> hom unity ?\<Pi>D \<Longrightarrow> ?\<phi> (?\<phi>' x) = x"
proof -
fix x
assume x: "x \<in> hom unity ?\<Pi>D"
show "?\<phi> (?\<phi>' x) = x"
proof -
have "D.coneToFun (D.funToCone (inv_into (PiE I (set o D)) \<pi> (img x)))
= inv_into (PiE I (set o D)) \<pi> (img x)"
using x 1 5 img_point_elem_set set_\<Pi>D D.coneToFun_funToCone by force
hence "\<pi> (D.coneToFun (D.funToCone (inv_into (PiE I (set o D)) \<pi> (img x))))
= img x"
using x 3 img_point_elem_set set_\<Pi>D by force
thus ?thesis using x 0 mkPoint_img by auto
qed
qed
show "\<And>\<chi>. \<chi> \<in> D.cones unity \<Longrightarrow> ?\<phi>' (?\<phi> \<chi>) = \<chi>"
proof -
fix \<chi>
assume \<chi>: "\<chi> \<in> D.cones unity"
show "?\<phi>' (?\<phi> \<chi>) = \<chi>"
proof -
have "img (mkPoint ?\<Pi>D (\<pi> (D.coneToFun \<chi>))) = \<pi> (D.coneToFun \<chi>)"
using \<chi> 0 1 5 D.coneToFun_mapsto img_mkPoint(2) by blast
hence "inv_into (PiE I (set o D)) \<pi> (img (mkPoint ?\<Pi>D (\<pi> (D.coneToFun \<chi>))))
= D.coneToFun \<chi>"
using \<chi> D.coneToFun_mapsto 4 5 by (metis PiE)
hence "D.funToCone (inv_into (PiE I (set o D)) \<pi>
(img (mkPoint ?\<Pi>D (\<pi> (D.coneToFun \<chi>)))))
= \<chi>"
using \<chi> D.funToCone_coneToFun by auto
thus ?thesis by auto
qed
qed
qed
hence "bij_betw (inv_into (D.cones unity) ?\<phi>) (hom unity ?\<Pi>D) (D.cones unity)"
using bij_betw_inv_into by blast
hence "\<exists>\<phi>. bij_betw \<phi> (hom unity ?\<Pi>D) (D.cones unity)" by blast
hence "D.has_as_limit ?\<Pi>D"
using \<open>ide ?\<Pi>D\<close> D.limits_are_sets_of_cones by simp
from this obtain \<chi> where \<chi>: "limit_cone J S D ?\<Pi>D \<chi>" by blast
interpret \<chi>: limit_cone J S D ?\<Pi>D \<chi> using \<chi> by auto
interpret P: product_cone J S D ?\<Pi>D \<chi>
using \<chi> D.product_coneI by blast
have "product_cone J S D ?\<Pi>D \<chi>" ..
thus "has_as_product J D ?\<Pi>D"
using has_as_product_def by auto
qed
thus "I \<noteq> UNIV \<and>
(\<forall>J D. discrete_diagram J S D \<and> Collect (partial_magma.arr J) = I
\<longrightarrow> (\<exists>\<Pi>D. has_as_product J D \<Pi>D))"
using ex_\<pi> by blast
qed
qed
text\<open>
Characterization of the completeness properties enjoyed by a set category:
A set category @{term[source=true] S} has all limits at a type @{typ 'j},
if and only if @{term[source=true] S} admits @{term I}-indexed tupling
for all @{typ 'j}-sets @{term I} such that @{term "I \<noteq> UNIV"}.
\<close>
theorem has_limits_iff_admits_tupling:
shows "has_limits (undefined :: 'j) \<longleftrightarrow> (\<forall>I :: 'j set. I \<noteq> UNIV \<longrightarrow> admits_tupling I)"
proof
assume has_limits: "has_limits (undefined :: 'j)"
show "\<forall>I :: 'j set. I \<noteq> UNIV \<longrightarrow> admits_tupling I"
using has_limits has_products_if_has_limits has_products_iff_admits_tupling by blast
next
assume admits_tupling: "\<forall>I :: 'j set. I \<noteq> UNIV \<longrightarrow> admits_tupling I"
show "has_limits (undefined :: 'j)"
proof -
have 1: "\<And>I :: 'j set. I \<noteq> UNIV \<Longrightarrow> has_products I"
using admits_tupling has_products_iff_admits_tupling by auto
have "\<And>J :: 'j comp. category J \<Longrightarrow> has_products (Collect (partial_magma.arr J))"
proof -
fix J :: "'j comp"
assume J: "category J"
interpret J: category J using J by auto
have "Collect J.arr \<noteq> UNIV" using J.not_arr_null by blast
thus "has_products (Collect J.arr)"
using 1 by simp
qed
hence "\<And>J :: 'j comp. category J \<Longrightarrow> has_limits_of_shape J"
proof -
fix J :: "'j comp"
assume J: "category J"
interpret J: category J using J by auto
show "has_limits_of_shape J"
proof -
have "Collect J.arr \<noteq> UNIV" using J.not_arr_null by fast
moreover have "Collect J.ide \<noteq> UNIV" using J.not_arr_null by blast
ultimately show ?thesis
using 1 has_limits_if_has_products J.category_axioms by metis
qed
qed
thus "has_limits (undefined :: 'j)"
using has_limits_def by metis
qed
qed
end
section "Limits in Functor Categories"
text\<open>
In this section, we consider the special case of limits in functor categories,
with the objective of showing that limits in a functor category \<open>[A, B]\<close>
are given pointwise, and that \<open>[A, B]\<close> has all limits that @{term B} has.
\<close>
locale parametrized_diagram =
J: category J +
A: category A +
B: category B +
JxA: product_category J A +
binary_functor J A B D
for J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and D :: "'j * 'a \<Rightarrow> 'b"
begin
(* Notation for A.in_hom and B.in_hom is being inherited, but from where? *)
notation J.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J _\<guillemotright>")
notation JxA.comp (infixr "\<cdot>\<^sub>J\<^sub>x\<^sub>A" 55)
notation JxA.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J\<^sub>x\<^sub>A _\<guillemotright>")
text\<open>
A choice of limit cone for each diagram \<open>D (-, a)\<close>, where @{term a}
is an object of @{term[source=true] A}, extends to a functor \<open>L: A \<rightarrow> B\<close>,
where the action of @{term L} on arrows of @{term[source=true] A} is determined by
universality.
\<close>
abbreviation L
where "L \<equiv> \<lambda>l \<chi>. \<lambda>a. if A.arr a then
limit_cone.induced_arrow J B (\<lambda>j. D (j, A.cod a))
(l (A.cod a)) (\<chi> (A.cod a))
(l (A.dom a)) (vertical_composite.map J B
(\<chi> (A.dom a)) (\<lambda>j. D (j, a)))
else B.null"
abbreviation P
where "P \<equiv> \<lambda>l \<chi>. \<lambda>a f. \<guillemotleft>f : l (A.dom a) \<rightarrow>\<^sub>B l (A.cod a)\<guillemotright> \<and>
diagram.cones_map J B (\<lambda>j. D (j, A.cod a)) f (\<chi> (A.cod a)) =
vertical_composite.map J B (\<chi> (A.dom a)) (\<lambda>j. D (j, a))"
lemma L_arr:
assumes "\<forall>a. A.ide a \<longrightarrow> limit_cone J B (\<lambda>j. D (j, a)) (l a) (\<chi> a)"
shows "\<And>a. A.arr a \<Longrightarrow> (\<exists>!f. P l \<chi> a f) \<and> P l \<chi> a (L l \<chi> a)"
proof
fix a
assume a: "A.arr a"
- interpret \<chi>_dom_a: limit_cone J B "\<lambda>j. D (j, A.dom a)" "l (A.dom a)" "\<chi> (A.dom a)"
+ interpret \<chi>_dom_a: limit_cone J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>l (A.dom a)\<close> \<open>\<chi> (A.dom a)\<close>
using a assms by auto
- interpret \<chi>_cod_a: limit_cone J B "\<lambda>j. D (j, A.cod a)" "l (A.cod a)" "\<chi> (A.cod a)"
+ interpret \<chi>_cod_a: limit_cone J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>l (A.cod a)\<close> \<open>\<chi> (A.cod a)\<close>
using a assms by auto
- interpret Da: natural_transformation J B "\<lambda>j. D (j, A.dom a)" "\<lambda>j. D (j, A.cod a)"
- "\<lambda>j. D (j, a)"
+ interpret Da: natural_transformation J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>\<lambda>j. D (j, A.cod a)\<close>
+ \<open>\<lambda>j. D (j, a)\<close>
using a fixing_arr_gives_natural_transformation_2 by simp
interpret Dao\<chi>_dom_a: vertical_composite J B
- \<chi>_dom_a.A.map "\<lambda>j. D (j, A.dom a)" "\<lambda>j. D (j, A.cod a)"
- "\<chi> (A.dom a)" "\<lambda>j. D (j, a)" ..
- interpret Dao\<chi>_dom_a: cone J B "\<lambda>j. D (j, A.cod a)" "l (A.dom a)" Dao\<chi>_dom_a.map ..
+ \<chi>_dom_a.A.map \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>\<lambda>j. D (j, A.cod a)\<close>
+ \<open>\<chi> (A.dom a)\<close> \<open>\<lambda>j. D (j, a)\<close> ..
+ interpret Dao\<chi>_dom_a: cone J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>l (A.dom a)\<close> Dao\<chi>_dom_a.map ..
show "P l \<chi> a (L l \<chi> a)"
using a Dao\<chi>_dom_a.cone_axioms
\<chi>_cod_a.induced_arrowI [of Dao\<chi>_dom_a.map "l (A.dom a)"]
by auto
show "\<exists>!f. P l \<chi> a f"
using \<chi>_cod_a.is_universal Dao\<chi>_dom_a.cone_axioms by blast
qed
lemma L_ide:
assumes "\<forall>a. A.ide a \<longrightarrow> limit_cone J B (\<lambda>j. D (j, a)) (l a) (\<chi> a)"
shows "\<And>a. A.ide a \<Longrightarrow> L l \<chi> a = l a"
proof -
let ?L = "L l \<chi>"
let ?P = "P l \<chi>"
fix a
assume a: "A.ide a"
- interpret \<chi>a: limit_cone J B "\<lambda>j. D (j, a)" "l a" "\<chi> a" using a assms by auto
+ interpret \<chi>a: limit_cone J B \<open>\<lambda>j. D (j, a)\<close> \<open>l a\<close> \<open>\<chi> a\<close> using a assms by auto
have Pa: "?P a = (\<lambda>f. f \<in> B.hom (l a) (l a) \<and>
diagram.cones_map J B (\<lambda>j. D (j, a)) f (\<chi> a) = \<chi> a)"
using a vcomp_ide_dom \<chi>a.natural_transformation_axioms by simp
have "?P a (?L a)" using assms a L_arr [of l \<chi> a] by fastforce
moreover have "?P a (l a)"
proof -
have "?P a (l a) \<longleftrightarrow> l a \<in> B.hom (l a) (l a) \<and> \<chi>a.D.cones_map (l a) (\<chi> a) = \<chi> a"
using Pa by meson
thus ?thesis
using a \<chi>a.ide_apex \<chi>a.cone_axioms \<chi>a.D.cones_map_ide [of "\<chi> a" "l a"] by force
qed
moreover have "\<exists>!f. ?P a f"
using a Pa \<chi>a.is_universal \<chi>a.cone_axioms by force
ultimately show "?L a = l a" by blast
qed
lemma chosen_limits_induce_functor:
assumes "\<forall>a. A.ide a \<longrightarrow> limit_cone J B (\<lambda>j. D (j, a)) (l a) (\<chi> a)"
shows "functor A B (L l \<chi>)"
proof -
let ?L = "L l \<chi>"
let ?P = "\<lambda>a. \<lambda>f. \<guillemotleft>f : l (A.dom a) \<rightarrow>\<^sub>B l (A.cod a)\<guillemotright> \<and>
diagram.cones_map J B (\<lambda>j. D (j, A.cod a)) f (\<chi> (A.cod a))
= vertical_composite.map J B (\<chi> (A.dom a)) (\<lambda>j. D (j, a))"
interpret L: "functor" A B ?L
apply unfold_locales
using assms L_arr [of l] L_ide
apply auto[4]
proof -
fix a' a
assume 1: "A.arr (A a' a)"
have a: "A.arr a" using 1 by auto
have a': "\<guillemotleft>a' : A.cod a \<rightarrow>\<^sub>A A.cod a'\<guillemotright>" using 1 by auto
have a'a: "A.seq a' a" using 1 by auto
- interpret \<chi>_dom_a: limit_cone J B "\<lambda>j. D (j, A.dom a)" "l (A.dom a)" "\<chi> (A.dom a)"
+ interpret \<chi>_dom_a: limit_cone J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>l (A.dom a)\<close> \<open>\<chi> (A.dom a)\<close>
using a assms by auto
- interpret \<chi>_cod_a: limit_cone J B "\<lambda>j. D (j, A.cod a)" "l (A.cod a)" "\<chi> (A.cod a)"
- using a'a assms by auto
- interpret \<chi>_dom_a'a: limit_cone J B "\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))" "l (A.dom (a' \<cdot>\<^sub>A a))"
- "\<chi> (A.dom (a' \<cdot>\<^sub>A a))"
+ interpret \<chi>_cod_a: limit_cone J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>l (A.cod a)\<close> \<open>\<chi> (A.cod a)\<close>
using a'a assms by auto
- interpret \<chi>_cod_a'a: limit_cone J B "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))" "l (A.cod (a' \<cdot>\<^sub>A a))"
- "\<chi> (A.cod (a' \<cdot>\<^sub>A a))"
+ interpret \<chi>_dom_a'a: limit_cone J B \<open>\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))\<close> \<open>l (A.dom (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<chi> (A.dom (a' \<cdot>\<^sub>A a))\<close>
using a'a assms by auto
- interpret Da: natural_transformation J B "\<lambda>j. D (j, A.dom a)" "\<lambda>j. D (j, A.cod a)"
- "\<lambda>j. D (j, a)"
+ interpret \<chi>_cod_a'a: limit_cone J B \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>l (A.cod (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<chi> (A.cod (a' \<cdot>\<^sub>A a))\<close>
+ using a'a assms by auto
+ interpret Da: natural_transformation J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>\<lambda>j. D (j, A.cod a)\<close>
+ \<open>\<lambda>j. D (j, a)\<close>
using a fixing_arr_gives_natural_transformation_2 by simp
- interpret Da': natural_transformation J B "\<lambda>j. D (j, A.cod a)" "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))"
- "\<lambda>j. D (j, a')"
+ interpret Da': natural_transformation J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<lambda>j. D (j, a')\<close>
using a a'a fixing_arr_gives_natural_transformation_2 by fastforce
interpret Da'o\<chi>_cod_a: vertical_composite J B
- \<chi>_cod_a.A.map "\<lambda>j. D (j, A.cod a)" "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))"
- "\<chi> (A.cod a)" "\<lambda>j. D (j, a')" ..
- interpret Da'o\<chi>_cod_a: cone J B "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))" "l (A.cod a)" Da'o\<chi>_cod_a.map ..
+ \<chi>_cod_a.A.map \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<chi> (A.cod a)\<close> \<open>\<lambda>j. D (j, a')\<close>..
+ interpret Da'o\<chi>_cod_a: cone J B \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>l (A.cod a)\<close> Da'o\<chi>_cod_a.map ..
interpret Da'a: natural_transformation J B
- "\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))" "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))"
- "\<lambda>j. D (j, a' \<cdot>\<^sub>A a)"
+ \<open>\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))\<close> \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<lambda>j. D (j, a' \<cdot>\<^sub>A a)\<close>
using a'a fixing_arr_gives_natural_transformation_2 [of "a' \<cdot>\<^sub>A a"] by auto
interpret Da'ao\<chi>_dom_a'a:
- vertical_composite J B \<chi>_dom_a'a.A.map "\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))"
- "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))" "\<chi> (A.dom (a' \<cdot>\<^sub>A a))"
- "\<lambda>j. D (j, a' \<cdot>\<^sub>A a)" ..
- interpret Da'ao\<chi>_dom_a'a: cone J B "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))"
- "l (A.dom (a' \<cdot>\<^sub>A a))" Da'ao\<chi>_dom_a'a.map ..
+ vertical_composite J B \<chi>_dom_a'a.A.map \<open>\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>\<chi> (A.dom (a' \<cdot>\<^sub>A a))\<close>
+ \<open>\<lambda>j. D (j, a' \<cdot>\<^sub>A a)\<close> ..
+ interpret Da'ao\<chi>_dom_a'a: cone J B \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
+ \<open>l (A.dom (a' \<cdot>\<^sub>A a))\<close> Da'ao\<chi>_dom_a'a.map ..
show "?L (a' \<cdot>\<^sub>A a) = ?L a' \<cdot>\<^sub>B ?L a"
proof -
have "?P (a' \<cdot>\<^sub>A a) (?L (a' \<cdot>\<^sub>A a))" using assms a'a L_arr [of l \<chi> "a' \<cdot>\<^sub>A a"] by fastforce
moreover have "?P (a' \<cdot>\<^sub>A a) (?L a' \<cdot>\<^sub>B ?L a)"
proof
have La: "\<guillemotleft>?L a : l (A.dom a) \<rightarrow>\<^sub>B l (A.cod a)\<guillemotright>"
using assms a L_arr by fast
moreover have La': "\<guillemotleft>?L a' : l (A.cod a) \<rightarrow>\<^sub>B l (A.cod a')\<guillemotright>"
using assms a a' L_arr [of l \<chi> a'] by auto
ultimately have seq: "B.seq (?L a') (?L a)" by (elim B.in_homE, auto)
thus La'_La: "\<guillemotleft>?L a' \<cdot>\<^sub>B ?L a : l (A.dom (a' \<cdot>\<^sub>A a)) \<rightarrow>\<^sub>B l (A.cod (a' \<cdot>\<^sub>A a))\<guillemotright>"
using a a' 1 La La' by (intro B.comp_in_homI, auto)
show "\<chi>_cod_a'a.D.cones_map (?L a' \<cdot>\<^sub>B ?L a) (\<chi> (A.cod (a' \<cdot>\<^sub>A a)))
= Da'ao\<chi>_dom_a'a.map"
proof -
have "\<chi>_cod_a'a.D.cones_map (?L a' \<cdot>\<^sub>B ?L a) (\<chi> (A.cod (a' \<cdot>\<^sub>A a)))
= (\<chi>_cod_a'a.D.cones_map (?L a) o \<chi>_cod_a'a.D.cones_map (?L a'))
(\<chi> (A.cod a'))"
proof -
have "\<chi>_cod_a'a.D.cones_map (?L a' \<cdot>\<^sub>B ?L a) (\<chi> (A.cod (a' \<cdot>\<^sub>A a))) =
restrict (\<chi>_cod_a'a.D.cones_map (?L a) \<circ> \<chi>_cod_a'a.D.cones_map (?L a'))
(\<chi>_cod_a'a.D.cones (B.cod (?L a')))
(\<chi> (A.cod (a' \<cdot>\<^sub>A a)))"
using seq \<chi>_cod_a'a.cone_axioms \<chi>_cod_a'a.D.cones_map_comp [of "?L a'" "?L a"]
by argo
also have "... = (\<chi>_cod_a'a.D.cones_map (?L a) o \<chi>_cod_a'a.D.cones_map (?L a'))
(\<chi> (A.cod a'))"
proof -
have "\<chi> (A.cod a') \<in> \<chi>_cod_a'a.D.cones (l (A.cod a'))"
using \<chi>_cod_a'a.cone_axioms a'a by simp
moreover have "B.cod (?L a') = l (A.cod a')"
using assms a' L_arr [of l] by auto
ultimately show ?thesis
using a' a'a by simp
qed
finally show ?thesis by blast
qed
also have "... = \<chi>_cod_a'a.D.cones_map (?L a)
(\<chi>_cod_a'a.D.cones_map (?L a') (\<chi> (A.cod a')))"
by simp
also have "... = \<chi>_cod_a'a.D.cones_map (?L a) Da'o\<chi>_cod_a.map"
proof -
have "?P a' (?L a')" using assms a' L_arr [of l \<chi> a'] by fast
moreover have
"?P a' = (\<lambda>f. f \<in> B.hom (l (A.cod a)) (l (A.cod a')) \<and>
\<chi>_cod_a'a.D.cones_map f (\<chi> (A.cod a')) = Da'o\<chi>_cod_a.map)"
using a'a by force
ultimately show ?thesis using a'a by force
qed
also have "... = vertical_composite.map J B
(\<chi>_cod_a.D.cones_map (?L a) (\<chi> (A.cod a)))
(\<lambda>j. D (j, a'))"
using assms \<chi>_cod_a.D.diagram_axioms \<chi>_cod_a'a.D.diagram_axioms
Da'.natural_transformation_axioms \<chi>_cod_a.cone_axioms La
cones_map_vcomp [of J B "\<lambda>j. D (j, A.cod a)" "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))"
"\<lambda>j. D (j, a')" "l (A.cod a)" "\<chi> (A.cod a)"
"?L a" "l (A.dom a)"]
by blast
also have "... = vertical_composite.map J B
(vertical_composite.map J B (\<chi> (A.dom a)) (\<lambda>j. D (j, a)))
(\<lambda>j. D (j, a'))"
using assms a L_arr by presburger
also have "... = vertical_composite.map J B (\<chi> (A.dom a))
(vertical_composite.map J B (\<lambda>j. D (j, a)) (\<lambda>j. D (j, a')))"
using a'a Da.natural_transformation_axioms Da'.natural_transformation_axioms
\<chi>_dom_a.natural_transformation_axioms
vcomp_assoc [of J B \<chi>_dom_a.A.map "\<lambda>j. D (j, A.dom a)" "\<chi> (A.dom a)"
"\<lambda>j. D (j, A.cod a)" "\<lambda>j. D (j, a)"
"\<lambda>j. D (j, A.cod a')" "\<lambda>j. D (j, a')"]
by auto
also have
"... = vertical_composite.map J B (\<chi> (A.dom (a' \<cdot>\<^sub>A a))) (\<lambda>j. D (j, a' \<cdot>\<^sub>A a))"
using a'a preserves_comp_2 by simp
finally show ?thesis by auto
qed
qed
moreover have "\<exists>!f. ?P (a' \<cdot>\<^sub>A a) f"
using \<chi>_cod_a'a.is_universal
[of "l (A.dom (a' \<cdot>\<^sub>A a))"
"vertical_composite.map J B (\<chi> (A.dom (a' \<cdot>\<^sub>A a))) (\<lambda>j. D (j, a' \<cdot>\<^sub>A a))"]
Da'ao\<chi>_dom_a'a.cone_axioms
by fast
ultimately show ?thesis by blast
qed
qed
show ?thesis ..
qed
end
locale diagram_in_functor_category =
A: category A +
B: category B +
A_B: functor_category A B +
diagram J A_B.comp D
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and J :: "'j comp" (infixr "\<cdot>\<^sub>J" 55)
and D :: "'j \<Rightarrow> ('a, 'b) functor_category.arr"
begin
interpretation JxA: product_category J A ..
interpretation A_BxA: product_category A_B.comp A ..
interpretation E: evaluation_functor A B ..
interpretation Curry: currying J A B ..
notation JxA.comp (infixr "\<cdot>\<^sub>J\<^sub>x\<^sub>A" 55)
notation JxA.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J\<^sub>x\<^sub>A _\<guillemotright>")
text\<open>
Evaluation of a functor or natural transformation from @{term[source=true] J}
to \<open>[A, B]\<close> at an arrow @{term a} of @{term[source=true] A}.
\<close>
abbreviation at
where "at a \<tau> \<equiv> \<lambda>j. Curry.uncurry \<tau> (j, a)"
lemma at_simp:
assumes "A.arr a" and "J.arr j" and "A_B.arr (\<tau> j)"
- shows "at a \<tau> j = A_B.Fun (\<tau> j) a"
+ shows "at a \<tau> j = A_B.Map (\<tau> j) a"
using assms Curry.uncurry_def E.map_simp by simp
lemma functor_at_ide_is_functor:
assumes "functor J A_B.comp F" and "A.ide a"
shows "functor J B (at a F)"
proof -
- interpret uncurry_F: "functor" JxA.comp B "Curry.uncurry F"
+ interpret uncurry_F: "functor" JxA.comp B \<open>Curry.uncurry F\<close>
using assms(1) Curry.uncurry_preserves_functors by simp
- interpret uncurry_F: binary_functor J A B "Curry.uncurry F" ..
+ interpret uncurry_F: binary_functor J A B \<open>Curry.uncurry F\<close> ..
show ?thesis using assms(2) uncurry_F.fixing_ide_gives_functor_2 by simp
qed
lemma functor_at_arr_is_transformation:
assumes "functor J A_B.comp F" and "A.arr a"
shows "natural_transformation J B (at (A.dom a) F) (at (A.cod a) F) (at a F)"
proof -
- interpret uncurry_F: "functor" JxA.comp B "Curry.uncurry F"
+ interpret uncurry_F: "functor" JxA.comp B \<open>Curry.uncurry F\<close>
using assms(1) Curry.uncurry_preserves_functors by simp
- interpret uncurry_F: binary_functor J A B "Curry.uncurry F" ..
+ interpret uncurry_F: binary_functor J A B \<open>Curry.uncurry F\<close> ..
show ?thesis
using assms(2) uncurry_F.fixing_arr_gives_natural_transformation_2 by simp
qed
lemma transformation_at_ide_is_transformation:
assumes "natural_transformation J A_B.comp F G \<tau>" and "A.ide a"
shows "natural_transformation J B (at a F) (at a G) (at a \<tau>)"
proof -
interpret \<tau>: natural_transformation J A_B.comp F G \<tau> using assms(1) by auto
- interpret uncurry_F: "functor" JxA.comp B "Curry.uncurry F"
+ interpret uncurry_F: "functor" JxA.comp B \<open>Curry.uncurry F\<close>
using Curry.uncurry_preserves_functors \<tau>.F.functor_axioms by simp
- interpret uncurry_f: binary_functor J A B "Curry.uncurry F" ..
- interpret uncurry_G: "functor" JxA.comp B "Curry.uncurry G"
+ interpret uncurry_f: binary_functor J A B \<open>Curry.uncurry F\<close> ..
+ interpret uncurry_G: "functor" JxA.comp B \<open>Curry.uncurry G\<close>
using Curry.uncurry_preserves_functors \<tau>.G.functor_axioms by simp
- interpret uncurry_G: binary_functor J A B "Curry.uncurry G" ..
+ interpret uncurry_G: binary_functor J A B \<open>Curry.uncurry G\<close> ..
interpret uncurry_\<tau>: natural_transformation
- JxA.comp B "Curry.uncurry F" "Curry.uncurry G" "Curry.uncurry \<tau>"
+ JxA.comp B \<open>Curry.uncurry F\<close> \<open>Curry.uncurry G\<close> \<open>Curry.uncurry \<tau>\<close>
using Curry.uncurry_preserves_transformations \<tau>.natural_transformation_axioms
by simp
interpret uncurry_\<tau>: binary_functor_transformation J A B
- "Curry.uncurry F" "Curry.uncurry G" "Curry.uncurry \<tau>" ..
+ \<open>Curry.uncurry F\<close> \<open>Curry.uncurry G\<close> \<open>Curry.uncurry \<tau>\<close> ..
show ?thesis
using assms(2) uncurry_\<tau>.fixing_ide_gives_natural_transformation_2 by simp
qed
lemma constant_at_ide_is_constant:
assumes "cone x \<chi>" and a: "A.ide a"
shows "at a (constant_functor.map J A_B.comp x) =
- constant_functor.map J B (A_B.Fun x a)"
+ constant_functor.map J B (A_B.Map x a)"
proof -
interpret \<chi>: cone J A_B.comp D x \<chi> using assms(1) by auto
have x: "A_B.ide x" using \<chi>.ide_apex by auto
- interpret Fun_x: "functor" A B "A_B.Fun x"
+ interpret Fun_x: "functor" A B \<open>A_B.Map x\<close>
using x A_B.ide_char by simp
- interpret Da: "functor" J B "at a D"
+ interpret Da: "functor" J B \<open>at a D\<close>
using a functor_at_ide_is_functor functor_axioms by blast
- interpret Da: diagram J B "at a D" ..
- interpret Xa: constant_functor J B "A_B.Fun x a"
+ interpret Da: diagram J B \<open>at a D\<close> ..
+ interpret Xa: constant_functor J B \<open>A_B.Map x a\<close>
using a Fun_x.preserves_ide [of a] by (unfold_locales, simp)
show "at a \<chi>.A.map = Xa.map"
using a x Curry.uncurry_def E.map_def Xa.is_extensional by auto
qed
lemma at_ide_is_diagram:
assumes a: "A.ide a"
shows "diagram J B (at a D)"
proof -
interpret Da: "functor" J B "at a D"
using a functor_at_ide_is_functor functor_axioms by simp
show ?thesis ..
qed
lemma cone_at_ide_is_cone:
assumes "cone x \<chi>" and a: "A.ide a"
- shows "diagram.cone J B (at a D) (A_B.Fun x a) (at a \<chi>)"
+ shows "diagram.cone J B (at a D) (A_B.Map x a) (at a \<chi>)"
proof -
interpret \<chi>: cone J A_B.comp D x \<chi> using assms(1) by auto
have x: "A_B.ide x" using \<chi>.ide_apex by auto
- interpret Fun_x: "functor" A B "A_B.Fun x"
+ interpret Fun_x: "functor" A B \<open>A_B.Map x\<close>
using x A_B.ide_char by simp
- interpret Da: diagram J B "at a D" using a at_ide_is_diagram by auto
- interpret Xa: constant_functor J B "A_B.Fun x a"
+ interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
+ interpret Xa: constant_functor J B \<open>A_B.Map x a\<close>
using a by (unfold_locales, simp)
- interpret \<chi>a: natural_transformation J B Xa.map "at a D" "at a \<chi>"
+ interpret \<chi>a: natural_transformation J B Xa.map \<open>at a D\<close> \<open>at a \<chi>\<close>
using assms(1) x a transformation_at_ide_is_transformation \<chi>.natural_transformation_axioms
constant_at_ide_is_constant
by fastforce
- interpret \<chi>a: cone J B "at a D" "A_B.Fun x a" "at a \<chi>" ..
- show cone_\<chi>a: "Da.cone (A_B.Fun x a) (at a \<chi>)" ..
+ interpret \<chi>a: cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close> ..
+ show cone_\<chi>a: "Da.cone (A_B.Map x a) (at a \<chi>)" ..
qed
lemma at_preserves_comp:
assumes "A.seq a' a"
shows "at (A a' a) D = vertical_composite.map J B (at a D) (at a' D)"
proof -
- interpret Da: natural_transformation J B "at (A.dom a) D" "at (A.cod a) D" "at a D"
+ interpret Da: natural_transformation J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close> \<open>at a D\<close>
using assms functor_at_arr_is_transformation functor_axioms by blast
- interpret Da': natural_transformation J B "at (A.cod a) D" "at (A.cod a') D" "at a' D"
+ interpret Da': natural_transformation J B \<open>at (A.cod a) D\<close> \<open>at (A.cod a') D\<close> \<open>at a' D\<close>
using assms functor_at_arr_is_transformation [of D a'] functor_axioms by fastforce
- interpret Da'oDa: vertical_composite J B "at (A.dom a) D" "at (A.cod a) D" "at (A.cod a') D"
- "at a D" "at a' D" ..
- interpret Da'a: natural_transformation J B "at (A.dom a) D" "at (A.cod a') D" "at (a' \<cdot>\<^sub>A a) D"
+ interpret Da'oDa: vertical_composite J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close> \<open>at (A.cod a') D\<close>
+ \<open>at a D\<close> \<open>at a' D\<close> ..
+ interpret Da'a: natural_transformation J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a') D\<close> \<open>at (a' \<cdot>\<^sub>A a) D\<close>
using assms functor_at_arr_is_transformation [of D "a' \<cdot>\<^sub>A a"] functor_axioms by simp
show "at (a' \<cdot>\<^sub>A a) D = Da'oDa.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) Da'oDa.map" ..
show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) (at (a' \<cdot>\<^sub>A a) D)" ..
show "\<And>j. J.ide j \<Longrightarrow> at (a' \<cdot>\<^sub>A a) D j = Da'oDa.map j"
proof -
fix j
assume j: "J.ide j"
- interpret Dj: "functor" A B "A_B.Fun (D j)"
+ interpret Dj: "functor" A B \<open>A_B.Map (D j)\<close>
using j preserves_ide A_B.ide_char by simp
show "at (a' \<cdot>\<^sub>A a) D j = Da'oDa.map j"
using assms j Dj.preserves_comp at_simp Da'oDa.map_simp_ide by auto
qed
qed
qed
lemma cones_map_pointwise:
assumes "cone x \<chi>" and "cone x' \<chi>'"
and f: "f \<in> A_B.hom x' x"
shows "cones_map f \<chi> = \<chi>' \<longleftrightarrow>
- (\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Fun f a) (at a \<chi>) = at a \<chi>')"
+ (\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>')"
proof
interpret \<chi>: cone J A_B.comp D x \<chi> using assms(1) by auto
interpret \<chi>': cone J A_B.comp D x' \<chi>' using assms(2) by auto
have x: "A_B.ide x" using \<chi>.ide_apex by auto
have x': "A_B.ide x'" using \<chi>'.ide_apex by auto
- interpret \<chi>f: cone J A_B.comp D x' "cones_map f \<chi>"
+ interpret \<chi>f: cone J A_B.comp D x' \<open>cones_map f \<chi>\<close>
using x' f assms(1) cones_map_mapsto by blast
- interpret Fun_x: "functor" A B "A_B.Fun x" using x A_B.ide_char by simp
- interpret Fun_x': "functor" A B "A_B.Fun x'" using x' A_B.ide_char by simp
+ interpret Fun_x: "functor" A B \<open>A_B.Map x\<close> using x A_B.ide_char by simp
+ interpret Fun_x': "functor" A B \<open>A_B.Map x'\<close> using x' A_B.ide_char by simp
show "cones_map f \<chi> = \<chi>' \<Longrightarrow>
- (\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Fun f a) (at a \<chi>) = at a \<chi>')"
+ (\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>')"
proof -
assume \<chi>': "cones_map f \<chi> = \<chi>'"
- have "\<And>a. A.ide a \<Longrightarrow> diagram.cones_map J B (at a D) (A_B.Fun f a) (at a \<chi>) = at a \<chi>'"
+ have "\<And>a. A.ide a \<Longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
proof -
fix a
assume a: "A.ide a"
- interpret Da: diagram J B "at a D" using a at_ide_is_diagram by auto
- interpret \<chi>a: cone J B "at a D" "A_B.Fun x a" "at a \<chi>"
+ interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
+ interpret \<chi>a: cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close>
using a assms(1) cone_at_ide_is_cone by simp
- interpret \<chi>'a: cone J B "at a D" "A_B.Fun x' a" "at a \<chi>'"
+ interpret \<chi>'a: cone J B \<open>at a D\<close> \<open>A_B.Map x' a\<close> \<open>at a \<chi>'\<close>
using a assms(2) cone_at_ide_is_cone by simp
- have 1: "\<guillemotleft>A_B.Fun f a : A_B.Fun x' a \<rightarrow>\<^sub>B A_B.Fun x a\<guillemotright>"
- using f a A_B.arr_char A_B.Fun_cod A_B.Fun_dom mem_Collect_eq
+ have 1: "\<guillemotleft>A_B.Map f a : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright>"
+ using f a A_B.arr_char A_B.Map_cod A_B.Map_dom mem_Collect_eq
natural_transformation.preserves_hom A.ide_in_hom
- by (metis A_B.in_homE)
- interpret \<chi>fa: cone J B "at a D" "A_B.Fun x' a" "Da.cones_map (A_B.Fun f a) (at a \<chi>)"
+ by (metis (no_types, lifting) A_B.in_homE)
+ interpret \<chi>fa: cone J B \<open>at a D\<close> \<open>A_B.Map x' a\<close> \<open>Da.cones_map (A_B.Map f a) (at a \<chi>)\<close>
using 1 \<chi>a.cone_axioms Da.cones_map_mapsto by force
- show "Da.cones_map (A_B.Fun f a) (at a \<chi>) = at a \<chi>'"
+ show "Da.cones_map (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
proof
fix j
- have "\<not>J.arr j \<Longrightarrow> Da.cones_map (A_B.Fun f a) (at a \<chi>) j = at a \<chi>' j"
+ have "\<not>J.arr j \<Longrightarrow> Da.cones_map (A_B.Map f a) (at a \<chi>) j = at a \<chi>' j"
using \<chi>'a.is_extensional \<chi>fa.is_extensional [of j] by simp
- moreover have "J.arr j \<Longrightarrow> Da.cones_map (A_B.Fun f a) (at a \<chi>) j = at a \<chi>' j"
+ moreover have "J.arr j \<Longrightarrow> Da.cones_map (A_B.Map f a) (at a \<chi>) j = at a \<chi>' j"
using a f 1 \<chi>.cone_axioms \<chi>a.cone_axioms at_simp apply simp
apply (elim A_B.in_homE B.in_homE, auto)
- using \<chi>' \<chi>.A.map_simp A_B.Fun_comp [of "\<chi> j" f a a] by auto
- ultimately show "Da.cones_map (A_B.Fun f a) (at a \<chi>) j = at a \<chi>' j" by blast
+ using \<chi>' \<chi>.A.map_simp A_B.Map_comp [of "\<chi> j" f a a] by auto
+ ultimately show "Da.cones_map (A_B.Map f a) (at a \<chi>) j = at a \<chi>' j" by blast
qed
qed
- thus "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Fun f a) (at a \<chi>) = at a \<chi>'"
+ thus "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
by simp
qed
- show "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Fun f a) (at a \<chi>) = at a \<chi>'
+ show "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'
\<Longrightarrow> cones_map f \<chi> = \<chi>'"
proof -
assume A:
- "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Fun f a) (at a \<chi>) = at a \<chi>'"
+ "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
show "cones_map f \<chi> = \<chi>'"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J A_B.comp \<chi>'.A.map D (cones_map f \<chi>)" ..
show "natural_transformation J A_B.comp \<chi>'.A.map D \<chi>'" ..
show "\<And>j. J.ide j \<Longrightarrow> cones_map f \<chi> j = \<chi>' j"
proof (intro A_B.arr_eqI)
fix j
assume j: "J.ide j"
show 1: "A_B.arr (cones_map f \<chi> j)"
using j \<chi>f.preserves_reflects_arr by simp
show "A_B.arr (\<chi>' j)" using j by auto
- have Dom_\<chi>f_j: "A_B.Dom (cones_map f \<chi> j) = A_B.Fun x'"
- using x' j 1 A_B.Fun_dom \<chi>'.A.map_simp [of "J.dom j"] \<chi>f.preserves_dom J.ide_in_hom
- by (metis (no_types, lifting) J.in_homE)
+ have Dom_\<chi>f_j: "A_B.Dom (cones_map f \<chi> j) = A_B.Map x'"
+ using x' j 1 A_B.Map_dom \<chi>'.A.map_simp [of "J.dom j"] \<chi>f.preserves_dom J.ide_in_hom
+ by (metis (no_types, lifting) J.ideD(2) \<chi>f.preserves_reflects_arr)
also have Dom_\<chi>'_j: "... = A_B.Dom (\<chi>' j)"
- using x' j A_B.Fun_dom [of "\<chi>' j"] \<chi>'.preserves_hom \<chi>'.A.map_simp by simp
+ using x' j A_B.Map_dom [of "\<chi>' j"] \<chi>'.preserves_hom \<chi>'.A.map_simp by simp
finally show "A_B.Dom (cones_map f \<chi> j) = A_B.Dom (\<chi>' j)" by auto
- have Cod_\<chi>f_j: "A_B.Cod (cones_map f \<chi> j) = A_B.Fun (D (J.cod j))"
- using j A_B.Fun_cod [of "cones_map f \<chi> j"] A_B.cod_simp J.ide_in_hom
+ have Cod_\<chi>f_j: "A_B.Cod (cones_map f \<chi> j) = A_B.Map (D (J.cod j))"
+ using j A_B.Map_cod [of "cones_map f \<chi> j"] A_B.cod_char J.ide_in_hom
\<chi>f.preserves_hom [of j "J.dom j" "J.cod j"]
- by auto
+ by (metis (no_types, lifting) "1" J.ideD(1) \<chi>f.preserves_cod)
also have Cod_\<chi>'_j: "... = A_B.Cod (\<chi>' j)"
- using j A_B.Fun_cod [of "\<chi>' j"] \<chi>'.preserves_hom by simp
+ using j A_B.Map_cod [of "\<chi>' j"] \<chi>'.preserves_hom by simp
finally show "A_B.Cod (cones_map f \<chi> j) = A_B.Cod (\<chi>' j)" by auto
- show "A_B.Fun (cones_map f \<chi> j) = A_B.Fun (\<chi>' j)"
+ show "A_B.Map (cones_map f \<chi> j) = A_B.Map (\<chi>' j)"
proof (intro NaturalTransformation.eqI)
- interpret \<chi>fj: natural_transformation A B "A_B.Fun x'" "A_B.Fun (D (J.cod j))"
- "A_B.Fun (cones_map f \<chi> j)"
+ interpret \<chi>fj: natural_transformation A B \<open>A_B.Map x'\<close> \<open>A_B.Map (D (J.cod j))\<close>
+ \<open>A_B.Map (cones_map f \<chi> j)\<close>
using j \<chi>f.preserves_reflects_arr A_B.arr_char [of "cones_map f \<chi> j"]
Dom_\<chi>f_j Cod_\<chi>f_j
by simp
- show "natural_transformation A B (A_B.Fun x') (A_B.Fun (D (J.cod j)))
- (A_B.Fun (cones_map f \<chi> j))" ..
- interpret \<chi>'j: natural_transformation A B "A_B.Fun x'" "A_B.Fun (D (J.cod j))"
- "A_B.Fun (\<chi>' j)"
+ show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
+ (A_B.Map (cones_map f \<chi> j))" ..
+ interpret \<chi>'j: natural_transformation A B \<open>A_B.Map x'\<close> \<open>A_B.Map (D (J.cod j))\<close>
+ \<open>A_B.Map (\<chi>' j)\<close>
using j A_B.arr_char [of "\<chi>' j"] Dom_\<chi>'_j Cod_\<chi>'_j by simp
- show "natural_transformation A B (A_B.Fun x') (A_B.Fun (D (J.cod j)))
- (A_B.Fun (\<chi>' j))" ..
- show "\<And>a. A.ide a \<Longrightarrow> A_B.Fun (cones_map f \<chi> j) a = A_B.Fun (\<chi>' j) a"
+ show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
+ (A_B.Map (\<chi>' j))" ..
+ show "\<And>a. A.ide a \<Longrightarrow> A_B.Map (cones_map f \<chi> j) a = A_B.Map (\<chi>' j) a"
proof -
fix a
assume a: "A.ide a"
- interpret Da: diagram J B "at a D" using a at_ide_is_diagram by auto
- have cone_\<chi>a: "Da.cone (A_B.Fun x a) (at a \<chi>)"
+ interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
+ have cone_\<chi>a: "Da.cone (A_B.Map x a) (at a \<chi>)"
using a assms(1) cone_at_ide_is_cone by simp
- interpret \<chi>a: cone J B "at a D" "A_B.Fun x a" "at a \<chi>"
+ interpret \<chi>a: cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close>
using cone_\<chi>a by auto
- interpret Fun_f: natural_transformation A B "A_B.Dom f" "A_B.Cod f" "A_B.Fun f"
+ interpret Fun_f: natural_transformation A B \<open>A_B.Dom f\<close> \<open>A_B.Cod f\<close> \<open>A_B.Map f\<close>
using f A_B.arr_char by fast
- have fa: "A_B.Fun f a \<in> B.hom (A_B.Fun x' a) (A_B.Fun x a)"
+ have fa: "A_B.Map f a \<in> B.hom (A_B.Map x' a) (A_B.Map x a)"
using a f Fun_f.preserves_hom A.ide_in_hom by auto
- have "A_B.Fun (cones_map f \<chi> j) a = Da.cones_map (A_B.Fun f a) (at a \<chi>) j"
+ have "A_B.Map (cones_map f \<chi> j) a = Da.cones_map (A_B.Map f a) (at a \<chi>) j"
proof -
- have "A_B.Fun (cones_map f \<chi> j) a = A_B.Fun (A_B.comp (\<chi> j) f) a"
+ have "A_B.Map (cones_map f \<chi> j) a = A_B.Map (A_B.comp (\<chi> j) f) a"
using assms(1) f \<chi>.is_extensional by auto
- also have "... = B (A_B.Fun (\<chi> j) a) (A_B.Fun f a)"
- using f j a \<chi>.preserves_hom A.ide_in_hom J.ide_in_hom A_B.Fun_comp
+ also have "... = B (A_B.Map (\<chi> j) a) (A_B.Map f a)"
+ using f j a \<chi>.preserves_hom A.ide_in_hom J.ide_in_hom A_B.Map_comp
\<chi>.A.map_simp
- by (metis A.in_homE A.comp_ide_self A_B.Fun_comp A_B.seqI'
- J.in_homE mem_Collect_eq)
- also have "... = Da.cones_map (A_B.Fun f a) (at a \<chi>) j"
+ by (metis (no_types, lifting) A.comp_ide_self A.ideD(1) A_B.seqI'
+ J.ideD(1) mem_Collect_eq)
+ also have "... = Da.cones_map (A_B.Map f a) (at a \<chi>) j"
using j a cone_\<chi>a fa Curry.uncurry_def E.map_simp by auto
finally show ?thesis by auto
qed
also have "... = at a \<chi>' j" using j a A by simp
- also have "... = A_B.Fun (\<chi>' j) a"
+ also have "... = A_B.Map (\<chi>' j) a"
using j Curry.uncurry_def E.map_simp \<chi>'j.is_extensional by simp
- finally show "A_B.Fun (cones_map f \<chi> j) a = A_B.Fun (\<chi>' j) a" by auto
+ finally show "A_B.Map (cones_map f \<chi> j) a = A_B.Map (\<chi>' j) a" by auto
qed
qed
qed
qed
qed
qed
text\<open>
If @{term \<chi>} is a cone with apex @{term a} over @{term D}, then @{term \<chi>}
is a limit cone if, for each object @{term x} of @{term X}, the cone obtained
- by evaluating @{term \<chi>} at @{term x} is a limit cone with apex @{term "A_B.Fun a x"}
+ by evaluating @{term \<chi>} at @{term x} is a limit cone with apex @{term "A_B.Map a x"}
for the diagram in @{term C} obtained by evaluating @{term D} at @{term x}.
\<close>
lemma cone_is_limit_if_pointwise_limit:
assumes cone_\<chi>: "cone x \<chi>"
- and "\<forall>a. A.ide a \<longrightarrow> diagram.limit_cone J B (at a D) (A_B.Fun x a) (at a \<chi>)"
+ and "\<forall>a. A.ide a \<longrightarrow> diagram.limit_cone J B (at a D) (A_B.Map x a) (at a \<chi>)"
shows "limit_cone x \<chi>"
proof -
interpret \<chi>: cone J A_B.comp D x \<chi> using assms by auto
have x: "A_B.ide x" using \<chi>.ide_apex by auto
show "limit_cone x \<chi>"
proof
fix x' \<chi>'
assume cone_\<chi>': "cone x' \<chi>'"
interpret \<chi>': cone J A_B.comp D x' \<chi>' using cone_\<chi>' by auto
have x': "A_B.ide x'" using \<chi>'.ide_apex by auto
text\<open>
The universality of the limit cone \<open>at a \<chi>\<close> yields, for each object
\<open>a\<close> of \<open>A\<close>, a unique arrow \<open>fa\<close> that transforms
\<open>at a \<chi>\<close> to \<open>at a \<chi>'\<close>.
\<close>
have EU: "\<And>a. A.ide a \<Longrightarrow>
- \<exists>!fa. fa \<in> B.hom (A_B.Fun x' a) (A_B.Fun x a) \<and>
+ \<exists>!fa. fa \<in> B.hom (A_B.Map x' a) (A_B.Map x a) \<and>
diagram.cones_map J B (at a D) fa (at a \<chi>) = at a \<chi>'"
proof -
fix a
assume a: "A.ide a"
- interpret Da: diagram J B "at a D" using a at_ide_is_diagram by auto
- interpret \<chi>a: limit_cone J B "at a D" "A_B.Fun x a" "at a \<chi>"
+ interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
+ interpret \<chi>a: limit_cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close>
using assms(2) a by auto
- interpret \<chi>'a: cone J B "at a D" "A_B.Fun x' a" "at a \<chi>'"
+ interpret \<chi>'a: cone J B \<open>at a D\<close> \<open>A_B.Map x' a\<close> \<open>at a \<chi>'\<close>
using a cone_\<chi>' cone_at_ide_is_cone by auto
- have "Da.cone (A_B.Fun x' a) (at a \<chi>')" ..
- thus "\<exists>!fa. fa \<in> B.hom (A_B.Fun x' a) (A_B.Fun x a) \<and>
+ have "Da.cone (A_B.Map x' a) (at a \<chi>')" ..
+ thus "\<exists>!fa. fa \<in> B.hom (A_B.Map x' a) (A_B.Map x a) \<and>
Da.cones_map fa (at a \<chi>) = at a \<chi>'"
using \<chi>a.is_universal by simp
qed
text\<open>
Our objective is to show the existence of a unique arrow \<open>f\<close> that transforms
\<open>\<chi>\<close> into \<open>\<chi>'\<close>. We obtain \<open>f\<close> by bundling the arrows \<open>fa\<close>
of \<open>C\<close> and proving that this yields a natural transformation from \<open>X\<close>
to \<open>C\<close>, hence an arrow of \<open>[X, C]\<close>.
\<close>
show "\<exists>!f. \<guillemotleft>f : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map f \<chi> = \<chi>'"
proof
- let ?P = "\<lambda>a fa. \<guillemotleft>fa : A_B.Fun x' a \<rightarrow>\<^sub>B A_B.Fun x a\<guillemotright> \<and>
+ let ?P = "\<lambda>a fa. \<guillemotleft>fa : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright> \<and>
diagram.cones_map J B (at a D) fa (at a \<chi>) = at a \<chi>'"
have AaPa: "\<And>a. A.ide a \<Longrightarrow> ?P a (THE fa. ?P a fa)"
proof -
fix a
assume a: "A.ide a"
have "\<exists>!fa. ?P a fa" using a EU by simp
thus "?P a (THE fa. ?P a fa)" using a theI' [of "?P a"] by fastforce
qed
have AaPa_in_hom:
- "\<And>a. A.ide a \<Longrightarrow> \<guillemotleft>THE fa. ?P a fa : A_B.Fun x' a \<rightarrow>\<^sub>B A_B.Fun x a\<guillemotright>"
+ "\<And>a. A.ide a \<Longrightarrow> \<guillemotleft>THE fa. ?P a fa : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright>"
using AaPa by blast
have AaPa_map:
"\<And>a. A.ide a \<Longrightarrow>
diagram.cones_map J B (at a D) (THE fa. ?P a fa) (at a \<chi>) = at a \<chi>'"
using AaPa by blast
let ?Fun_f = "\<lambda>a. if A.ide a then (THE fa. ?P a fa) else B.null"
- interpret Fun_x: "functor" A B "\<lambda>a. A_B.Fun x a"
+ interpret Fun_x: "functor" A B \<open>\<lambda>a. A_B.Map x a\<close>
using x A_B.ide_char by simp
- interpret Fun_x': "functor" A B "\<lambda>a. A_B.Fun x' a"
+ interpret Fun_x': "functor" A B \<open>\<lambda>a. A_B.Map x' a\<close>
using x' A_B.ide_char by simp
text\<open>
The arrows \<open>Fun_f a\<close> are the components of a natural transformation.
It is more work to verify the naturality than it seems like it ought to be.
\<close>
interpret \<phi>: transformation_by_components A B
- "\<lambda>a. A_B.Fun x' a" "\<lambda>a. A_B.Fun x a" ?Fun_f
+ \<open>\<lambda>a. A_B.Map x' a\<close> \<open>\<lambda>a. A_B.Map x a\<close> ?Fun_f
proof
fix a
assume a: "A.ide a"
- show "\<guillemotleft>?Fun_f a : A_B.Fun x' a \<rightarrow>\<^sub>B A_B.Fun x a\<guillemotright>" using a AaPa by simp
+ show "\<guillemotleft>?Fun_f a : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright>" using a AaPa by simp
next
fix a
assume a: "A.arr a"
text\<open>
\newcommand\xdom{\mathop{\rm dom}}
\newcommand\xcod{\mathop{\rm cod}}
$$\xymatrix{
{x_{\xdom a}} \drtwocell\omit{\omit(A)} \ar[d]_{\chi_{\xdom a}} \ar[r]^{x_a} & {x_{\xcod a}}
\ar[d]^{\chi_{\xcod a}} \\
{D_{\xdom a}} \ar[r]^{D_a} & {D_{\xcod a}} \\
{x'_{\xdom a}} \urtwocell\omit{\omit(B)} \ar@/^5em/[uu]^{f_{\xdom a}}_{\hspace{1em}(C)} \ar[u]^{\chi'_{\xdom a}}
\ar[r]_{x'_a} & {x'_{\xcod a}} \ar[u]_{x'_{\xcod a}} \ar@/_5em/[uu]_{f_{\xcod a}}
}$$
\<close>
- let ?x_dom_a = "A_B.Fun x (A.dom a)"
- let ?x_cod_a = "A_B.Fun x (A.cod a)"
- let ?x_a = "A_B.Fun x a"
+ let ?x_dom_a = "A_B.Map x (A.dom a)"
+ let ?x_cod_a = "A_B.Map x (A.cod a)"
+ let ?x_a = "A_B.Map x a"
have x_a: "\<guillemotleft>?x_a : ?x_dom_a \<rightarrow>\<^sub>B ?x_cod_a\<guillemotright>"
using a x A_B.ide_char by auto
have x_dom_a: "B.ide ?x_dom_a" using a by simp
have x_cod_a: "B.ide ?x_cod_a" using a by simp
- let ?x'_dom_a = "A_B.Fun x' (A.dom a)"
- let ?x'_cod_a = "A_B.Fun x' (A.cod a)"
- let ?x'_a = "A_B.Fun x' a"
+ let ?x'_dom_a = "A_B.Map x' (A.dom a)"
+ let ?x'_cod_a = "A_B.Map x' (A.cod a)"
+ let ?x'_a = "A_B.Map x' a"
have x'_a: "\<guillemotleft>?x'_a : ?x'_dom_a \<rightarrow>\<^sub>B ?x'_cod_a\<guillemotright>"
using a x' A_B.ide_char by auto
have x'_dom_a: "B.ide ?x'_dom_a" using a by simp
have x'_cod_a: "B.ide ?x'_cod_a" using a by simp
let ?f_dom_a = "?Fun_f (A.dom a)"
let ?f_cod_a = "?Fun_f (A.cod a)"
have f_dom_a: "\<guillemotleft>?f_dom_a : ?x'_dom_a \<rightarrow>\<^sub>B ?x_dom_a\<guillemotright>" using a AaPa by simp
have f_cod_a: "\<guillemotleft>?f_cod_a : ?x'_cod_a \<rightarrow>\<^sub>B ?x_cod_a\<guillemotright>" using a AaPa by simp
- interpret D_dom_a: diagram J B "at (A.dom a) D" using a at_ide_is_diagram by simp
- interpret D_cod_a: diagram J B "at (A.cod a) D" using a at_ide_is_diagram by simp
- interpret Da: natural_transformation J B "at (A.dom a) D" "at (A.cod a) D" "at a D"
+ interpret D_dom_a: diagram J B \<open>at (A.dom a) D\<close> using a at_ide_is_diagram by simp
+ interpret D_cod_a: diagram J B \<open>at (A.cod a) D\<close> using a at_ide_is_diagram by simp
+ interpret Da: natural_transformation J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close> \<open>at a D\<close>
using a functor_axioms functor_at_arr_is_transformation by simp
- interpret \<chi>_dom_a: limit_cone J B "at (A.dom a) D" "A_B.Fun x (A.dom a)"
- "at (A.dom a) \<chi>"
+ interpret \<chi>_dom_a: limit_cone J B \<open>at (A.dom a) D\<close> \<open>A_B.Map x (A.dom a)\<close>
+ \<open>at (A.dom a) \<chi>\<close>
using assms(2) a by auto
- interpret \<chi>_cod_a: limit_cone J B "at (A.cod a) D" "A_B.Fun x (A.cod a)"
- "at (A.cod a) \<chi>"
+ interpret \<chi>_cod_a: limit_cone J B \<open>at (A.cod a) D\<close> \<open>A_B.Map x (A.cod a)\<close>
+ \<open>at (A.cod a) \<chi>\<close>
using assms(2) a by auto
- interpret \<chi>'_dom_a: cone J B "at (A.dom a) D" "A_B.Fun x' (A.dom a)" "at (A.dom a) \<chi>'"
+ interpret \<chi>'_dom_a: cone J B \<open>at (A.dom a) D\<close> \<open>A_B.Map x' (A.dom a)\<close> \<open>at (A.dom a) \<chi>'\<close>
using a cone_\<chi>' cone_at_ide_is_cone by auto
- interpret \<chi>'_cod_a: cone J B "at (A.cod a) D" "A_B.Fun x' (A.cod a)" "at (A.cod a) \<chi>'"
+ interpret \<chi>'_cod_a: cone J B \<open>at (A.cod a) D\<close> \<open>A_B.Map x' (A.cod a)\<close> \<open>at (A.cod a) \<chi>'\<close>
using a cone_\<chi>' cone_at_ide_is_cone by auto
text\<open>
Now construct cones with apexes \<open>x_dom_a\<close> and \<open>x'_dom_a\<close>
over @{term "at (A.cod a) D"} by forming the vertical composites of
@{term "at (A.dom a) \<chi>"} and @{term "at (A.cod a) \<chi>'"} with the natural
transformation @{term "at a D"}.
\<close>
interpret Dao\<chi>_dom_a: vertical_composite J B
- \<chi>_dom_a.A.map "at (A.dom a) D" "at (A.cod a) D"
- "at (A.dom a) \<chi>" "at a D" ..
- interpret Dao\<chi>_dom_a: cone J B "at (A.cod a) D" ?x_dom_a Dao\<chi>_dom_a.map
+ \<chi>_dom_a.A.map \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close>
+ \<open>at (A.dom a) \<chi>\<close> \<open>at a D\<close> ..
+ interpret Dao\<chi>_dom_a: cone J B \<open>at (A.cod a) D\<close> ?x_dom_a Dao\<chi>_dom_a.map
using \<chi>_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
by metis
interpret Dao\<chi>'_dom_a: vertical_composite J B
- \<chi>'_dom_a.A.map "at (A.dom a) D" "at (A.cod a) D"
- "at (A.dom a) \<chi>'" "at a D" ..
- interpret Dao\<chi>'_dom_a: cone J B "at (A.cod a) D" ?x'_dom_a Dao\<chi>'_dom_a.map
+ \<chi>'_dom_a.A.map \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close>
+ \<open>at (A.dom a) \<chi>'\<close> \<open>at a D\<close> ..
+ interpret Dao\<chi>'_dom_a: cone J B \<open>at (A.cod a) D\<close> ?x'_dom_a Dao\<chi>'_dom_a.map
using \<chi>'_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
by metis
have Dao\<chi>_dom_a: "D_cod_a.cone ?x_dom_a Dao\<chi>_dom_a.map" ..
have Dao\<chi>'_dom_a: "D_cod_a.cone ?x'_dom_a Dao\<chi>'_dom_a.map" ..
text\<open>
These cones are also obtained by transforming the cones @{term "at (A.cod a) \<chi>"}
and @{term "at (A.cod a) \<chi>'"} by \<open>x_a\<close> and \<open>x'_a\<close>, respectively.
\<close>
have A: "Dao\<chi>_dom_a.map = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>)"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> Dao\<chi>_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
using Dao\<chi>_dom_a.is_extensional \<chi>_cod_a.cone_axioms x_a by force
moreover have
"J.arr j \<Longrightarrow> Dao\<chi>_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
proof -
assume j: "J.arr j"
have "Dao\<chi>_dom_a.map j = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi> (J.dom j)"
using j Dao\<chi>_dom_a.map_simp_2 by simp
- also have "... = A_B.Fun (D j) a \<cdot>\<^sub>B A_B.Fun (\<chi> (J.dom j)) (A.dom a)"
+ also have "... = A_B.Map (D j) a \<cdot>\<^sub>B A_B.Map (\<chi> (J.dom j)) (A.dom a)"
using a j at_simp by simp
- also have "... = A_B.Fun (A_B.comp (D j) (\<chi> (J.dom j))) a"
- using a j A_B.Fun_comp
- by (metis A.comp_arr_dom A_B.Fun_comp \<chi>.is_natural_1 \<chi>.preserves_reflects_arr)
- also have "... = A_B.Fun (A_B.comp (\<chi> (J.cod j)) (\<chi>.A.map j)) a"
+ also have "... = A_B.Map (A_B.comp (D j) (\<chi> (J.dom j))) a"
+ using a j A_B.Map_comp
+ by (metis (no_types, lifting) A.comp_arr_dom \<chi>.is_natural_1
+ \<chi>.preserves_reflects_arr)
+ also have "... = A_B.Map (A_B.comp (\<chi> (J.cod j)) (\<chi>.A.map j)) a"
using a j \<chi>.naturality by simp
- also have "... = A_B.Fun (\<chi> (J.cod j)) (A.cod a) \<cdot>\<^sub>B A_B.Fun x a"
- using a j x A_B.Fun_comp
- by (metis A.comp_cod_arr A_B.Fun_comp \<chi>.A.map_simp \<chi>.is_natural_2
+ also have "... = A_B.Map (\<chi> (J.cod j)) (A.cod a) \<cdot>\<^sub>B A_B.Map x a"
+ using a j x A_B.Map_comp
+ by (metis (no_types, lifting) A.comp_cod_arr \<chi>.A.map_simp \<chi>.is_natural_2
\<chi>.preserves_reflects_arr)
- also have "... = at (A.cod a) \<chi> (J.cod j) \<cdot>\<^sub>B A_B.Fun x a"
+ also have "... = at (A.cod a) \<chi> (J.cod j) \<cdot>\<^sub>B A_B.Map x a"
using a j at_simp by simp
- also have "... = at (A.cod a) \<chi> j \<cdot>\<^sub>B A_B.Fun x a"
+ also have "... = at (A.cod a) \<chi> j \<cdot>\<^sub>B A_B.Map x a"
using a j \<chi>_cod_a.is_natural_2 \<chi>_cod_a.A.map_simp
by (metis J.arr_cod_iff_arr J.cod_cod)
also have "... = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
using a j x \<chi>_cod_a.cone_axioms preserves_cod by simp
finally show ?thesis by blast
qed
ultimately show "Dao\<chi>_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
by blast
qed
have B: "Dao\<chi>'_dom_a.map = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>')"
proof
fix j
have
"\<not>J.arr j \<Longrightarrow> Dao\<chi>'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
using Dao\<chi>'_dom_a.is_extensional \<chi>'_cod_a.cone_axioms x'_a by force
moreover have
"J.arr j \<Longrightarrow> Dao\<chi>'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
proof -
assume j: "J.arr j"
have "Dao\<chi>'_dom_a.map j = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi>' (J.dom j)"
using j Dao\<chi>'_dom_a.map_simp_2 by simp
- also have "... = A_B.Fun (D j) a \<cdot>\<^sub>B A_B.Fun (\<chi>' (J.dom j)) (A.dom a)"
+ also have "... = A_B.Map (D j) a \<cdot>\<^sub>B A_B.Map (\<chi>' (J.dom j)) (A.dom a)"
using a j at_simp by simp
- also have "... = A_B.Fun (A_B.comp (D j) (\<chi>' (J.dom j))) a"
- using a j A_B.Fun_comp
- by (metis A.comp_arr_dom A_B.Fun_comp \<chi>'.is_natural_1 \<chi>'.preserves_reflects_arr)
- also have "... = A_B.Fun (A_B.comp (\<chi>' (J.cod j)) (\<chi>'.A.map j)) a"
+ also have "... = A_B.Map (A_B.comp (D j) (\<chi>' (J.dom j))) a"
+ using a j A_B.Map_comp
+ by (metis (no_types, lifting) A.comp_arr_dom \<chi>'.is_natural_1
+ \<chi>'.preserves_reflects_arr)
+ also have "... = A_B.Map (A_B.comp (\<chi>' (J.cod j)) (\<chi>'.A.map j)) a"
using a j \<chi>'.naturality by simp
- also have "... = A_B.Fun (\<chi>' (J.cod j)) (A.cod a) \<cdot>\<^sub>B A_B.Fun x' a"
- using a j x' A_B.Fun_comp
- by (metis A.comp_cod_arr A_B.Fun_comp \<chi>'.A.map_simp \<chi>'.is_natural_2
+ also have "... = A_B.Map (\<chi>' (J.cod j)) (A.cod a) \<cdot>\<^sub>B A_B.Map x' a"
+ using a j x' A_B.Map_comp
+ by (metis (no_types, lifting) A.comp_cod_arr \<chi>'.A.map_simp \<chi>'.is_natural_2
\<chi>'.preserves_reflects_arr)
- also have "... = at (A.cod a) \<chi>' (J.cod j) \<cdot>\<^sub>B A_B.Fun x' a"
+ also have "... = at (A.cod a) \<chi>' (J.cod j) \<cdot>\<^sub>B A_B.Map x' a"
using a j at_simp by simp
- also have "... = at (A.cod a) \<chi>' j \<cdot>\<^sub>B A_B.Fun x' a"
+ also have "... = at (A.cod a) \<chi>' j \<cdot>\<^sub>B A_B.Map x' a"
using a j \<chi>'_cod_a.is_natural_2 \<chi>'_cod_a.A.map_simp
by (metis J.arr_cod_iff_arr J.cod_cod)
also have "... = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
using a j x' \<chi>'_cod_a.cone_axioms preserves_cod by simp
finally show ?thesis by blast
qed
ultimately show
"Dao\<chi>'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
by blast
qed
text\<open>
Next, we show that \<open>f_dom_a\<close>, which is the unique arrow that transforms
\<open>\<chi>_dom_a\<close> into \<open>\<chi>'_dom_a\<close>, is also the unique arrow that transforms
\<open>Dao\<chi>_dom_a\<close> into \<open>Dao\<chi>'_dom_a\<close>.
\<close>
have C: "D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map = Dao\<chi>'_dom_a.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation
J B \<chi>'_dom_a.A.map (at (A.cod a) D) Dao\<chi>'_dom_a.map" ..
show "natural_transformation J B \<chi>'_dom_a.A.map (at (A.cod a) D)
(D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map)"
proof -
- interpret \<kappa>: cone J B "at (A.cod a) D" ?x'_dom_a
- "D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map"
+ interpret \<kappa>: cone J B \<open>at (A.cod a) D\<close> ?x'_dom_a
+ \<open>D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map\<close>
proof -
have 1: "\<And>b b' f. \<lbrakk> f \<in> B.hom b' b; D_cod_a.cone b Dao\<chi>_dom_a.map \<rbrakk>
\<Longrightarrow> D_cod_a.cone b' (D_cod_a.cones_map f Dao\<chi>_dom_a.map)"
using D_cod_a.cones_map_mapsto by blast
have "D_cod_a.cone ?x_dom_a Dao\<chi>_dom_a.map" ..
thus "D_cod_a.cone ?x'_dom_a (D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map)"
using f_dom_a 1 by simp
qed
show ?thesis ..
qed
show "\<And>j. J.ide j \<Longrightarrow>
D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map j = Dao\<chi>'_dom_a.map j"
proof -
fix j
assume j: "J.ide j"
have "D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map j =
Dao\<chi>_dom_a.map j \<cdot>\<^sub>B ?f_dom_a"
using j f_dom_a Dao\<chi>_dom_a.cone_axioms
by (elim B.in_homE, auto)
also have "... = (at a D j \<cdot>\<^sub>B at (A.dom a) \<chi> j) \<cdot>\<^sub>B ?f_dom_a"
using j Dao\<chi>_dom_a.map_simp_ide by simp
also have "... = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi> j \<cdot>\<^sub>B ?f_dom_a"
using B.comp_assoc by simp
also have "... = at a D j \<cdot>\<^sub>B D_dom_a.cones_map ?f_dom_a (at (A.dom a) \<chi>) j"
using j \<chi>_dom_a.cone_axioms f_dom_a
by (elim B.in_homE, auto)
also have "... = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi>' j"
using a AaPa A.ide_dom by presburger
also have "... = Dao\<chi>'_dom_a.map j"
using j Dao\<chi>'_dom_a.map_simp_ide by simp
finally show
"D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map j = Dao\<chi>'_dom_a.map j"
by auto
qed
qed
text\<open>
Naturality amounts to showing that \<open>C f_cod_a x'_a = C x_a f_dom_a\<close>.
To do this, we show that both arrows transform @{term "at (A.cod a) \<chi>"}
into \<open>Dao\<chi>'_cod_a\<close>, thus they are equal by the universality of
@{term "at (A.cod a) \<chi>"}.
\<close>
have "\<exists>!fa. \<guillemotleft>fa : ?x'_dom_a \<rightarrow>\<^sub>B ?x_cod_a\<guillemotright> \<and>
D_cod_a.cones_map fa (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
using Dao\<chi>'_dom_a.cone_axioms a \<chi>_cod_a.is_universal [of ?x'_dom_a Dao\<chi>'_dom_a.map]
by fast
moreover have
"?f_cod_a \<cdot>\<^sub>B ?x'_a \<in> B.hom ?x'_dom_a ?x_cod_a \<and>
D_cod_a.cones_map (?f_cod_a \<cdot>\<^sub>B ?x'_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
proof
show "?f_cod_a \<cdot>\<^sub>B ?x'_a \<in> B.hom ?x'_dom_a ?x_cod_a"
using f_cod_a x'_a by blast
show "D_cod_a.cones_map (?f_cod_a \<cdot>\<^sub>B ?x'_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
proof -
have 1: "B.arr (?f_cod_a \<cdot>\<^sub>B ?x'_a)"
using f_cod_a x'_a by (elim B.in_homE, auto)
hence "D_cod_a.cones_map (?f_cod_a \<cdot>\<^sub>B ?x'_a) (at (A.cod a) \<chi>)
= restrict (D_cod_a.cones_map ?x'_a o D_cod_a.cones_map ?f_cod_a)
(D_cod_a.cones (?x_cod_a))
(at (A.cod a) \<chi>)"
using D_cod_a.cones_map_comp [of ?f_cod_a ?x'_a] f_cod_a
by (elim B.in_homE, auto)
also have "... = D_cod_a.cones_map ?x'_a
(D_cod_a.cones_map ?f_cod_a (at (A.cod a) \<chi>))"
using \<chi>_cod_a.cone_axioms by simp
also have "... = Dao\<chi>'_dom_a.map"
using a B AaPa_map A.ide_cod by presburger
finally show ?thesis by auto
qed
qed
moreover have
"?x_a \<cdot>\<^sub>B ?f_dom_a \<in> B.hom ?x'_dom_a ?x_cod_a \<and>
D_cod_a.cones_map (?x_a \<cdot>\<^sub>B ?f_dom_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
proof
show "?x_a \<cdot>\<^sub>B ?f_dom_a \<in> B.hom ?x'_dom_a ?x_cod_a"
using f_dom_a x_a by blast
show "D_cod_a.cones_map (?x_a \<cdot>\<^sub>B ?f_dom_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
proof -
have
- "D_cod_a.cones (B.cod (A_B.Fun x a)) = D_cod_a.cones (A_B.Fun x (A.cod a))"
+ "D_cod_a.cones (B.cod (A_B.Map x a)) = D_cod_a.cones (A_B.Map x (A.cod a))"
using a x by simp
moreover have "B.seq ?x_a ?f_dom_a"
using f_dom_a x_a by (elim B.in_homE, auto)
ultimately have
"D_cod_a.cones_map (?x_a \<cdot>\<^sub>B ?f_dom_a) (at (A.cod a) \<chi>)
= restrict (D_cod_a.cones_map ?f_dom_a o D_cod_a.cones_map ?x_a)
(D_cod_a.cones (?x_cod_a))
(at (A.cod a) \<chi>)"
using D_cod_a.cones_map_comp [of ?x_a ?f_dom_a] x_a by argo
also have "... = D_cod_a.cones_map ?f_dom_a
(D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>))"
using \<chi>_cod_a.cone_axioms by simp
also have "... = Dao\<chi>'_dom_a.map"
using A C a AaPa by argo
finally show ?thesis by blast
qed
qed
ultimately show "?f_cod_a \<cdot>\<^sub>B ?x'_a = ?x_a \<cdot>\<^sub>B ?f_dom_a"
using a \<chi>_cod_a.is_universal by blast
qed
text\<open>
The arrow from @{term x'} to @{term x} in \<open>[A, B]\<close> determined by
the natural transformation \<open>\<phi>\<close> transforms @{term \<chi>} into @{term \<chi>'}.
Moreover, it is the unique such arrow, since the components of \<open>\<phi>\<close>
are each determined by universality.
\<close>
- let ?f = "A_B.mkArr (\<lambda>a. A_B.Fun x' a) (\<lambda>a. A_B.Fun x a) \<phi>.map"
+ let ?f = "A_B.MkArr (\<lambda>a. A_B.Map x' a) (\<lambda>a. A_B.Map x a) \<phi>.map"
have f_in_hom: "?f \<in> A_B.hom x' x"
proof -
have arr_f: "A_B.arr ?f"
- using x' x A_B.arr_mkArr \<phi>.natural_transformation_axioms by simp
- moreover have "A_B.mkIde (\<lambda>a. A_B.Fun x a) = x"
- using x A_B.ide_char A_B.mkArr_Fun A_B.in_homE A_B.ide_in_hom by metis
- moreover have "A_B.mkIde (\<lambda>a. A_B.Fun x' a) = x'"
- using x' A_B.ide_char A_B.mkArr_Fun A_B.in_homE A_B.ide_in_hom by metis
+ using x' x A_B.arr_MkArr \<phi>.natural_transformation_axioms by simp
+ moreover have "A_B.MkIde (\<lambda>a. A_B.Map x a) = x"
+ using x A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
+ moreover have "A_B.MkIde (\<lambda>a. A_B.Map x' a) = x'"
+ using x' A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
ultimately show ?thesis
using A_B.dom_char A_B.cod_char by auto
qed
- have Fun_f: "\<And>a. A.ide a \<Longrightarrow> A_B.Fun ?f a = (THE fa. ?P a fa)"
- using f_in_hom \<phi>.map_simp_ide A_B.Fun_mkArr by fastforce
+ have Fun_f: "\<And>a. A.ide a \<Longrightarrow> A_B.Map ?f a = (THE fa. ?P a fa)"
+ using f_in_hom \<phi>.map_simp_ide by fastforce
have cones_map_f: "cones_map ?f \<chi> = \<chi>'"
using AaPa Fun_f at_ide_is_diagram assms(2) x x' cone_\<chi> cone_\<chi>' f_in_hom Fun_f
cones_map_pointwise
by presburger
show "\<guillemotleft>?f : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map ?f \<chi> = \<chi>'" using f_in_hom cones_map_f by auto
show "\<And>f'. \<guillemotleft>f' : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map f' \<chi> = \<chi>' \<Longrightarrow> f' = ?f"
proof -
fix f'
assume f': "\<guillemotleft>f' : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map f' \<chi> = \<chi>'"
have 0: "\<And>a. A.ide a \<Longrightarrow>
- diagram.cones_map J B (at a D) (A_B.Fun f' a) (at a \<chi>) = at a \<chi>'"
+ diagram.cones_map J B (at a D) (A_B.Map f' a) (at a \<chi>) = at a \<chi>'"
using f' cone_\<chi> cone_\<chi>' cones_map_pointwise by blast
- have "f' = A_B.mkArr (A_B.Dom f') (A_B.Cod f') (A_B.Fun f')"
- using f' A_B.mkArr_Fun by auto
+ have "f' = A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f')"
+ using f' A_B.MkArr_Map by auto
also have "... = ?f"
- proof
- show "A_B.arr (A_B.mkArr (A_B.Dom f') (A_B.Cod f') (A_B.Fun f'))"
+ proof (intro A_B.MkArr_eqI)
+ show "A_B.arr (A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f'))"
using f' calculation by blast
- show 1: "A_B.Dom f' = A_B.Fun x'" using f' A_B.Fun_dom by auto
- show 2: "A_B.Cod f' = A_B.Fun x" using f' A_B.Fun_cod by auto
- show "A_B.Fun f' = \<phi>.map"
+ show 1: "A_B.Dom f' = A_B.Map x'" using f' A_B.Map_dom by auto
+ show 2: "A_B.Cod f' = A_B.Map x" using f' A_B.Map_cod by auto
+ show "A_B.Map f' = \<phi>.map"
proof (intro NaturalTransformation.eqI)
- show "natural_transformation A B (A_B.Fun x') (A_B.Fun x) \<phi>.map" ..
- show "natural_transformation A B (A_B.Fun x') (A_B.Fun x) (A_B.Fun f')"
+ show "natural_transformation A B (A_B.Map x') (A_B.Map x) \<phi>.map" ..
+ show "natural_transformation A B (A_B.Map x') (A_B.Map x) (A_B.Map f')"
using f' 1 2 A_B.arr_char [of f'] by auto
- show "\<And>a. A.ide a \<Longrightarrow> A_B.Fun f' a = \<phi>.map a"
+ show "\<And>a. A.ide a \<Longrightarrow> A_B.Map f' a = \<phi>.map a"
proof -
fix a
assume a: "A.ide a"
- interpret Da: diagram J B "at a D" using a at_ide_is_diagram by auto
- interpret Fun_f': natural_transformation A B "A_B.Dom f'" "A_B.Cod f'"
- "A_B.Fun f'"
+ interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
+ interpret Fun_f': natural_transformation A B \<open>A_B.Dom f'\<close> \<open>A_B.Cod f'\<close>
+ \<open>A_B.Map f'\<close>
using f' A_B.arr_char by fast
- have "A_B.Fun f' a \<in> B.hom (A_B.Fun x' a) (A_B.Fun x a)"
+ have "A_B.Map f' a \<in> B.hom (A_B.Map x' a) (A_B.Map x a)"
using a f' Fun_f'.preserves_hom A.ide_in_hom by auto
- hence "?P a (A_B.Fun f' a)" using a 0 [of a] by simp
+ hence "?P a (A_B.Map f' a)" using a 0 [of a] by simp
moreover have "?P a (\<phi>.map a)"
using a \<phi>.map_simp_ide Fun_f AaPa by presburger
- ultimately show "A_B.Fun f' a = \<phi>.map a" using a EU by blast
+ ultimately show "A_B.Map f' a = \<phi>.map a" using a EU by blast
qed
qed
qed
finally show "f' = ?f" by auto
qed
qed
qed
qed
end
context functor_category
begin
text\<open>
A functor category \<open>[A, B]\<close> has limits of shape @{term[source=true] J}
whenever @{term B} has limits of shape @{term[source=true] J}.
\<close>
lemma has_limits_of_shape_if_target_does:
assumes "category (J :: 'j comp)"
and "B.has_limits_of_shape J"
shows "has_limits_of_shape J"
proof (unfold has_limits_of_shape_def)
have "\<And>D. diagram J comp D \<Longrightarrow> (\<exists>x \<chi>. limit_cone J comp D x \<chi>)"
proof -
fix D
assume D: "diagram J comp D"
interpret J: category J using assms(1) by auto
interpret JxA: product_category J A ..
interpret D: diagram J comp D using D by auto
interpret D: diagram_in_functor_category A B J D ..
interpret Curry: currying J A B ..
text\<open>
Given diagram @{term D} in \<open>[A, B]\<close>, choose for each object \<open>a\<close>
of \<open>A\<close> a limit cone \<open>(la, \<chi>a)\<close> for \<open>at a D\<close> in \<open>B\<close>.
\<close>
let ?l = "\<lambda>a. diagram.some_limit J B (D.at a D)"
let ?\<chi> = "\<lambda>a. diagram.some_limit_cone J B (D.at a D)"
have l\<chi>: "\<And>a. A.ide a \<Longrightarrow> diagram.limit_cone J B (D.at a D) (?l a) (?\<chi> a)"
proof -
fix a
assume a: "A.ide a"
- interpret Da: diagram J B "D.at a D"
+ interpret Da: diagram J B \<open>D.at a D\<close>
using a D.at_ide_is_diagram by blast
show "limit_cone J B (D.at a D) (?l a) (?\<chi> a)"
using assms(2) B.has_limits_of_shape_def Da.diagram_axioms
Da.limit_cone_some_limit_cone
by auto
qed
text\<open>
The choice of limit cones induces a limit functor from \<open>A\<close> to \<open>B\<close>.
\<close>
interpret uncurry_D: diagram JxA.comp B "Curry.uncurry D"
proof -
- interpret "functor" JxA.comp B "Curry.uncurry D"
+ interpret "functor" JxA.comp B \<open>Curry.uncurry D\<close>
using D.functor_axioms Curry.uncurry_preserves_functors by simp
- interpret binary_functor J A B "Curry.uncurry D" ..
+ interpret binary_functor J A B \<open>Curry.uncurry D\<close> ..
show "diagram JxA.comp B (Curry.uncurry D)" ..
qed
- interpret uncurry_D: parametrized_diagram J A B "Curry.uncurry D" ..
+ interpret uncurry_D: parametrized_diagram J A B \<open>Curry.uncurry D\<close> ..
let ?L = "uncurry_D.L ?l ?\<chi>"
let ?P = "uncurry_D.P ?l ?\<chi>"
interpret L: "functor" A B ?L
using l\<chi> uncurry_D.chosen_limits_induce_functor [of ?l ?\<chi>] by simp
have L_ide: "\<And>a. A.ide a \<Longrightarrow> ?L a = ?l a"
using uncurry_D.L_ide [of ?l ?\<chi>] l\<chi> by blast
have L_arr: "\<And>a. A.arr a \<Longrightarrow> (\<exists>!f. ?P a f) \<and> ?P a (?L a)"
using uncurry_D.L_arr [of ?l ?\<chi>] l\<chi> by blast
have L_arr_in_hom: "\<And>a. A.arr a \<Longrightarrow> \<guillemotleft>?L a : ?l (A.dom a) \<rightarrow>\<^sub>B ?l (A.cod a)\<guillemotright>"
using L_arr by blast
have L_map: "\<And>a. A.arr a \<Longrightarrow> uncurry_D.P ?l ?\<chi> a (uncurry_D.L ?l ?\<chi> a)"
using L_arr by blast
text\<open>
The functor \<open>L\<close> extends to a functor \<open>L'\<close> from \<open>JxA\<close>
to \<open>B\<close> that is constant on \<open>J\<close>.
\<close>
let ?L' = "\<lambda>ja. if JxA.arr ja then ?L (snd ja) else B.null"
let ?P' = "\<lambda>ja. ?P (snd ja)"
interpret L': "functor" JxA.comp B ?L'
apply unfold_locales
using L.preserves_arr L.preserves_dom L.preserves_cod
apply auto[4]
using L.preserves_comp JxA.comp_char by (elim JxA.seqE, auto)
have "\<And>ja. JxA.arr ja \<Longrightarrow> (\<exists>!f. ?P' ja f) \<and> ?P' ja (?L' ja)"
proof -
fix ja
assume ja: "JxA.arr ja"
have "A.arr (snd ja)" using ja by blast
thus "(\<exists>!f. ?P' ja f) \<and> ?P' ja (?L' ja)"
using ja L_arr by presburger
qed
hence L'_arr: "\<And>ja. JxA.arr ja \<Longrightarrow> ?P' ja (?L' ja)" by blast
have L'_arr_in_hom:
"\<And>ja. JxA.arr ja \<Longrightarrow> \<guillemotleft>?L' ja : ?l (A.dom (snd ja)) \<rightarrow>\<^sub>B ?l (A.cod (snd ja))\<guillemotright>"
using L'_arr by simp
have L'_ide: "\<And>ja. \<lbrakk> J.arr (fst ja); A.ide (snd ja) \<rbrakk> \<Longrightarrow> ?L' ja = ?l (snd ja)"
using L_ide l\<chi> by force
have L'_arr_map:
"\<And>ja. JxA.arr ja \<Longrightarrow> uncurry_D.P ?l ?\<chi> (snd ja) (uncurry_D.L ?l ?\<chi> (snd ja))"
using L'_arr by presburger
text\<open>
The map that takes an object \<open>(j, a)\<close> of \<open>JxA\<close> to the component
\<open>\<chi> a j\<close> of the limit cone \<open>\<chi> a\<close> is a natural transformation
from \<open>L\<close> to uncurry \<open>D\<close>.
\<close>
let ?\<chi>' = "\<lambda>ja. ?\<chi> (snd ja) (fst ja)"
- interpret \<chi>': transformation_by_components JxA.comp B ?L' "Curry.uncurry D" ?\<chi>'
+ interpret \<chi>': transformation_by_components JxA.comp B ?L' \<open>Curry.uncurry D\<close> ?\<chi>'
proof
fix ja
assume ja: "JxA.ide ja"
let ?j = "fst ja"
let ?a = "snd ja"
- interpret \<chi>a: limit_cone J B "D.at ?a D" "?l ?a" "?\<chi> ?a"
+ interpret \<chi>a: limit_cone J B \<open>D.at ?a D\<close> \<open>?l ?a\<close> \<open>?\<chi> ?a\<close>
using ja l\<chi> by blast
show "\<guillemotleft>?\<chi>' ja : ?L' ja \<rightarrow>\<^sub>B Curry.uncurry D ja\<guillemotright>"
using ja L'_ide [of ja] by force
next
fix ja
assume ja: "JxA.arr ja"
let ?j = "fst ja"
let ?a = "snd ja"
have j: "J.arr ?j" using ja by simp
have a: "A.arr ?a" using ja by simp
- interpret D_dom_a: diagram J B "D.at (A.dom ?a) D"
- using a D.at_ide_is_diagram by auto
- interpret D_cod_a: diagram J B "D.at (A.cod ?a) D"
+ interpret D_dom_a: diagram J B \<open>D.at (A.dom ?a) D\<close>
using a D.at_ide_is_diagram by auto
- interpret Da: natural_transformation J B "D.at (A.dom ?a) D" "D.at (A.cod ?a) D"
- "D.at ?a D"
+ interpret D_cod_a: diagram J B \<open>D.at (A.cod ?a) D\<close>
+ using a D.at_ide_is_diagram by auto
+ interpret Da: natural_transformation J B \<open>D.at (A.dom ?a) D\<close> \<open>D.at (A.cod ?a) D\<close>
+ \<open>D.at ?a D\<close>
using a D.functor_axioms D.functor_at_arr_is_transformation by simp
- interpret \<chi>_dom_a: limit_cone J B "D.at (A.dom ?a) D" "?l (A.dom ?a)" "?\<chi> (A.dom ?a)"
+ interpret \<chi>_dom_a: limit_cone J B \<open>D.at (A.dom ?a) D\<close> \<open>?l (A.dom ?a)\<close> \<open>?\<chi> (A.dom ?a)\<close>
using a l\<chi> by simp
- interpret \<chi>_cod_a: limit_cone J B "D.at (A.cod ?a) D" "?l (A.cod ?a)" "?\<chi> (A.cod ?a)"
+ interpret \<chi>_cod_a: limit_cone J B \<open>D.at (A.cod ?a) D\<close> \<open>?l (A.cod ?a)\<close> \<open>?\<chi> (A.cod ?a)\<close>
using a l\<chi> by simp
interpret Dao\<chi>_dom_a: vertical_composite J B
- \<chi>_dom_a.A.map "D.at (A.dom ?a) D" "D.at (A.cod ?a) D"
- "?\<chi> (A.dom ?a)" "D.at ?a D" ..
- interpret Dao\<chi>_dom_a: cone J B "D.at (A.cod ?a) D" "?l (A.dom ?a)" Dao\<chi>_dom_a.map ..
+ \<chi>_dom_a.A.map \<open>D.at (A.dom ?a) D\<close> \<open>D.at (A.cod ?a) D\<close>
+ \<open>?\<chi> (A.dom ?a)\<close> \<open>D.at ?a D\<close> ..
+ interpret Dao\<chi>_dom_a: cone J B \<open>D.at (A.cod ?a) D\<close> \<open>?l (A.dom ?a)\<close> Dao\<chi>_dom_a.map ..
show "?\<chi>' (JxA.cod ja) \<cdot>\<^sub>B ?L' ja = B (Curry.uncurry D ja) (?\<chi>' (JxA.dom ja))"
proof -
have "?\<chi>' (JxA.cod ja) \<cdot>\<^sub>B ?L' ja = ?\<chi> (A.cod ?a) (J.cod ?j) \<cdot>\<^sub>B ?L' ja"
using ja by fastforce
also have "... = D_cod_a.cones_map (?L' ja) (?\<chi> (A.cod ?a)) (J.cod ?j)"
using ja L'_arr_map [of ja] \<chi>_cod_a.cone_axioms by auto
also have "... = Dao\<chi>_dom_a.map (J.cod ?j)"
using ja \<chi>_cod_a.induced_arrowI Dao\<chi>_dom_a.cone_axioms L'_arr by presburger
also have "... = D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D_dom_a.some_limit_cone (J.cod ?j)"
using ja Dao\<chi>_dom_a.map_simp_ide by fastforce
also have "... = D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D.at (A.dom ?a) D ?j \<cdot>\<^sub>B ?\<chi>' (JxA.dom ja)"
using ja \<chi>_dom_a.naturality \<chi>_dom_a.ide_apex apply simp
by (metis B.comp_arr_ide \<chi>_dom_a.preserves_reflects_arr)
also have "... = (D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D.at (A.dom ?a) D ?j) \<cdot>\<^sub>B ?\<chi>' (JxA.dom ja)"
proof -
have "B.seq (D.at ?a D (J.cod ?j)) (D.at (A.dom ?a) D ?j)"
using j ja by auto
moreover have "B.seq (D.at (A.dom ?a) D ?j) (?\<chi>' (JxA.dom ja))"
using j ja by fastforce
ultimately show ?thesis using B.comp_assoc by force
qed
also have "... = B (D.at ?a D ?j) (?\<chi>' (JxA.dom ja))"
proof -
have "D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D.at (A.dom ?a) D ?j =
- Fun (D (J.cod ?j)) ?a \<cdot>\<^sub>B Fun (D ?j) (A.dom ?a)"
+ Map (D (J.cod ?j)) ?a \<cdot>\<^sub>B Map (D ?j) (A.dom ?a)"
using ja D.at_simp by auto
- also have "... = Fun (D (J.cod ?j) \<cdot> D ?j) (?a \<cdot>\<^sub>A A.dom ?a)"
- using ja Fun_comp D.preserves_hom
- by (metis A.comp_arr_dom D.is_natural_2 D.preserves_arr Fun_comp a j)
+ also have "... = Map (comp (D (J.cod ?j)) (D ?j)) (?a \<cdot>\<^sub>A A.dom ?a)"
+ using ja Map_comp D.preserves_hom
+ by (metis (mono_tags, lifting) A.comp_arr_dom D.natural_transformation_axioms
+ D.preserves_arr a j natural_transformation.is_natural_2)
also have "... = D.at ?a D ?j"
- using ja D.at_simp dom_simp A.comp_arr_dom by force
+ using ja D.at_simp dom_char A.comp_arr_dom by force
finally show ?thesis by auto
qed
also have "... = Curry.uncurry D ja \<cdot>\<^sub>B ?\<chi>' (JxA.dom ja)"
using Curry.uncurry_def by simp
finally show ?thesis by auto
qed
qed
text\<open>
Since \<open>\<chi>'\<close> is constant on \<open>J\<close>, \<open>curry \<chi>'\<close> is a cone over \<open>D\<close>.
\<close>
- interpret constL: constant_functor J comp "mkIde ?L"
+ interpret constL: constant_functor J comp \<open>MkIde ?L\<close>
proof
- show "ide (mkIde ?L)"
- using L.natural_transformation_axioms mkArr_in_hom ide_in_hom by blast
+ show "ide (MkIde ?L)"
+ using L.natural_transformation_axioms MkArr_in_hom ide_in_hom L.functor_axioms
+ by blast
qed
(* TODO: This seems a little too involved. *)
have curry_L': "constL.map = Curry.curry ?L' ?L' ?L'"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> constL.map j = Curry.curry ?L' ?L' ?L' j"
using Curry.curry_def constL.is_extensional by simp
moreover have "J.arr j \<Longrightarrow> constL.map j = Curry.curry ?L' ?L' ?L' j"
proof -
assume j: "J.arr j"
show "constL.map j = Curry.curry ?L' ?L' ?L' j"
proof -
- have "constL.map j = mkIde ?L" using j constL.map_simp by simp
- moreover have "... = mkArr ?L ?L ?L" by simp
- moreover have "... = mkArr (\<lambda>a. ?L' (J.dom j, a)) (\<lambda>a. ?L' (J.cod j, a))
+ have "constL.map j = MkIde ?L" using j constL.map_simp by simp
+ moreover have "... = MkArr ?L ?L ?L" by simp
+ moreover have "... = MkArr (\<lambda>a. ?L' (J.dom j, a)) (\<lambda>a. ?L' (J.cod j, a))
(\<lambda>a. ?L' (j, a))"
- using j constL.value_is_ide in_homE ide_in_hom by (intro mkArr_eqI, auto)
+ using j constL.value_is_ide in_homE ide_in_hom by (intro MkArr_eqI, auto)
moreover have "... = Curry.curry ?L' ?L' ?L' j"
using j Curry.curry_def by auto
ultimately show ?thesis by force
qed
qed
ultimately show "constL.map j = Curry.curry ?L' ?L' ?L' j" by blast
qed
hence uncurry_constL: "Curry.uncurry constL.map = ?L'"
using L'.natural_transformation_axioms Curry.uncurry_curry by simp
interpret curry_\<chi>': natural_transformation J comp constL.map D
- "Curry.curry ?L' (Curry.uncurry D) \<chi>'.map"
+ \<open>Curry.curry ?L' (Curry.uncurry D) \<chi>'.map\<close>
proof -
have 1: "Curry.curry (Curry.uncurry D) (Curry.uncurry D) (Curry.uncurry D) = D"
using Curry.curry_uncurry D.functor_axioms D.natural_transformation_axioms
by blast
thus "natural_transformation J comp constL.map D
(Curry.curry ?L' (Curry.uncurry D) \<chi>'.map)"
using Curry.curry_preserves_transformations curry_L' \<chi>'.natural_transformation_axioms
by force
qed
- interpret curry_\<chi>': cone J comp D "mkIde ?L" "Curry.curry ?L' (Curry.uncurry D) \<chi>'.map" ..
+ interpret curry_\<chi>': cone J comp D \<open>MkIde ?L\<close> \<open>Curry.curry ?L' (Curry.uncurry D) \<chi>'.map\<close> ..
text\<open>
The value of \<open>curry_\<chi>'\<close> at each object \<open>a\<close> of \<open>A\<close> is the
limit cone \<open>\<chi> a\<close>, hence \<open>curry_\<chi>'\<close> is a limit cone.
\<close>
have 1: "\<And>a. A.ide a \<Longrightarrow> D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) = ?\<chi> a"
proof -
fix a
assume a: "A.ide a"
have "D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) =
(\<lambda>j. Curry.uncurry (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) (j, a))"
using a by simp
moreover have "... = (\<lambda>j. \<chi>'.map (j, a))"
using a Curry.uncurry_curry \<chi>'.natural_transformation_axioms by simp
moreover have "... = ?\<chi> a"
proof (intro NaturalTransformation.eqI)
- interpret \<chi>a: limit_cone J B "D.at a D" "?l a" "?\<chi> a" using a l\<chi> by simp
- interpret \<chi>': binary_functor_transformation J A B ?L' "Curry.uncurry D" \<chi>'.map ..
+ interpret \<chi>a: limit_cone J B \<open>D.at a D\<close> \<open>?l a\<close> \<open>?\<chi> a\<close> using a l\<chi> by simp
+ interpret \<chi>': binary_functor_transformation J A B ?L' \<open>Curry.uncurry D\<close> \<chi>'.map ..
show "natural_transformation J B \<chi>a.A.map (D.at a D) (?\<chi> a)" ..
show "natural_transformation J B \<chi>a.A.map (D.at a D) (\<lambda>j. \<chi>'.map (j, a))"
proof -
have "\<chi>a.A.map = (\<lambda>j. ?L' (j, a))"
using a \<chi>a.A.map_def L'_ide by auto
thus ?thesis
using a \<chi>'.fixing_ide_gives_natural_transformation_2 by simp
qed
fix j
assume j: "J.ide j"
show "\<chi>'.map (j, a) = ?\<chi> a j"
using a j \<chi>'.map_simp_ide by simp
qed
ultimately show "D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) = ?\<chi> a" by simp
qed
hence 2: "\<And>a. A.ide a \<Longrightarrow> diagram.limit_cone J B (D.at a D) (?l a)
(D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map))"
using l\<chi> by simp
- hence "limit_cone J comp D (mkIde ?L) (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map)"
+ hence "limit_cone J comp D (MkIde ?L) (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map)"
proof -
- have "\<And>a. A.ide a \<Longrightarrow> Fun (mkIde ?L) a = ?l a"
+ have "\<And>a. A.ide a \<Longrightarrow> Map (MkIde ?L) a = ?l a"
using L.functor_axioms L_ide by simp
thus ?thesis
using 1 2 curry_\<chi>'.cone_axioms curry_L' D.cone_is_limit_if_pointwise_limit by simp
qed
thus "\<exists>x \<chi>. limit_cone J comp D x \<chi>" by blast
qed
thus "\<forall>D. diagram J comp D \<longrightarrow> (\<exists>x \<chi>. limit_cone J comp D x \<chi>)" by blast
qed
lemma has_limits_if_target_does:
assumes "B.has_limits (undefined :: 'j)"
shows "has_limits (undefined :: 'j)"
using assms B.has_limits_def has_limits_def has_limits_of_shape_if_target_does by fast
end
section "The Yoneda Functor Preserves Limits"
text\<open>
In this section, we show that the Yoneda functor from \<open>C\<close> to \<open>[Cop, S]\<close>
preserves limits.
\<close>
context yoneda_functor
begin
lemma preserves_limits:
fixes J :: "'j comp"
assumes "diagram J C D" and "diagram.has_as_limit J C D a"
shows "diagram.has_as_limit J Cop_S.comp (map o D) (map a)"
proof -
text\<open>
The basic idea of the proof is as follows:
If \<open>\<chi>\<close> is a limit cone in \<open>C\<close>, then for every object \<open>a'\<close>
of \<open>Cop\<close> the evaluation of \<open>Y o \<chi>\<close> at \<open>a'\<close> is a limit cone
in \<open>S\<close>. By the results on limits in functor categories,
this implies that \<open>Y o \<chi>\<close> is a limit cone in \<open>[Cop, S]\<close>.
\<close>
interpret J: category J using assms(1) diagram_def by auto
interpret D: diagram J C D using assms(1) by auto
from assms(2) obtain \<chi> where \<chi>: "D.limit_cone a \<chi>" by blast
interpret \<chi>: limit_cone J C D a \<chi> using \<chi> by auto
have a: "C.ide a" using \<chi>.ide_apex by auto
- interpret YoD: diagram J Cop_S.comp "map o D"
+ interpret YoD: diagram J Cop_S.comp \<open>map o D\<close>
using D.diagram_axioms functor_axioms preserves_diagrams [of J D] by simp
- interpret YoD: diagram_in_functor_category Cop.comp S J "map o D" ..
- interpret Yo\<chi>: cone J Cop_S.comp "map o D" "map a" "map o \<chi>"
+ interpret YoD: diagram_in_functor_category Cop.comp S J \<open>map o D\<close> ..
+ interpret Yo\<chi>: cone J Cop_S.comp \<open>map o D\<close> \<open>map a\<close> \<open>map o \<chi>\<close>
using \<chi>.cone_axioms preserves_cones by blast
have "\<And>a'. C.ide a' \<Longrightarrow>
limit_cone J S (YoD.at a' (map o D))
- (Cop_S.Fun (map a) a') (YoD.at a' (map o \<chi>))"
+ (Cop_S.Map (map a) a') (YoD.at a' (map o \<chi>))"
proof -
fix a'
assume a': "C.ide a'"
interpret A': constant_functor J C a'
using a' by (unfold_locales, auto)
- interpret YoD_a': diagram J S "YoD.at a' (map o D)"
+ interpret YoD_a': diagram J S \<open>YoD.at a' (map o D)\<close>
using a' YoD.at_ide_is_diagram by simp
- interpret Yo\<chi>_a': cone J S "YoD.at a' (map o D)"
- "Cop_S.Fun (map a) a'" "YoD.at a' (map o \<chi>)"
+ interpret Yo\<chi>_a': cone J S \<open>YoD.at a' (map o D)\<close>
+ \<open>Cop_S.Map (map a) a'\<close> \<open>YoD.at a' (map o \<chi>)\<close>
using a' YoD.cone_at_ide_is_cone Yo\<chi>.cone_axioms by fastforce
have eval_at_ide: "\<And>j. J.ide j \<Longrightarrow> YoD.at a' (map \<circ> D) j = Hom.map (a', D j)"
proof -
fix j
assume j: "J.ide j"
- have "YoD.at a' (map \<circ> D) j = Cop_S.Fun (map (D j)) a'"
+ have "YoD.at a' (map \<circ> D) j = Cop_S.Map (map (D j)) a'"
using a' j YoD.at_simp YoD.preserves_arr [of j] by auto
also have "... = Y (D j) a'" using Y_def by simp
also have "... = Hom.map (a', D j)" using a' j D.preserves_arr by simp
finally show "YoD.at a' (map \<circ> D) j = Hom.map (a', D j)" by auto
qed
have eval_at_arr: "\<And>j. J.arr j \<Longrightarrow> YoD.at a' (map \<circ> \<chi>) j = Hom.map (a', \<chi> j)"
proof -
fix j
assume j: "J.arr j"
- have "YoD.at a' (map \<circ> \<chi>) j = Cop_S.Fun ((map o \<chi>) j) a'"
+ have "YoD.at a' (map \<circ> \<chi>) j = Cop_S.Map ((map o \<chi>) j) a'"
using a' j YoD.at_simp [of a' j "map o \<chi>"] preserves_arr by fastforce
also have "... = Y (\<chi> j) a'" using Y_def by simp
also have "... = Hom.map (a', \<chi> j)" using a' j by simp
finally show "YoD.at a' (map \<circ> \<chi>) j = Hom.map (a', \<chi> j)" by auto
qed
- have Fun_map_a_a': "Cop_S.Fun (map a) a' = Hom.map (a', a)"
- using a a' map_simp preserves_arr [of a] Cop_S.Fun_mkArr by simp
+ have Fun_map_a_a': "Cop_S.Map (map a) a' = Hom.map (a', a)"
+ using a a' map_simp preserves_arr [of a] by simp
show "limit_cone J S (YoD.at a' (map o D))
- (Cop_S.Fun (map a) a') (YoD.at a' (map o \<chi>))"
+ (Cop_S.Map (map a) a') (YoD.at a' (map o \<chi>))"
proof
fix x \<sigma>
assume \<sigma>: "YoD_a'.cone x \<sigma>"
- interpret \<sigma>: cone J S "YoD.at a' (map o D)" x \<sigma> using \<sigma> by auto
+ interpret \<sigma>: cone J S \<open>YoD.at a' (map o D)\<close> x \<sigma> using \<sigma> by auto
have x: "S.ide x" using \<sigma>.ide_apex by simp
text\<open>
For each object \<open>j\<close> of \<open>J\<close>, the component \<open>\<sigma> j\<close>
is an arrow in \<open>S.hom x (Hom.map (a', D j))\<close>.
Each element \<open>e \<in> S.set x\<close> therefore determines an arrow
\<open>\<psi> (a', D j) (S.Fun (\<sigma> j) e) \<in> C.hom a' (D j)\<close>.
These arrows are the components of a cone \<open>\<kappa> e\<close> over @{term D}
with apex @{term a'}.
\<close>
have \<sigma>j: "\<And>j. J.ide j \<Longrightarrow> \<guillemotleft>\<sigma> j : x \<rightarrow>\<^sub>S Hom.map (a', D j)\<guillemotright>"
using eval_at_ide \<sigma>.preserves_hom J.ide_in_hom by force
have \<kappa>: "\<And>e. e \<in> S.set x \<Longrightarrow>
transformation_by_components
J C A'.map D (\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e))"
proof -
fix e
assume e: "e \<in> S.set x"
show "transformation_by_components J C A'.map D (\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e))"
proof
fix j
assume j: "J.ide j"
show "\<guillemotleft>\<psi> (a', D j) (S.Fun (\<sigma> j) e) : A'.map j \<rightarrow> D j\<guillemotright>"
using e j S.Fun_mapsto [of "\<sigma> j"] A'.preserves_ide Hom.set_map eval_at_ide
Hom.\<psi>_mapsto [of "A'.map j" "D j"]
by force
next
fix j
assume j: "J.arr j"
show "\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<cdot> A'.map j =
D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)"
proof -
have 1: "Y (D j) a' =
S.mkArr (Hom.set (a', D (J.dom j))) (Hom.set (a', D (J.cod j)))
(\<phi> (a', D (J.cod j)) \<circ> C (D j) \<circ> \<psi> (a', D (J.dom j)))"
using j a' D.preserves_hom
Y_arr_ide [of a' "D j" "D (J.dom j)" "D (J.cod j)"]
by blast
have "\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<cdot> A'.map j =
\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<cdot> a'"
using A'.map_simp j by simp
also have "... = \<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e)"
proof -
have "\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<in> C.hom a' (D (J.cod j))"
using a' e j Hom.\<psi>_mapsto [of "A'.map j" "D (J.cod j)"] A'.map_simp
S.Fun_mapsto [of "\<sigma> (J.cod j)"] Hom.set_map eval_at_ide
by auto
thus ?thesis
using C.comp_arr_dom by fastforce
qed
also have "... = \<psi> (a', D (J.cod j)) (S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e))"
proof -
have "S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e) =
(S.Fun (Y (D j) a') o S.Fun (\<sigma> (J.dom j))) e"
by simp
also have "... = S.Fun (Y (D j) a' \<cdot>\<^sub>S \<sigma> (J.dom j)) e"
using a' e j Y_arr_ide(1) S.in_homE \<sigma>j eval_at_ide S.Fun_comp by force
also have "... = S.Fun (\<sigma> (J.cod j)) e"
using a' j x \<sigma>.is_natural_2 \<sigma>.A.map_simp S.comp_arr_dom J.arr_cod_iff_arr
J.cod_cod YoD.preserves_arr \<sigma>.is_natural_1 YoD.at_simp
by auto
finally have
"S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e) = S.Fun (\<sigma> (J.cod j)) e"
by auto
thus ?thesis by simp
qed
also have "... = D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)"
proof -
have "e \<in> S.Dom (\<sigma> (J.dom j))"
using e j by simp
hence "S.Fun (\<sigma> (J.dom j)) e \<in> S.Cod (\<sigma> (J.dom j))"
using e j S.Fun_mapsto [of "\<sigma> (J.dom j)"] by auto
hence 2: "S.Fun (\<sigma> (J.dom j)) e \<in> Hom.set (a', D (J.dom j))"
proof -
have "YoD.at a' (map \<circ> D) (J.dom j) = S.mkIde (Hom.set (a', D (J.dom j)))"
using a' j YoD.at_simp by (simp add: eval_at_ide)
moreover have "S.Cod (\<sigma> (J.dom j)) = Hom.set (a', D (J.dom j))"
using a' e j Hom.set_map YoD.at_simp eval_at_ide by simp
ultimately show ?thesis
using a' e j \<sigma>j S.Fun_mapsto [of "\<sigma> (J.dom j)"] Hom.set_map
by auto
qed
hence "S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e) =
\<phi> (a', D (J.cod j)) (D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e))"
proof -
have "S.Fun (\<sigma> (J.dom j)) e \<in> Hom.set (a', D (J.dom j))"
using a' e j \<sigma>j S.Fun_mapsto [of "\<sigma> (J.dom j)"] Hom.set_map
by (auto simp add: eval_at_ide)
hence "C.arr (\<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)) \<and>
C.dom (\<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)) = a'"
using a' j Hom.\<psi>_mapsto [of a' "D (J.dom j)"] by auto
thus ?thesis
using a' e j 2 Hom.Fun_map C.comp_arr_dom by force
qed
moreover have "D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)
\<in> C.hom a' (D (J.cod j))"
proof -
have "\<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e) \<in> C.hom a' (D (J.dom j))"
using a' e j Hom.\<psi>_mapsto [of a' "D (J.dom j)"] eval_at_ide
S.Fun_mapsto [of "\<sigma> (J.dom j)"] Hom.set_map
by auto
thus ?thesis using j D.preserves_hom by blast
qed
ultimately show ?thesis using a' j Hom.\<psi>_\<phi> by simp
qed
finally show ?thesis by auto
qed
qed
qed
let ?\<kappa> = "\<lambda>e. transformation_by_components.map J C A'.map
(\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e))"
have cone_\<kappa>e: "\<And>e. e \<in> S.set x \<Longrightarrow> D.cone a' (?\<kappa> e)"
proof -
fix e
assume e: "e \<in> S.set x"
interpret \<kappa>e: transformation_by_components J C A'.map D
- "\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e)"
+ \<open>\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e)\<close>
using e \<kappa> by blast
show "D.cone a' (?\<kappa> e)" ..
qed
text\<open>
Since \<open>\<kappa> e\<close> is a cone for each element \<open>e\<close> of \<open>S.set x\<close>,
by the universal property of the limit cone \<open>\<chi>\<close> there is a unique arrow
\<open>fe \<in> C.hom a' a\<close> that transforms \<open>\<chi>\<close> to \<open>\<kappa> e\<close>.
\<close>
have ex_fe: "\<And>e. e \<in> S.set x \<Longrightarrow> \<exists>!fe. \<guillemotleft>fe : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map fe \<chi> = ?\<kappa> e"
using cone_\<kappa>e \<chi>.is_universal by simp
text\<open>
The map taking \<open>e \<in> S.set x\<close> to \<open>fe \<in> C.hom a' a\<close>
determines an arrow \<open>f \<in> S.hom x (Hom (a', a))\<close> that
transforms the cone obtained by evaluating \<open>Y o \<chi>\<close> at \<open>a'\<close>
to the cone \<open>\<sigma>\<close>.
\<close>
let ?f = "S.mkArr (S.set x) (Hom.set (a', a))
(\<lambda>e. \<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)))"
have 0: "(\<lambda>e. \<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e))) \<in> S.set x \<rightarrow> Hom.set (a', a)"
proof
fix e
assume e: "e \<in> S.set x"
- interpret \<kappa>e: cone J C D a' "?\<kappa> e" using e cone_\<kappa>e by simp
+ interpret \<kappa>e: cone J C D a' \<open>?\<kappa> e\<close> using e cone_\<kappa>e by simp
have "\<chi>.induced_arrow a' (?\<kappa> e) \<in> C.hom a' a"
using a a' e ex_fe \<chi>.induced_arrowI \<kappa>e.cone_axioms by simp
thus "\<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)) \<in> Hom.set (a', a)"
using a a' Hom.\<phi>_mapsto by auto
qed
hence f: "\<guillemotleft>?f : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright>"
using a a' x \<sigma>.ide_apex S.mkArr_in_hom [of "S.set x" "Hom.set (a', a)"]
Hom.set_subset_Univ
by simp
have "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) = \<sigma>"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J S \<sigma>.A.map (YoD.at a' (map o D)) \<sigma>"
using \<sigma>.natural_transformation_axioms by auto
- have 1: "S.cod ?f = Cop_S.Fun (map a) a'"
+ have 1: "S.cod ?f = Cop_S.Map (map a) a'"
using f Fun_map_a_a' by force
- interpret YoD_a'of: cone J S "YoD.at a' (map o D)" x
- "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>))"
+ interpret YoD_a'of: cone J S \<open>YoD.at a' (map o D)\<close> x
+ \<open>YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>))\<close>
proof -
have "YoD_a'.cone (S.cod ?f) (YoD.at a' (map o \<chi>))"
- using a a' f Yo\<chi>_a'.cone_axioms Cop_S.Fun_mkArr preserves_arr [of a] by auto
+ using a a' f Yo\<chi>_a'.cone_axioms preserves_arr [of a] by auto
hence "YoD_a'.cone (S.dom ?f) (YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)))"
using f YoD_a'.cones_map_mapsto S.arrI by blast
thus "cone J S (YoD.at a' (map o D)) x
(YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)))"
using f by auto
qed
show "natural_transformation J S \<sigma>.A.map (YoD.at a' (map o D))
(YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)))" ..
fix j
assume j: "J.ide j"
have "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) j = YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f"
using f j Fun_map_a_a' Yo\<chi>_a'.cone_axioms by fastforce
also have "... = \<sigma> j"
proof (intro S.arr_eqI)
show "S.par (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) (\<sigma> j)"
using 1 f j x YoD_a'.preserves_hom by fastforce
show "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) = S.Fun (\<sigma> j)"
proof
fix e
have "e \<notin> S.set x \<Longrightarrow> S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
proof -
assume e: "e \<notin> S.set x"
have "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = undefined"
using 1 e f j x S.Fun_mapsto by fastforce
also have "... = S.Fun (\<sigma> j) e"
proof -
have "\<guillemotleft>\<sigma> j : x \<rightarrow>\<^sub>S YoD.at a' (map \<circ> D) (J.cod j)\<guillemotright>"
using j \<sigma>.A.map_simp by force
thus ?thesis
using e j S.Fun_mapsto [of "\<sigma> j"] extensional_arb [of "S.Fun (\<sigma> j)"]
by fastforce
qed
finally show ?thesis by auto
qed
moreover have "e \<in> S.set x \<Longrightarrow>
S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
proof -
assume e: "e \<in> S.set x"
interpret \<kappa>e: transformation_by_components J C A'.map D
- "\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e)"
+ \<open>\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e)\<close>
using e \<kappa> by blast
- interpret \<kappa>e: cone J C D a' "?\<kappa> e" using e cone_\<kappa>e by simp
+ interpret \<kappa>e: cone J C D a' \<open>?\<kappa> e\<close> using e cone_\<kappa>e by simp
have induced_arrow: "\<chi>.induced_arrow a' (?\<kappa> e) \<in> C.hom a' a"
using a a' e ex_fe \<chi>.induced_arrowI \<kappa>e.cone_axioms by simp
have "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e =
restrict (S.Fun (YoD.at a' (map o \<chi>) j) o S.Fun ?f) (S.set x) e"
using 1 e f j S.Fun_comp YoD_a'.preserves_hom by force
also have "... = (\<phi> (a', D j) o C (\<chi> j) o \<psi> (a', a)) (S.Fun ?f e)"
using j a' f e Hom.map_simp_2 S.Fun_mkArr Hom.preserves_arr [of "(a', \<chi> j)"]
eval_at_arr
by (elim S.in_homE, auto)
also have "... = (\<phi> (a', D j) o C (\<chi> j) o \<psi> (a', a))
(\<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)))"
using e f S.Fun_mkArr by fastforce
also have "... = \<phi> (a', D j) (D.cones_map (\<chi>.induced_arrow a' (?\<kappa> e)) \<chi> j)"
using a a' e j 0 Hom.\<psi>_\<phi> induced_arrow \<chi>.cone_axioms
by auto
also have "... = \<phi> (a', D j) (?\<kappa> e j)"
using \<chi>.induced_arrowI \<kappa>e.cone_axioms by fastforce
also have "... = \<phi> (a', D j) (\<psi> (a', D j) (S.Fun (\<sigma> j) e))"
using j \<kappa>e.map_def [of j] by simp
also have "... = S.Fun (\<sigma> j) e"
proof -
have "S.Fun (\<sigma> j) e \<in> Hom.set (a', D j)"
using a' e j S.Fun_mapsto [of "\<sigma> j"] eval_at_ide Hom.set_map by auto
thus ?thesis
using a' j Hom.\<phi>_\<psi> C.ide_in_hom J.ide_in_hom by blast
qed
finally show "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
by auto
qed
ultimately show "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
by auto
qed
qed
finally show "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) j = \<sigma> j" by auto
qed
hence ff: "?f \<in> S.hom x (Hom.map (a', a)) \<and>
YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) = \<sigma>"
using f by auto
text\<open>
Any other arrow \<open>f' \<in> S.hom x (Hom.map (a', a))\<close> that
transforms the cone obtained by evaluating \<open>Y o \<chi>\<close> at @{term a'}
to the cone @{term \<sigma>}, must equal \<open>f\<close>, showing that \<open>f\<close>
is unique.
\<close>
moreover have "\<And>f'. \<guillemotleft>f' : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright> \<and>
YoD_a'.cones_map f' (YoD.at a' (map o \<chi>)) = \<sigma>
\<Longrightarrow> f' = ?f"
proof -
fix f'
assume f': "\<guillemotleft>f' : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright> \<and>
YoD_a'.cones_map f' (YoD.at a' (map o \<chi>)) = \<sigma>"
show "f' = ?f"
proof (intro S.arr_eqI)
show par: "S.par f' ?f" using f f' by (elim S.in_homE, auto)
show "S.Fun f' = S.Fun ?f"
proof
fix e
have "e \<notin> S.set x \<Longrightarrow> S.Fun f' e = S.Fun ?f e"
using f f' x S.Fun_mapsto extensional_arb by fastforce
moreover have "e \<in> S.set x \<Longrightarrow> S.Fun f' e = S.Fun ?f e"
proof -
assume e: "e \<in> S.set x"
have 1: "\<guillemotleft>\<psi> (a', a) (S.Fun f' e) : a' \<rightarrow> a\<guillemotright>"
proof -
have "S.Fun f' e \<in> S.Cod f'"
using a a' e f' S.Fun_mapsto by auto
hence "S.Fun f' e \<in> Hom.set (a', a)"
using a a' f' Hom.set_map by auto
thus ?thesis
using a a' e f' S.Fun_mapsto Hom.\<psi>_mapsto Hom.set_map by blast
qed
have 2: "\<guillemotleft>\<psi> (a', a) (S.Fun ?f e) : a' \<rightarrow> a\<guillemotright>"
proof -
have "S.Fun ?f e \<in> S.Cod ?f"
using a a' e f S.Fun_mapsto by force
hence "S.Fun ?f e \<in> Hom.set (a', a)"
using a a' f Hom.set_map by auto
thus ?thesis
using a a' e f' S.Fun_mapsto Hom.\<psi>_mapsto Hom.set_map by blast
qed
- interpret \<chi>ofe: cone J C D a' "D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>"
+ interpret \<chi>ofe: cone J C D a' \<open>D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>\<close>
proof -
have "D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<in> D.cones a \<rightarrow> D.cones a'"
using 2 D.cones_map_mapsto [of "\<psi> (a', a) (S.Fun ?f e)"]
by (elim C.in_homE, auto)
thus "cone J C D a' (D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>)"
using \<chi>.cone_axioms by blast
qed
have f'e: "S.Fun f' e \<in> Hom.set (a', a)"
using a a' e f' x S.Fun_mapsto [of f'] Hom.set_map by fastforce
have fe: "S.Fun ?f e \<in> Hom.set (a', a)"
using e f by (elim S.in_homE, auto)
have A: "\<And>h j. h \<in> C.hom a' a \<Longrightarrow> J.arr j \<Longrightarrow>
S.Fun (YoD.at a' (map o \<chi>) j) (\<phi> (a', a) h)
= \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> h)"
proof -
fix h j
assume j: "J.arr j"
assume h: "h \<in> C.hom a' a"
have "S.Fun (YoD.at a' (map o \<chi>) j) = S.Fun (Y (\<chi> j) a')"
using a' j YoD.at_simp Y_def Yo\<chi>.preserves_reflects_arr [of j]
by simp
also have "... = restrict (\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a))
(Hom.set (a', a))"
proof -
have "S.arr (Y (\<chi> j) a') \<and>
Y (\<chi> j) a' = S.mkArr (Hom.set (a', a)) (Hom.set (a', D (J.cod j)))
(\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a))"
using a' j \<chi>.preserves_hom [of j "J.dom j" "J.cod j"]
Y_arr_ide [of a' "\<chi> j" a "D (J.cod j)"] \<chi>.A.map_simp
by auto
thus ?thesis
using S.Fun_mkArr by metis
qed
finally have "S.Fun (YoD.at a' (map o \<chi>) j)
= restrict (\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a))
(Hom.set (a', a))"
by auto
hence "S.Fun (YoD.at a' (map o \<chi>) j) (\<phi> (a', a) h)
= (\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a)) (\<phi> (a', a) h)"
using a a' h Hom.\<phi>_mapsto by auto
also have "... = \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> h)"
using a a' h Hom.\<psi>_\<phi> by simp
finally show "S.Fun (YoD.at a' (map o \<chi>) j) (\<phi> (a', a) h)
= \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> h)"
by auto
qed
have "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> =
D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>"
proof
fix j
have "\<not>J.arr j \<Longrightarrow> D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
using 1 2 \<chi>.cone_axioms by (elim C.in_homE, auto)
moreover have "J.arr j \<Longrightarrow> D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
proof -
assume j: "J.arr j"
have 3: "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun f' e) = S.Fun (\<sigma> j) e"
using Fun_map_a_a' a a' j f' e x Yo\<chi>_a'.A.map_simp eval_at_ide
Yo\<chi>_a'.cone_axioms
by auto
have 4: "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e) = S.Fun (\<sigma> j) e"
proof -
have "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e)
= (S.Fun (YoD.at a' (map o \<chi>) j) o S.Fun ?f) e"
by simp
also have "... = S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e"
using Fun_map_a_a' a a' j f e x Yo\<chi>_a'.A.map_simp eval_at_ide
by auto
also have "... = S.Fun (\<sigma> j) e"
proof -
have "YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f =
YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) j"
using j f Yo\<chi>_a'.cone_axioms Fun_map_a_a' by auto
thus ?thesis using j ff by argo
qed
finally show ?thesis by auto
qed
have "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
\<chi> j \<cdot> \<psi> (a', a) (S.Fun f' e)"
using j 1 \<chi>.cone_axioms by auto
also have "... = \<psi> (a', D (J.cod j)) (S.Fun (\<sigma> j) e)"
proof -
have "\<psi> (a', D (J.cod j)) (S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun f' e)) =
\<psi> (a', D (J.cod j))
(\<phi> (a', D (J.cod j)) (\<chi> j \<cdot> \<psi> (a', a) (S.Fun f' e)))"
using j a a' f'e A Hom.\<phi>_\<psi> Hom.\<psi>_mapsto by force
moreover have "\<chi> j \<cdot> \<psi> (a', a) (S.Fun f' e) \<in> C.hom a' (D (J.cod j))"
using a a' j f'e Hom.\<psi>_mapsto \<chi>.preserves_hom [of j "J.dom j" "J.cod j"]
\<chi>.A.map_simp
by auto
ultimately show ?thesis
using a a' 3 4 Hom.\<psi>_\<phi> by auto
qed
also have "... = \<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e)"
proof -
have "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e) =
\<phi> (a', D (J.cod j)) (\<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e))"
using j a a' fe A [of "\<psi> (a', a) (S.Fun ?f e)" j] Hom.\<phi>_\<psi> Hom.\<psi>_mapsto
by auto
hence "\<psi> (a', D (J.cod j)) (S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e)) =
\<psi> (a', D (J.cod j))
(\<phi> (a', D (J.cod j)) (\<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e)))"
by simp
moreover have "\<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e) \<in> C.hom a' (D (J.cod j))"
using a a' j fe Hom.\<psi>_mapsto \<chi>.preserves_hom [of j "J.dom j" "J.cod j"]
\<chi>.A.map_simp
by auto
ultimately show ?thesis
using a a' 3 4 Hom.\<psi>_\<phi> by auto
qed
also have "... = D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
using j 2 \<chi>.cone_axioms by force
finally show "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
by auto
qed
ultimately show "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
by auto
qed
hence "\<psi> (a', a) (S.Fun f' e) = \<psi> (a', a) (S.Fun ?f e)"
using 1 2 \<chi>ofe.cone_axioms \<chi>.cone_axioms \<chi>.is_universal by blast
hence "\<phi> (a', a) (\<psi> (a', a) (S.Fun f' e)) = \<phi> (a', a) (\<psi> (a', a) (S.Fun ?f e))"
by simp
thus "S.Fun f' e = S.Fun ?f e"
using a a' fe f'e Hom.\<phi>_\<psi> by force
qed
ultimately show "S.Fun f' e = S.Fun ?f e" by auto
qed
qed
qed
ultimately have "\<exists>!f. \<guillemotleft>f : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright> \<and>
YoD_a'.cones_map f (YoD.at a' (map o \<chi>)) = \<sigma>"
using ex1I [of "\<lambda>f. S.in_hom x (Hom.map (a', a)) f \<and>
YoD_a'.cones_map f (YoD.at a' (map o \<chi>)) = \<sigma>"]
by blast
- thus "\<exists>!f. \<guillemotleft>f : x \<rightarrow>\<^sub>S Cop_S.Fun (map a) a'\<guillemotright> \<and>
+ thus "\<exists>!f. \<guillemotleft>f : x \<rightarrow>\<^sub>S Cop_S.Map (map a) a'\<guillemotright> \<and>
YoD_a'.cones_map f (YoD.at a' (map o \<chi>)) = \<sigma>"
using a a' Y_def [of a] by simp
qed
qed
thus "YoD.has_as_limit (map a)"
using YoD.cone_is_limit_if_pointwise_limit Yo\<chi>.cone_axioms by auto
qed
end
end
diff --git a/thys/Category3/NaturalTransformation.thy b/thys/Category3/NaturalTransformation.thy
--- a/thys/Category3/NaturalTransformation.thy
+++ b/thys/Category3/NaturalTransformation.thy
@@ -1,949 +1,939 @@
(* Title: NaturalTransformation
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter NaturalTransformation
theory NaturalTransformation
imports Functor
begin
section "Definition of a Natural Transformation"
text\<open>
As is the case for functors, the ``object-free'' definition of category
makes it possible to view natural transformations as functions on arrows.
In particular, a natural transformation between functors
@{term F} and @{term G} from @{term A} to @{term B} can be represented by
the map that takes each arrow @{term f} of @{term A} to the diagonal of the
square in @{term B} corresponding to the transformation of @{term "F f"}
to @{term "G f"}. The images of the identities of @{term A} under this
map are the usual components of the natural transformation.
This representation exhibits natural transformations as a kind of generalization
of functors, and in fact we can directly identify functors with identity
natural transformations.
However, functors are still necessary to state the defining conditions for
a natural transformation, as the domain and codomain of a natural transformation
cannot be recovered from the map on arrows that represents it.
Like functors, natural transformations preserve arrows and map non-arrows to null.
Natural transformations also ``preserve'' domain and codomain, but in a more general
sense than functors. The naturality conditions, which express the two ways of factoring
the diagonal of a commuting square, are degenerate in the case of an identity transformation.
\<close>
locale natural_transformation =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'a \<Rightarrow> 'b"
and \<tau> :: "'a \<Rightarrow> 'b" +
assumes is_extensional: "\<not>A.arr f \<Longrightarrow> \<tau> f = B.null"
and preserves_dom [iff]: "A.arr f \<Longrightarrow> B.dom (\<tau> f) = F (A.dom f)"
and preserves_cod [iff]: "A.arr f \<Longrightarrow> B.cod (\<tau> f) = G (A.cod f)"
and is_natural_1 [iff]: "A.arr f \<Longrightarrow> G f \<cdot>\<^sub>B \<tau> (A.dom f) = \<tau> f"
and is_natural_2 [iff]: "A.arr f \<Longrightarrow> \<tau> (A.cod f) \<cdot>\<^sub>B F f = \<tau> f"
begin
lemma naturality:
assumes "A.arr f"
shows "\<tau> (A.cod f) \<cdot>\<^sub>B F f = G f \<cdot>\<^sub>B \<tau> (A.dom f)"
using assms is_natural_1 is_natural_2 by simp
text\<open>
The following fact for natural transformations provides us with the same advantages
as the corresponding fact for functors.
\<close>
lemma preserves_reflects_arr [iff]:
shows "B.arr (\<tau> f) \<longleftrightarrow> A.arr f"
using is_extensional A.arr_cod_iff_arr B.arr_cod_iff_arr preserves_cod by force
lemma preserves_hom [intro]:
assumes "\<guillemotleft>f : a \<rightarrow>\<^sub>A b\<guillemotright>"
shows "\<guillemotleft>\<tau> f : F a \<rightarrow>\<^sub>B G b\<guillemotright>"
using assms
by (metis A.in_homE B.arr_cod_iff_arr B.in_homI G.preserves_arr G.preserves_cod
preserves_cod preserves_dom)
lemma preserves_comp_1:
assumes "A.seq f' f"
shows "\<tau> (f' \<cdot>\<^sub>A f) = G f' \<cdot>\<^sub>B \<tau> f"
using assms
by (metis A.seqE A.dom_comp B.comp_assoc G.preserves_comp is_natural_1)
lemma preserves_comp_2:
assumes "A.seq f' f"
shows "\<tau> (f' \<cdot>\<^sub>A f) = \<tau> f' \<cdot>\<^sub>B F f"
using assms
by (metis A.arr_cod_iff_arr A.cod_comp B.comp_assoc F.preserves_comp is_natural_2)
text\<open>
A natural transformation that also happens to be a functor is equal to
its own domain and codomain.
\<close>
lemma functor_implies_equals_dom:
assumes "functor A B \<tau>"
shows "F = \<tau>"
proof
interpret \<tau>: "functor" A B \<tau> using assms by auto
fix f
show "F f = \<tau> f"
using assms
by (metis A.dom_cod B.comp_cod_arr F.is_extensional F.preserves_arr F.preserves_cod
\<tau>.preserves_dom is_extensional is_natural_2 preserves_dom)
qed
lemma functor_implies_equals_cod:
assumes "functor A B \<tau>"
shows "G = \<tau>"
proof
interpret \<tau>: "functor" A B \<tau> using assms by auto
fix f
show "G f = \<tau> f"
using assms
by (metis A.cod_dom B.comp_arr_dom F.preserves_arr G.is_extensional G.preserves_arr
G.preserves_dom B.cod_dom functor_implies_equals_dom is_extensional
is_natural_1 preserves_cod preserves_dom)
qed
end
section "Components of a Natural Transformation"
text\<open>
The values taken by a natural transformation on identities are the \emph{components}
of the transformation. We have the following basic technique for proving two natural
transformations equal: show that they have the same components.
\<close>
lemma eqI:
assumes "natural_transformation A B F G \<sigma>" and "natural_transformation A B F G \<sigma>'"
and "\<And>a. partial_magma.ide A a \<Longrightarrow> \<sigma> a = \<sigma>' a"
shows "\<sigma> = \<sigma>'"
proof -
interpret A: category A using assms(1) natural_transformation_def by blast
interpret \<sigma>: natural_transformation A B F G \<sigma> using assms(1) by auto
interpret \<sigma>': natural_transformation A B F G \<sigma>' using assms(2) by auto
have "\<And>f. \<sigma> f = \<sigma>' f"
using assms(3) \<sigma>.is_natural_2 \<sigma>'.is_natural_2 \<sigma>.is_extensional \<sigma>'.is_extensional A.ide_cod
by metis
thus ?thesis by auto
qed
text\<open>
As equality of natural transformations is determined by equality of components,
a natural transformation may be uniquely defined by specifying its components.
The extension to all arrows is given by @{prop is_natural_1} or equivalently
by @{prop is_natural_2}.
\<close>
locale transformation_by_components =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'a \<Rightarrow> 'b"
and t :: "'a \<Rightarrow> 'b" +
assumes maps_ide_in_hom [intro]: "A.ide a \<Longrightarrow> \<guillemotleft>t a : F a \<rightarrow>\<^sub>B G a\<guillemotright>"
and is_natural: "A.arr f \<Longrightarrow> t (A.cod f) \<cdot>\<^sub>B F f = G f \<cdot>\<^sub>B t (A.dom f)"
begin
definition map
where "map f = (if A.arr f then t (A.cod f) \<cdot>\<^sub>B F f else B.null)"
lemma map_simp_ide [simp]:
assumes "A.ide a"
shows "map a = t a"
using assms map_def B.comp_arr_dom [of "t a"] maps_ide_in_hom by fastforce
lemma is_natural_transformation:
shows "natural_transformation A B F G map"
using map_def is_natural
apply (unfold_locales, simp_all)
apply (metis A.ide_dom B.dom_comp B.seqI
G.preserves_arr G.preserves_dom B.in_homE maps_ide_in_hom)
apply (metis A.ide_dom B.arrI B.cod_comp B.in_homE B.seqI
G.preserves_arr G.preserves_cod G.preserves_dom maps_ide_in_hom)
apply (metis A.ide_dom B.comp_arr_dom B.in_homE maps_ide_in_hom)
by (metis B.comp_assoc A.comp_cod_arr F.preserves_comp)
end
sublocale transformation_by_components \<subseteq> natural_transformation A B F G map
using is_natural_transformation by auto
lemma transformation_by_components_idem [simp]:
assumes "natural_transformation A B F G \<tau>"
shows "transformation_by_components.map A B F \<tau> = \<tau>"
proof -
interpret \<tau>: natural_transformation A B F G \<tau> using assms by blast
interpret \<tau>': transformation_by_components A B F G \<tau>
by (unfold_locales, auto)
show ?thesis
using assms \<tau>'.map_simp_ide \<tau>'.is_natural_transformation eqI by blast
qed
section "Functors as Natural Transformations"
text\<open>
A functor is a special case of a natural transformation, in the sense that the same map
that defines the functor also defines an identity natural transformation.
\<close>
lemma functor_is_transformation [simp]:
assumes "functor A B F"
shows "natural_transformation A B F F F"
proof -
interpret "functor" A B F using assms by auto
show "natural_transformation A B F F F"
- using is_extensional B.comp_arr_dom B.comp_cod_arr by (unfold_locales, simp_all)
+ using is_extensional B.comp_arr_dom B.comp_cod_arr
+ by (unfold_locales, simp_all)
qed
sublocale "functor" \<subseteq> natural_transformation A B F F F
by (simp add: functor_axioms)
section "Constant Natural Transformations"
text\<open>
A constant natural transformation is one whose components are all the same arrow.
\<close>
locale constant_transformation =
A: category A +
B: category B +
F: constant_functor A B "B.dom g" +
G: constant_functor A B "B.cod g"
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and g :: 'b +
assumes value_is_arr: "B.arr g"
begin
definition map
where "map f \<equiv> if A.arr f then g else B.null"
lemma map_simp [simp]:
assumes "A.arr f"
shows "map f = g"
using assms map_def by auto
lemma is_natural_transformation:
shows "natural_transformation A B F.map G.map map"
apply unfold_locales
using map_def value_is_arr B.comp_arr_dom B.comp_cod_arr by auto
lemma is_functor_if_value_is_ide:
assumes "B.ide g"
shows "functor A B map"
apply unfold_locales using assms map_def by auto
end
sublocale constant_transformation \<subseteq> natural_transformation A B F.map G.map map
using is_natural_transformation by auto
context constant_transformation
begin
lemma equals_dom_if_value_is_ide:
assumes "B.ide g"
shows "map = F.map"
using assms functor_implies_equals_dom is_functor_if_value_is_ide by auto
lemma equals_cod_if_value_is_ide:
assumes "B.ide g"
shows "map = G.map"
using assms functor_implies_equals_dom is_functor_if_value_is_ide by auto
end
section "Vertical Composition"
text\<open>
Vertical composition is a way of composing natural transformations \<open>\<sigma>: F \<rightarrow> G\<close>
and \<open>\<tau>: G \<rightarrow> H\<close>, between parallel functors @{term F}, @{term G}, and @{term H}
to obtain a natural transformation from @{term F} to @{term H}.
The composite is traditionally denoted by \<open>\<tau> o \<sigma>\<close>, however in the present
setting this notation is misleading because it is horizontal composite, rather than
vertical composite, that coincides with composition of natural transformations as
functions on arrows.
\<close>
locale vertical_composite =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G +
H: "functor" A B H +
\<sigma>: natural_transformation A B F G \<sigma> +
\<tau>: natural_transformation A B G H \<tau>
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'a \<Rightarrow> 'b"
and H :: "'a \<Rightarrow> 'b"
and \<sigma> :: "'a \<Rightarrow> 'b"
and \<tau> :: "'a \<Rightarrow> 'b"
begin
text\<open>
Vertical composition takes an arrow @{term "A.in_hom a b f"} to an arrow in
@{term "B.hom (F a) (G b)"}, which we can obtain by forming either of
the composites @{term "B (\<tau> b) (\<sigma> f)"} or @{term "B (\<tau> f) (\<sigma> a)"}, which are
equal to each other.
\<close>
definition map
where "map f = (if A.arr f then \<tau> (A.cod f) \<cdot>\<^sub>B \<sigma> f else B.null)"
lemma map_seq:
assumes "A.arr f"
shows "B.seq (\<tau> (A.cod f)) (\<sigma> f)"
using assms by auto
lemma map_simp_ide:
assumes "A.ide a"
shows "map a = \<tau> a \<cdot>\<^sub>B \<sigma> a"
using assms map_def by auto
lemma map_simp_1:
assumes "A.arr f"
shows "map f = \<tau> (A.cod f) \<cdot>\<^sub>B \<sigma> f"
using assms by (simp add: map_def)
lemma map_simp_2:
assumes "A.arr f"
shows "map f = \<tau> f \<cdot>\<^sub>B \<sigma> (A.dom f)"
using assms
by (metis B.comp_assoc \<sigma>.is_natural_2 \<sigma>.naturality \<tau>.is_natural_1 \<tau>.naturality map_simp_1)
lemma is_natural_transformation:
shows "natural_transformation A B F H map"
using map_def map_simp_1 map_simp_2 map_seq B.comp_assoc
apply (unfold_locales, simp_all)
by (metis B.comp_assoc \<tau>.is_natural_1)
end
sublocale vertical_composite \<subseteq> natural_transformation A B F H map
using is_natural_transformation by auto
text\<open>
Functors are the identities for vertical composition.
\<close>
lemma vcomp_ide_dom [simp]:
assumes "natural_transformation A B F G \<tau>"
shows "vertical_composite.map A B F \<tau> = \<tau>"
using assms apply (intro eqI)
apply auto[2]
apply (meson functor_is_transformation natural_transformation_def vertical_composite.intro
vertical_composite.is_natural_transformation)
proof -
fix a :: 'a
have "vertical_composite A B F F G F \<tau>"
- by (meson assms functor_is_transformation natural_transformation.axioms(1)
- natural_transformation.axioms(2) natural_transformation.axioms(3)
- natural_transformation.axioms(4) vertical_composite.intro)
+ by (meson assms functor_is_transformation natural_transformation.axioms(1-4)
+ vertical_composite.intro)
thus "vertical_composite.map A B F \<tau> a = \<tau> a"
using assms natural_transformation.is_extensional natural_transformation.is_natural_2
vertical_composite.map_def
by fastforce
qed
lemma vcomp_ide_cod [simp]:
assumes "natural_transformation A B F G \<tau>"
shows "vertical_composite.map A B \<tau> G = \<tau>"
using assms apply (intro eqI)
apply auto[2]
apply (meson functor_is_transformation natural_transformation_def vertical_composite.intro
vertical_composite.is_natural_transformation)
proof -
fix a :: 'a
assume a: "partial_magma.ide A a"
interpret Go\<tau>: vertical_composite A B F G G \<tau> G
- by (meson assms functor_is_transformation natural_transformation.axioms(1)
- natural_transformation.axioms(2) natural_transformation.axioms(3)
- natural_transformation.axioms(4) vertical_composite.intro)
+ by (meson assms functor_is_transformation natural_transformation.axioms(1-4)
+ vertical_composite.intro)
show "vertical_composite.map A B \<tau> G a = \<tau> a"
using assms a natural_transformation.is_extensional natural_transformation.is_natural_1
- Go\<tau>.map_simp_ide [of a] Go\<tau>.B.comp_cod_arr
+ Go\<tau>.map_simp_ide Go\<tau>.B.comp_cod_arr
by simp
qed
text\<open>
Vertical composition is associative.
\<close>
lemma vcomp_assoc [simp]:
assumes "natural_transformation A B F G \<rho>"
and "natural_transformation A B G H \<sigma>"
and "natural_transformation A B H K \<tau>"
shows "vertical_composite.map A B (vertical_composite.map A B \<rho> \<sigma>) \<tau>
= vertical_composite.map A B \<rho> (vertical_composite.map A B \<sigma> \<tau>)"
proof -
interpret A: category A
using assms(1) natural_transformation_def functor_def by blast
interpret B: category B
using assms(1) natural_transformation_def functor_def by blast
interpret \<rho>: natural_transformation A B F G \<rho> using assms(1) by auto
interpret \<sigma>: natural_transformation A B G H \<sigma> using assms(2) by auto
interpret \<tau>: natural_transformation A B H K \<tau> using assms(3) by auto
interpret \<rho>\<sigma>: vertical_composite A B F G H \<rho> \<sigma> ..
interpret \<sigma>\<tau>: vertical_composite A B G H K \<sigma> \<tau> ..
interpret \<rho>_\<sigma>\<tau>: vertical_composite A B F G K \<rho> \<sigma>\<tau>.map ..
interpret \<rho>\<sigma>_\<tau>: vertical_composite A B F H K \<rho>\<sigma>.map \<tau> ..
show ?thesis
using \<rho>\<sigma>_\<tau>.is_natural_transformation \<rho>_\<sigma>\<tau>.natural_transformation_axioms
- apply (intro eqI, simp_all)
- using \<rho>\<sigma>.map_simp_ide \<rho>\<sigma>_\<tau>.map_simp_ide \<rho>_\<sigma>\<tau>.map_simp_ide \<sigma>\<tau>.map_simp_ide B.comp_assoc
- by force
+ \<rho>\<sigma>.map_simp_ide \<rho>\<sigma>_\<tau>.map_simp_ide \<rho>_\<sigma>\<tau>.map_simp_ide \<sigma>\<tau>.map_simp_ide B.comp_assoc
+ by (intro eqI, auto)
qed
section "Natural Isomorphisms"
text\<open>
A natural isomorphism is a natural transformation each of whose components
is an isomorphism. Equivalently, a natural isomorphism is a natural transformation
that is invertible with respect to vertical composition.
\<close>
locale natural_isomorphism = natural_transformation A B F G \<tau>
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'a \<Rightarrow> 'b"
and \<tau> :: "'a \<Rightarrow> 'b" +
assumes components_are_iso [simp]: "A.ide a \<Longrightarrow> B.iso (\<tau> a)"
begin
text \<open>
Natural isomorphisms preserve isomorphisms, in the sense that the sides of
of the naturality square determined by an isomorphism are all isomorphisms,
so the diagonal is, as well.
\<close>
lemma preserves_iso:
assumes "A.iso f"
shows "B.iso (\<tau> f)"
using assms
by (metis A.ide_dom A.iso_is_arr B.isos_compose G.preserves_iso components_are_iso
is_natural_2 naturality preserves_reflects_arr)
end
text \<open>
Since the function that represents a functor is formally identical to the function
that represents the corresponding identity natural transformation, no additional locale
is needed for identity natural transformations. However, an identity natural transformation
is also a natural isomorphism, so it is useful for @{locale functor} to inherit from the
@{locale natural_isomorphism} locale.
\<close>
sublocale "functor" \<subseteq> natural_isomorphism A B F F F
apply unfold_locales
using preserves_ide B.ide_is_iso by simp
definition naturally_isomorphic
where "naturally_isomorphic A B F G = (\<exists>\<tau>. natural_isomorphism A B F G \<tau>)"
lemma naturally_isomorphic_respects_full_functor:
assumes "naturally_isomorphic A B F G"
and "full_functor A B F"
shows "full_functor A B G"
proof -
obtain \<phi> where \<phi>: "natural_isomorphism A B F G \<phi>"
using assms naturally_isomorphic_def by blast
interpret \<phi>: natural_isomorphism A B F G \<phi>
using \<phi> by auto
interpret \<phi>.F: full_functor A B F
using assms by auto
write A (infixr "\<cdot>\<^sub>A" 55)
write B (infixr "\<cdot>\<^sub>B" 55)
write \<phi>.A.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A _\<guillemotright>")
write \<phi>.B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
show "full_functor A B G"
proof
fix a a' g
assume a': "\<phi>.A.ide a'" and a: "\<phi>.A.ide a"
and g: "\<guillemotleft>g : G a' \<rightarrow>\<^sub>B G a\<guillemotright>"
show "\<exists>f. \<guillemotleft>f : a' \<rightarrow>\<^sub>A a\<guillemotright> \<and> G f = g"
proof -
let ?g' = "\<phi>.B.inv (\<phi> a) \<cdot>\<^sub>B g \<cdot>\<^sub>B \<phi> a'"
have g': "\<guillemotleft>?g' : F a' \<rightarrow>\<^sub>B F a\<guillemotright>"
using a a' g \<phi>.preserves_hom \<phi>.components_are_iso \<phi>.B.inv_in_hom by force
obtain f' where f': "\<guillemotleft>f' : a' \<rightarrow>\<^sub>A a\<guillemotright> \<and> F f' = ?g'"
using a a' g' \<phi>.F.is_full [of a a' ?g'] by blast
moreover have "G f' = g"
proof -
have "G f' = \<phi> a \<cdot>\<^sub>B ?g' \<cdot>\<^sub>B \<phi>.B.inv (\<phi> a')"
- proof -
- have "\<phi>.B.seq (\<phi> a) (F f')"
- using a f' by (metis \<phi>.A.in_homE \<phi>.is_natural_2 \<phi>.preserves_reflects_arr)
- moreover have "G f' \<cdot>\<^sub>B \<phi> a' = \<phi> a \<cdot>\<^sub>B F f'"
- using a a' f' \<phi>.naturality [of f'] by force
- ultimately show ?thesis
- using a a' f' \<phi>.components_are_iso \<phi>.B.invert_side_of_triangle(2)
- by (metis \<phi>.B.comp_assoc)
- qed
+ using a a' f' \<phi>.naturality [of f'] \<phi>.components_are_iso \<phi>.is_natural_2
+ by (metis \<phi>.A.in_homE \<phi>.B.comp_assoc \<phi>.B.invert_side_of_triangle(2)
+ \<phi>.preserves_reflects_arr)
also have "... = (\<phi> a \<cdot>\<^sub>B \<phi>.B.inv (\<phi> a)) \<cdot>\<^sub>B g \<cdot>\<^sub>B \<phi> a' \<cdot>\<^sub>B \<phi>.B.inv (\<phi> a')"
using \<phi>.B.comp_assoc by auto
also have "... = g"
- using a a' g \<phi>.B.comp_arr_dom \<phi>.B.comp_cod_arr \<phi>.B.comp_arr_inv \<phi>.B.comp_inv_arr
+ using a a' g \<phi>.B.comp_arr_dom \<phi>.B.comp_cod_arr \<phi>.B.comp_arr_inv
\<phi>.B.inv_is_inverse
by auto
finally show ?thesis by blast
qed
ultimately show ?thesis by auto
qed
qed
qed
lemma naturally_isomorphic_respects_faithful_functor:
assumes "naturally_isomorphic A B F G"
and "faithful_functor A B F"
shows "faithful_functor A B G"
proof -
obtain \<phi> where \<phi>: "natural_isomorphism A B F G \<phi>"
using assms naturally_isomorphic_def by blast
interpret \<phi>: natural_isomorphism A B F G \<phi>
using \<phi> by auto
interpret \<phi>.F: faithful_functor A B F
using assms by auto
- write A (infixr "\<cdot>\<^sub>A" 55)
- write B (infixr "\<cdot>\<^sub>B" 55)
- write \<phi>.A.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A _\<guillemotright>")
- write \<phi>.B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
show "faithful_functor A B G"
- proof
- fix \<mu> \<mu>'
- assume par: "\<phi>.A.par \<mu> \<mu>'" and eq: "G \<mu> = G \<mu>'"
- show "\<mu> = \<mu>'"
- proof -
- have "\<phi> (\<phi>.A.cod \<mu>) \<cdot>\<^sub>B F \<mu> = \<phi> (\<phi>.A.cod \<mu>) \<cdot>\<^sub>B F \<mu>'"
- using par eq \<phi>.naturality by metis
- moreover have "\<phi>.B.mono (\<phi> (\<phi>.A.cod \<mu>))"
- using par \<phi>.components_are_iso \<phi>.B.iso_is_section \<phi>.B.section_is_mono by auto
- ultimately have "F \<mu> = F \<mu>'"
- using par \<phi>.B.monoE [of "\<phi> (\<phi>.A.cod \<mu>)" "F \<mu>" "F \<mu>'"] by auto
- thus "\<mu> = \<mu>'"
- using par \<phi>.F.is_faithful by blast
- qed
- qed
+ using \<phi>.naturality \<phi>.components_are_iso \<phi>.B.iso_is_section \<phi>.B.section_is_mono
+ \<phi>.B.monoE \<phi>.F.is_faithful \<phi>.is_natural_1 \<phi>.natural_transformation_axioms
+ \<phi>.preserves_reflects_arr \<phi>.A.ide_cod
+ by (unfold_locales, metis)
qed
locale inverse_transformation =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G +
\<tau>: natural_isomorphism A B F G \<tau>
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'a \<Rightarrow> 'b"
and \<tau> :: "'a \<Rightarrow> 'b"
begin
- interpretation \<tau>': transformation_by_components A B G F "\<lambda>a. B.inv (\<tau> a)"
+ interpretation \<tau>': transformation_by_components A B G F \<open>\<lambda>a. B.inv (\<tau> a)\<close>
proof
fix f :: 'a
show "A.ide f \<Longrightarrow> \<guillemotleft>B.inv (\<tau> f) : G f \<rightarrow>\<^sub>B F f\<guillemotright>"
using B.inv_in_hom \<tau>.components_are_iso A.ide_in_hom by blast
show "A.arr f \<Longrightarrow> B.inv (\<tau> (A.cod f)) \<cdot>\<^sub>B G f = F f \<cdot>\<^sub>B B.inv (\<tau> (A.dom f))"
by (metis A.ide_cod A.ide_dom B.invert_opposite_sides_of_square \<tau>.components_are_iso
\<tau>.is_natural_2 \<tau>.naturality \<tau>.preserves_reflects_arr)
qed
definition map
where "map = \<tau>'.map"
lemma map_ide_simp [simp]:
assumes "A.ide a"
shows "map a = B.inv (\<tau> a)"
using assms map_def by fastforce
lemma map_simp:
assumes "A.arr f"
shows "map f = B.inv (\<tau> (A.cod f)) \<cdot>\<^sub>B G f"
using assms map_def by (simp add: \<tau>'.map_def)
lemma is_natural_transformation:
shows "natural_transformation A B G F map"
by (simp add: \<tau>'.natural_transformation_axioms map_def)
lemma inverts_components:
assumes "A.ide a"
shows "B.inverse_arrows (\<tau> a) (map a)"
using assms \<tau>.components_are_iso B.ide_is_iso B.inv_is_inverse B.inverse_arrows_def map_def
by (metis \<tau>'.map_simp_ide)
end
sublocale inverse_transformation \<subseteq> natural_transformation A B G F map
using is_natural_transformation by auto
sublocale inverse_transformation \<subseteq> natural_isomorphism A B G F map
- by (meson B.category_axioms B.iso_def category.inverse_arrows_sym inverts_components
- natural_isomorphism.intro natural_isomorphism_axioms.intro
- natural_transformation_axioms)
+ by (simp add: B.iso_inv_iso natural_isomorphism.intro natural_isomorphism_axioms.intro
+ natural_transformation_axioms)
lemma inverse_inverse_transformation [simp]:
assumes "natural_isomorphism A B F G \<tau>"
shows "inverse_transformation.map A B F (inverse_transformation.map A B G \<tau>) = \<tau>"
proof -
interpret \<tau>: natural_isomorphism A B F G \<tau>
using assms by auto
interpret \<tau>': inverse_transformation A B F G \<tau> ..
interpret \<tau>'': inverse_transformation A B G F \<tau>'.map ..
show "\<tau>''.map = \<tau>"
using \<tau>.natural_transformation_axioms \<tau>''.natural_transformation_axioms
by (intro eqI, auto)
qed
locale inverse_transformations =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G +
\<tau>: natural_transformation A B F G \<tau> +
\<tau>': natural_transformation A B G F \<tau>'
for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
and F :: "'a \<Rightarrow> 'b"
and G :: "'a \<Rightarrow> 'b"
and \<tau> :: "'a \<Rightarrow> 'b"
and \<tau>' :: "'a \<Rightarrow> 'b" +
assumes inv: "A.ide a \<Longrightarrow> B.inverse_arrows (\<tau> a) (\<tau>' a)"
sublocale inverse_transformations \<subseteq> natural_isomorphism A B F G \<tau>
by (meson B.category_axioms \<tau>.natural_transformation_axioms B.iso_def inv
natural_isomorphism.intro natural_isomorphism_axioms.intro)
sublocale inverse_transformations \<subseteq> natural_isomorphism A B G F \<tau>'
by (meson category.inverse_arrows_sym category.iso_def inverse_transformations_axioms
inverse_transformations_axioms_def inverse_transformations_def
natural_isomorphism.intro natural_isomorphism_axioms.intro)
lemma inverse_transformations_sym:
assumes "inverse_transformations A B F G \<sigma> \<sigma>'"
shows "inverse_transformations A B G F \<sigma>' \<sigma>"
using assms
by (simp add: category.inverse_arrows_sym inverse_transformations_axioms_def
inverse_transformations_def)
lemma inverse_transformations_inverse:
assumes "inverse_transformations A B F G \<sigma> \<sigma>'"
shows "vertical_composite.map A B \<sigma> \<sigma>' = F"
and "vertical_composite.map A B \<sigma>' \<sigma> = G"
proof -
interpret A: category A
using assms(1) inverse_transformations_def natural_transformation_def by blast
interpret inv: inverse_transformations A B F G \<sigma> \<sigma>' using assms by auto
interpret \<sigma>\<sigma>': vertical_composite A B F G F \<sigma> \<sigma>' ..
show "vertical_composite.map A B \<sigma> \<sigma>' = F"
using \<sigma>\<sigma>'.is_natural_transformation inv.F.natural_transformation_axioms
- apply (intro eqI, simp_all)
- by (auto simp add: \<sigma>\<sigma>'.map_simp_ide inv.B.comp_inv_arr inv.inv)
+ \<sigma>\<sigma>'.map_simp_ide inv.B.comp_inv_arr inv.inv
+ by (intro eqI, simp_all)
interpret inv': inverse_transformations A B G F \<sigma>' \<sigma>
using assms inverse_transformations_sym by blast
interpret \<sigma>'\<sigma>: vertical_composite A B G F G \<sigma>' \<sigma> ..
show "vertical_composite.map A B \<sigma>' \<sigma> = G"
using \<sigma>'\<sigma>.is_natural_transformation inv.G.natural_transformation_axioms
- apply (intro eqI, simp_all)
- by (auto simp add: \<sigma>'\<sigma>.map_simp_ide inv'.inv inv.B.comp_inv_arr)
+ \<sigma>'\<sigma>.map_simp_ide inv'.inv inv.B.comp_inv_arr
+ by (intro eqI, simp_all)
qed
lemma inverse_transformations_compose:
assumes "inverse_transformations A B F G \<sigma> \<sigma>'"
and "inverse_transformations A B G H \<tau> \<tau>'"
- shows "inverse_transformations A B F H (vertical_composite.map A B \<sigma> \<tau>)
- (vertical_composite.map A B \<tau>' \<sigma>')"
+ shows "inverse_transformations A B F H
+ (vertical_composite.map A B \<sigma> \<tau>) (vertical_composite.map A B \<tau>' \<sigma>')"
proof -
interpret A: category A using assms(1) inverse_transformations_def by blast
interpret B: category B using assms(1) inverse_transformations_def by blast
interpret \<sigma>\<sigma>': inverse_transformations A B F G \<sigma> \<sigma>' using assms(1) by auto
interpret \<tau>\<tau>': inverse_transformations A B G H \<tau> \<tau>' using assms(2) by auto
interpret \<sigma>\<tau>: vertical_composite A B F G H \<sigma> \<tau> ..
interpret \<tau>'\<sigma>': vertical_composite A B H G F \<tau>' \<sigma>' ..
show ?thesis
using B.inverse_arrows_compose \<sigma>\<sigma>'.inv \<sigma>\<tau>.map_simp_ide \<tau>'\<sigma>'.map_simp_ide \<tau>\<tau>'.inv
by (unfold_locales, auto)
qed
lemma vertical_composite_iso_inverse [simp]:
assumes "natural_isomorphism A B F G \<tau>"
shows "vertical_composite.map A B \<tau> (inverse_transformation.map A B G \<tau>) = F"
proof -
interpret \<tau>: natural_isomorphism A B F G \<tau> using assms by auto
interpret \<tau>': inverse_transformation A B F G \<tau> ..
interpret \<tau>\<tau>': vertical_composite A B F G F \<tau> \<tau>'.map ..
show ?thesis
using \<tau>\<tau>'.is_natural_transformation \<tau>.F.natural_transformation_axioms \<tau>'.inverts_components
- apply (intro eqI, simp_all)
- by (auto simp add: \<tau>.B.comp_inv_arr \<tau>\<tau>'.map_simp_ide)
+ \<tau>.B.comp_inv_arr \<tau>\<tau>'.map_simp_ide
+ by (intro eqI, auto)
qed
lemma vertical_composite_inverse_iso [simp]:
assumes "natural_isomorphism A B F G \<tau>"
shows "vertical_composite.map A B (inverse_transformation.map A B G \<tau>) \<tau> = G"
proof -
interpret \<tau>: natural_isomorphism A B F G \<tau> using assms by auto
interpret \<tau>': inverse_transformation A B F G \<tau> ..
interpret \<tau>'\<tau>: vertical_composite A B G F G \<tau>'.map \<tau> ..
show ?thesis
using \<tau>'\<tau>.is_natural_transformation \<tau>.G.natural_transformation_axioms \<tau>'.inverts_components
- \<tau>'\<tau>.map_simp_ide
- apply (intro eqI, auto) by fastforce
+ \<tau>'\<tau>.map_simp_ide \<tau>.B.comp_arr_inv
+ by (intro eqI, auto)
qed
lemma natural_isomorphisms_compose:
assumes "natural_isomorphism A B F G \<sigma>" and "natural_isomorphism A B G H \<tau>"
shows "natural_isomorphism A B F H (vertical_composite.map A B \<sigma> \<tau>)"
proof -
interpret A: category A
using assms(1) natural_isomorphism_def natural_transformation_def by blast
interpret B: category B
using assms(1) natural_isomorphism_def natural_transformation_def by blast
interpret \<sigma>: natural_isomorphism A B F G \<sigma> using assms(1) by auto
interpret \<tau>: natural_isomorphism A B G H \<tau> using assms(2) by auto
interpret \<sigma>\<tau>: vertical_composite A B F G H \<sigma> \<tau> ..
interpret natural_isomorphism A B F H \<sigma>\<tau>.map
using \<sigma>\<tau>.map_simp_ide by (unfold_locales, auto)
show ?thesis ..
qed
lemma naturally_isomorphic_reflexive:
assumes "functor A B F"
shows "naturally_isomorphic A B F F"
proof -
interpret F: "functor" A B F using assms by auto
have "natural_isomorphism A B F F F" ..
thus ?thesis using naturally_isomorphic_def by blast
qed
lemma naturally_isomorphic_symmetric:
assumes "naturally_isomorphic A B F G"
shows "naturally_isomorphic A B G F"
proof -
obtain \<phi> where \<phi>: "natural_isomorphism A B F G \<phi>"
using assms naturally_isomorphic_def by blast
interpret \<phi>: natural_isomorphism A B F G \<phi>
using \<phi> by auto
interpret \<psi>: inverse_transformation A B F G \<phi> ..
have "natural_isomorphism A B G F \<psi>.map" ..
thus ?thesis using naturally_isomorphic_def by blast
qed
- lemma naturally_isomorphic_transitive:
+ lemma naturally_isomorphic_transitive [trans]:
assumes "naturally_isomorphic A B F G"
and "naturally_isomorphic A B G H"
shows "naturally_isomorphic A B F H"
proof -
obtain \<phi> where \<phi>: "natural_isomorphism A B F G \<phi>"
using assms naturally_isomorphic_def by blast
interpret \<phi>: natural_isomorphism A B F G \<phi>
using \<phi> by auto
obtain \<psi> where \<psi>: "natural_isomorphism A B G H \<psi>"
using assms naturally_isomorphic_def by blast
interpret \<psi>: natural_isomorphism A B G H \<psi>
using \<psi> by auto
interpret \<psi>\<phi>: vertical_composite A B F G H \<phi> \<psi> ..
have "natural_isomorphism A B F H \<psi>\<phi>.map"
using \<phi> \<psi> natural_isomorphisms_compose by blast
thus ?thesis
using naturally_isomorphic_def by blast
qed
section "Horizontal Composition"
text\<open>
Horizontal composition is a way of composing parallel natural transformations
@{term \<sigma>} from @{term F} to @{term G} and @{term \<tau>} from @{term H} to @{term K},
where functors @{term F} and @{term G} map @{term A} to @{term B} and
@{term H} and @{term K} map @{term B} to @{term C}, to obtain a natural transformation
from @{term "H o F"} to @{term "K o G"}.
+
+ Since horizontal composition turns out to coincide with ordinary composition of
+ natural transformations as functions, there is little point in defining a cumbersome
+ locale for horizontal composite.
\<close>
- locale horizontal_composite =
- A: category A +
- B: category B +
- C: category C +
- F: "functor" A B F +
- G: "functor" A B G +
- H: "functor" B C H +
- K: "functor" B C K +
- \<sigma>: natural_transformation A B F G \<sigma> +
- \<tau>: natural_transformation B C H K \<tau>
- for A :: "'a comp" (infixr "\<cdot>\<^sub>A" 55)
- and B :: "'b comp" (infixr "\<cdot>\<^sub>B" 55)
- and C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
- and F :: "'a \<Rightarrow> 'b"
- and G :: "'a \<Rightarrow> 'b"
- and H :: "'b \<Rightarrow> 'c"
- and K :: "'b \<Rightarrow> 'c"
- and \<sigma> :: "'a \<Rightarrow> 'b"
- and \<tau> :: "'b \<Rightarrow> 'c"
- begin
-
- no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
- notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
-
- abbreviation map
- where "map \<equiv> \<tau> o \<sigma>"
-
- lemma is_natural_transformation:
- shows "natural_transformation A C (H o F) (K o G) map"
- proof -
- interpret HF: composite_functor A B C F H ..
- interpret KG: composite_functor A B C G K ..
- show "natural_transformation A C (H o F) (K o G) (\<tau> o \<sigma>)"
- using \<sigma>.is_extensional \<tau>.is_extensional
- apply (unfold_locales, auto)
- apply (metis \<sigma>.is_natural_1 \<sigma>.preserves_reflects_arr \<tau>.preserves_comp_1)
- by (metis \<sigma>.is_natural_2 \<sigma>.preserves_reflects_arr \<tau>.preserves_comp_2)
- qed
-
- end
-
- sublocale horizontal_composite \<subseteq> natural_transformation A C "H o F" "K o G" "\<tau> o \<sigma>"
- using is_natural_transformation by auto
-
- context horizontal_composite
- begin
-
- interpretation KF: composite_functor A B C F K ..
- interpretation HG: composite_functor A B C G H ..
- interpretation \<tau>F: horizontal_composite A B C F F H K F \<tau> ..
- interpretation \<tau>G: horizontal_composite A B C G G H K G \<tau> ..
- interpretation H\<sigma>: horizontal_composite A B C F G H H \<sigma> H ..
- interpretation K\<sigma>: horizontal_composite A B C F G K K \<sigma> K ..
- interpretation K\<sigma>_\<tau>F: vertical_composite A C "H o F" "K o F" "K o G" "\<tau> o F" "K o \<sigma>" ..
- interpretation \<tau>G_H\<sigma>: vertical_composite A C "H o F" "H o G" "K o G" "H o \<sigma>" "\<tau> o G" ..
-
- lemma map_simp_1:
- assumes "A.arr f"
- shows "(\<tau> o \<sigma>) f = K\<sigma>_\<tau>F.map f"
- using assms
- by (metis K\<sigma>_\<tau>F.map_simp_1 \<sigma>.is_natural_2 \<sigma>.preserves_reflects_arr \<tau>.preserves_comp_1
- comp_apply)
-
- lemma map_simp_2:
- assumes "A.arr f"
- shows "(\<tau> o \<sigma>) f = \<tau>G_H\<sigma>.map f"
- using assms
- by (metis \<sigma>.is_natural_1 \<sigma>.preserves_reflects_arr \<tau>.preserves_comp_2 \<tau>G_H\<sigma>.map_simp_2
- comp_apply)
-
- end
+ lemma horizontal_composite:
+ assumes "natural_transformation A B F G \<sigma>"
+ and "natural_transformation B C H K \<tau>"
+ shows "natural_transformation A C (H o F) (K o G) (\<tau> o \<sigma>)"
+ proof -
+ interpret \<sigma>: natural_transformation A B F G \<sigma>
+ using assms(1) by simp
+ interpret \<tau>: natural_transformation B C H K \<tau>
+ using assms(2) by simp
+ interpret HF: composite_functor A B C F H ..
+ interpret KG: composite_functor A B C G K ..
+ show "natural_transformation A C (H o F) (K o G) (\<tau> o \<sigma>)"
+ using \<sigma>.is_extensional \<tau>.is_extensional
+ apply (unfold_locales, auto)
+ apply (metis \<sigma>.is_natural_1 \<sigma>.preserves_reflects_arr \<tau>.preserves_comp_1)
+ by (metis \<sigma>.is_natural_2 \<sigma>.preserves_reflects_arr \<tau>.preserves_comp_2)
+ qed
lemma hcomp_ide_dom [simp]:
assumes "natural_transformation A B F G \<tau>"
shows "\<tau> o (identity_functor.map A) = \<tau>"
proof -
interpret \<tau>: natural_transformation A B F G \<tau> using assms by auto
show "\<tau> o \<tau>.A.map = \<tau>"
using \<tau>.A.map_def \<tau>.is_extensional by fastforce
qed
lemma hcomp_ide_cod [simp]:
assumes "natural_transformation A B F G \<tau>"
shows "(identity_functor.map B) o \<tau> = \<tau>"
proof -
interpret \<tau>: natural_transformation A B F G \<tau> using assms by auto
show "\<tau>.B.map o \<tau> = \<tau>"
using \<tau>.B.map_def \<tau>.is_extensional by auto
qed
text\<open>
Horizontal composition of a functor with a vertical composite.
\<close>
- lemma hcomp_functor_vcomp:
+ lemma whisker_right:
assumes "functor A B F"
- and "natural_transformation B C H K \<tau>"
- and "natural_transformation B C K L \<tau>'"
+ and "natural_transformation B C H K \<tau>" and "natural_transformation B C K L \<tau>'"
shows "(vertical_composite.map B C \<tau> \<tau>') o F = vertical_composite.map A C (\<tau> o F) (\<tau>' o F)"
proof -
interpret F: "functor" A B F using assms(1) by auto
interpret \<tau>: natural_transformation B C H K \<tau> using assms(2) by auto
interpret \<tau>': natural_transformation B C K L \<tau>' using assms(3) by auto
- interpret HF: composite_functor A B C F H ..
- interpret KF: composite_functor A B C F K ..
- interpret LF: composite_functor A B C F L ..
- interpret \<tau>F: horizontal_composite A B C F F H K F \<tau> ..
- interpret \<tau>'F: horizontal_composite A B C F F K L F \<tau>' ..
- interpret \<tau>'o\<tau>: vertical_composite B C H K L \<tau> \<tau>' ..
- interpret \<tau>'o\<tau>_F: horizontal_composite A B C F F H L F \<tau>'o\<tau>.map ..
- interpret \<tau>'Fo\<tau>F: vertical_composite A C "H o F" "K o F" "L o F" "\<tau> o F" "\<tau>' o F" ..
+ interpret \<tau>oF: natural_transformation A C \<open>H o F\<close> \<open>K o F\<close> \<open>\<tau> o F\<close>
+ using \<tau>.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret \<tau>'oF: natural_transformation A C \<open>K o F\<close> \<open>L o F\<close> \<open>\<tau>' o F\<close>
+ using \<tau>'.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret \<tau>'\<tau>: vertical_composite B C H K L \<tau> \<tau>' ..
+ interpret \<tau>'\<tau>oF: natural_transformation A C \<open>H o F\<close> \<open>L o F\<close> \<open>\<tau>'\<tau>.map o F\<close>
+ using \<tau>'\<tau>.natural_transformation_axioms F.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret \<tau>'oF_\<tau>oF: vertical_composite A C \<open>H o F\<close> \<open>K o F\<close> \<open>L o F\<close> \<open>\<tau> o F\<close> \<open>\<tau>' o F\<close> ..
show ?thesis
- using \<tau>'Fo\<tau>F.map_def \<tau>'o\<tau>.map_def \<tau>'o\<tau>_F.is_extensional by auto
+ using \<tau>'oF_\<tau>oF.map_def \<tau>'\<tau>.map_def \<tau>'\<tau>oF.is_extensional by auto
qed
text\<open>
Horizontal composition of a vertical composite with a functor.
\<close>
- lemma hcomp_vcomp_functor:
+ lemma whisker_left:
assumes "functor B C K"
- and "natural_transformation A B F G \<tau>"
- and "natural_transformation A B G H \<tau>'"
+ and "natural_transformation A B F G \<tau>" and "natural_transformation A B G H \<tau>'"
shows "K o (vertical_composite.map A B \<tau> \<tau>') = vertical_composite.map A C (K o \<tau>) (K o \<tau>')"
proof -
interpret K: "functor" B C K using assms(1) by auto
interpret \<tau>: natural_transformation A B F G \<tau> using assms(2) by auto
interpret \<tau>': natural_transformation A B G H \<tau>' using assms(3) by auto
- interpret KF: composite_functor A B C F K ..
- interpret KG: composite_functor A B C G K ..
- interpret KH: composite_functor A B C H K ..
- interpret \<tau>'o\<tau>: vertical_composite A B F G H \<tau> \<tau>' ..
- interpret K\<tau>: horizontal_composite A B C F G K K \<tau> K ..
- interpret K\<tau>': horizontal_composite A B C G H K K \<tau>' K ..
- interpret K_\<tau>'o\<tau>: horizontal_composite A B C F H K K \<tau>'o\<tau>.map K ..
- interpret K\<tau>'oK\<tau>: vertical_composite A C "K o F" "K o G" "K o H" "K o \<tau>" "K o \<tau>'" ..
- show "K o \<tau>'o\<tau>.map = K\<tau>'oK\<tau>.map"
- using K\<tau>'oK\<tau>.map_def \<tau>'o\<tau>.map_def K_\<tau>'o\<tau>.is_extensional K\<tau>'oK\<tau>.map_simp_1 \<tau>'o\<tau>.map_simp_1
+ interpret \<tau>'\<tau>: vertical_composite A B F G H \<tau> \<tau>' ..
+ interpret Ko\<tau>: natural_transformation A C \<open>K o F\<close> \<open>K o G\<close> \<open>K o \<tau>\<close>
+ using \<tau>.natural_transformation_axioms K.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret Ko\<tau>': natural_transformation A C \<open>K o G\<close> \<open>K o H\<close> \<open>K o \<tau>'\<close>
+ using \<tau>'.natural_transformation_axioms K.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret Ko\<tau>'\<tau>: natural_transformation A C \<open>K o F\<close> \<open>K o H\<close> \<open>K o \<tau>'\<tau>.map\<close>
+ using \<tau>'\<tau>.natural_transformation_axioms K.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret Ko\<tau>'_Ko\<tau>: vertical_composite A C \<open>K o F\<close> \<open>K o G\<close> \<open>K o H\<close> \<open>K o \<tau>\<close> \<open>K o \<tau>'\<close> ..
+ show "K o \<tau>'\<tau>.map = Ko\<tau>'_Ko\<tau>.map"
+ using Ko\<tau>'_Ko\<tau>.map_def \<tau>'\<tau>.map_def Ko\<tau>'\<tau>.is_extensional Ko\<tau>'_Ko\<tau>.map_simp_1 \<tau>'\<tau>.map_simp_1
by auto
qed
text\<open>
The interchange law for horizontal and vertical composition.
\<close>
lemma interchange:
+ assumes "natural_transformation B C F G \<tau>" and "natural_transformation B C G H \<nu>"
+ and "natural_transformation C D K L \<sigma>" and "natural_transformation C D L M \<mu>"
+ shows "vertical_composite.map C D \<sigma> \<mu> \<circ> vertical_composite.map B C \<tau> \<nu> =
+ vertical_composite.map B D (\<sigma> \<circ> \<tau>) (\<mu> \<circ> \<nu>)"
+ proof -
+ interpret \<tau>: natural_transformation B C F G \<tau>
+ using assms(1) by auto
+ interpret \<nu>: natural_transformation B C G H \<nu>
+ using assms(2) by auto
+ interpret \<sigma>: natural_transformation C D K L \<sigma>
+ using assms(3) by auto
+ interpret \<mu>: natural_transformation C D L M \<mu>
+ using assms(4) by auto
+ interpret \<nu>\<tau>: vertical_composite B C F G H \<tau> \<nu> ..
+ interpret \<mu>\<sigma>: vertical_composite C D K L M \<sigma> \<mu> ..
+ interpret \<sigma>o\<tau>: natural_transformation B D \<open>K o F\<close> \<open>L o G\<close> \<open>\<sigma> o \<tau>\<close>
+ using \<sigma>.natural_transformation_axioms \<tau>.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret \<mu>o\<nu>: natural_transformation B D \<open>L o G\<close> \<open>M o H\<close> \<open>\<mu> o \<nu>\<close>
+ using \<mu>.natural_transformation_axioms \<nu>.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret \<mu>\<sigma>o\<nu>\<tau>: natural_transformation B D \<open>K o F\<close> \<open>M o H\<close> \<open>\<mu>\<sigma>.map o \<nu>\<tau>.map\<close>
+ using \<mu>\<sigma>.natural_transformation_axioms \<nu>\<tau>.natural_transformation_axioms
+ horizontal_composite
+ by blast
+ interpret \<mu>o\<nu>_\<sigma>o\<tau>: vertical_composite B D \<open>K o F\<close> \<open>L o G\<close> \<open>M o H\<close> \<open>\<sigma> o \<tau>\<close> \<open>\<mu> o \<nu>\<close> ..
+ show "\<mu>\<sigma>.map o \<nu>\<tau>.map = \<mu>o\<nu>_\<sigma>o\<tau>.map"
+ proof (intro eqI)
+ show "natural_transformation B D (K \<circ> F) (M \<circ> H) (\<mu>\<sigma>.map o \<nu>\<tau>.map)" ..
+ show "natural_transformation B D (K \<circ> F) (M \<circ> H) \<mu>o\<nu>_\<sigma>o\<tau>.map" ..
+ show "\<And>a. \<tau>.A.ide a \<Longrightarrow> (\<mu>\<sigma>.map o \<nu>\<tau>.map) a = \<mu>o\<nu>_\<sigma>o\<tau>.map a"
+ proof -
+ fix a
+ assume a: "\<tau>.A.ide a"
+ have "(\<mu>\<sigma>.map o \<nu>\<tau>.map) a = D (\<mu> (H a)) (\<sigma> (C (\<nu> a) (\<tau> a)))"
+ using a \<mu>\<sigma>.map_simp_1 \<nu>\<tau>.map_simp_2 by simp
+ also have "... = D (\<mu> (\<nu> a)) (\<sigma> (\<tau> a))"
+ using a
+ by (metis (full_types) \<mu>.is_natural_1 \<mu>\<sigma>.map_simp_1 \<mu>\<sigma>.preserves_comp_1
+ \<nu>\<tau>.map_seq \<nu>\<tau>.map_simp_1 \<nu>\<tau>.preserves_cod \<sigma>.B.comp_assoc \<tau>.A.ide_char \<tau>.B.seqE)
+ also have "... = \<mu>o\<nu>_\<sigma>o\<tau>.map a"
+ using a \<mu>o\<nu>_\<sigma>o\<tau>.map_simp_ide by simp
+ finally show "(\<mu>\<sigma>.map o \<nu>\<tau>.map) a = \<mu>o\<nu>_\<sigma>o\<tau>.map a" by blast
+ qed
+ qed
+ qed
+
+ text\<open>
+ A special-case of the interchange law in which two of the natural transformations
+ are functors. It comes up reasonably often, and the reasoning is awkward.
+\<close>
+
+ lemma interchange_spc:
assumes "natural_transformation B C F G \<sigma>"
and "natural_transformation C D H K \<tau>"
- shows "horizontal_composite.map \<sigma> \<tau> = vertical_composite.map B D (H o \<sigma>) (\<tau> o G)"
- and "horizontal_composite.map \<sigma> \<tau> = vertical_composite.map B D (\<tau> o F) (K o \<sigma>)"
+ shows "\<tau> \<circ> \<sigma> = vertical_composite.map B D (H o \<sigma>) (\<tau> o G)"
+ and "\<tau> \<circ> \<sigma> = vertical_composite.map B D (\<tau> o F) (K o \<sigma>)"
proof -
- interpret \<sigma>: natural_transformation B C F G \<sigma>
- using assms(1) by auto
- interpret \<tau>: natural_transformation C D H K \<tau>
- using assms(2) by auto
- interpret \<tau>\<sigma>: horizontal_composite B C D F G H K \<sigma> \<tau> ..
- interpret H\<sigma>: horizontal_composite B C D F G H H \<sigma> H ..
- interpret K\<sigma>: horizontal_composite B C D F G K K \<sigma> K ..
- interpret \<tau>G: horizontal_composite B C D G G H K G \<tau> ..
- interpret \<tau>F: horizontal_composite B C D F F H K F \<tau> ..
- interpret \<tau>GoH\<sigma>: vertical_composite B D "H o F" "H o G" "K o G" "H o \<sigma>" "\<tau> o G" ..
- interpret K\<sigma>o\<tau>F: vertical_composite B D "H o F" "K o F" "K o G" "\<tau> o F" "K o \<sigma>" ..
- show "\<tau>\<sigma>.map = \<tau>GoH\<sigma>.map"
- using \<tau>\<sigma>.map_simp_2 \<tau>\<sigma>.natural_transformation_axioms \<tau>GoH\<sigma>.natural_transformation_axioms
- by (intro eqI, auto)
- show "\<tau>\<sigma>.map = K\<sigma>o\<tau>F.map"
- using \<tau>\<sigma>.map_simp_1 \<tau>\<sigma>.natural_transformation_axioms K\<sigma>o\<tau>F.natural_transformation_axioms
- by (intro eqI, auto)
+ show "\<tau> \<circ> \<sigma> = vertical_composite.map B D (H \<circ> \<sigma>) (\<tau> \<circ> G)"
+ proof -
+ have "vertical_composite.map C D H \<tau> \<circ> vertical_composite.map B C \<sigma> G =
+ vertical_composite.map B D (H \<circ> \<sigma>) (\<tau> \<circ> G)"
+ by (meson assms functor_is_transformation interchange natural_transformation.axioms(3-4))
+ thus ?thesis
+ using assms by force
+ qed
+ show "\<tau> \<circ> \<sigma> = vertical_composite.map B D (\<tau> \<circ> F) (K \<circ> \<sigma>)"
+ proof -
+ have "vertical_composite.map C D \<tau> K \<circ> vertical_composite.map B C F \<sigma> =
+ vertical_composite.map B D (\<tau> \<circ> F) (K \<circ> \<sigma>)"
+ by (meson assms functor_is_transformation interchange natural_transformation.axioms(3-4))
+ thus ?thesis
+ using assms by force
+ qed
qed
end
diff --git a/thys/Category3/ProductCategory.thy b/thys/Category3/ProductCategory.thy
--- a/thys/Category3/ProductCategory.thy
+++ b/thys/Category3/ProductCategory.thy
@@ -1,310 +1,310 @@
(* Title: ProductCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter ProductCategory
theory ProductCategory
imports Category EpiMonoIso
begin
text\<open>
This theory defines the product of two categories @{term C1} and @{term C2},
which is the category @{term C} whose arrows are ordered pairs consisting of an
arrow of @{term C1} and an arrow of @{term C2}, with composition defined
componentwise. As the ordered pair \<open>(C1.null, C2.null)\<close> is available
to serve as \<open>C.null\<close>, we may directly identify the arrows of the product
category @{term C} with ordered pairs, leaving the type of arrows of @{term C}
transparent.
\<close>
- type_synonym ('a1, 'a2) arr = "'a1 * 'a2"
-
locale product_category =
C1: category C1 +
C2: category C2
for C1 :: "'a1 comp" (infixr "\<cdot>\<^sub>1" 55)
and C2 :: "'a2 comp" (infixr "\<cdot>\<^sub>2" 55)
begin
+ type_synonym ('aa1, 'aa2) arr = "'aa1 * 'aa2"
+
notation C1.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>1 _\<guillemotright>")
notation C2.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>2 _\<guillemotright>")
abbreviation (input) Null :: "('a1, 'a2) arr"
where "Null \<equiv> (C1.null, C2.null)"
abbreviation (input) Arr :: "('a1, 'a2) arr \<Rightarrow> bool"
where "Arr f \<equiv> C1.arr (fst f) \<and> C2.arr (snd f)"
abbreviation (input) Ide :: "('a1, 'a2) arr \<Rightarrow> bool"
where "Ide f \<equiv> C1.ide (fst f) \<and> C2.ide (snd f)"
abbreviation (input) Dom :: "('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr"
where "Dom f \<equiv> (if Arr f then (C1.dom (fst f), C2.dom (snd f)) else Null)"
abbreviation (input) Cod :: "('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr"
where "Cod f \<equiv> (if Arr f then (C1.cod (fst f), C2.cod (snd f)) else Null)"
definition comp :: "('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr"
where "comp g f = (if Arr f \<and> Arr g \<and> Cod f = Dom g then
(C1 (fst g) (fst f), C2 (snd g) (snd f))
else Null)"
notation comp (infixr "\<cdot>" 55)
lemma not_Arr_Null:
shows "\<not>Arr Null"
by simp
interpretation partial_magma comp
proof
show "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
proof
let ?P = "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
show 1: "?P Null" using comp_def not_Arr_Null by metis
thus "\<And>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n \<Longrightarrow> n = Null" by metis
qed
qed
notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
lemma null_char [simp]:
shows "null = Null"
proof -
let ?P = "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
have "?P Null" using comp_def not_Arr_Null by metis
thus ?thesis
unfolding null_def using the1_equality [of ?P Null] ex_un_null by blast
qed
lemma ide_Ide:
assumes "Ide a"
shows "ide a"
unfolding ide_def comp_def null_char
using assms C1.not_arr_null C1.ide_in_hom C1.comp_arr_dom C1.comp_cod_arr
C2.comp_arr_dom C2.comp_cod_arr
by auto
lemma has_domain_char:
shows "domains f \<noteq> {} \<longleftrightarrow> Arr f"
proof
show "domains f \<noteq> {} \<Longrightarrow> Arr f"
unfolding domains_def comp_def null_char by (auto; metis)
assume f: "Arr f"
show "domains f \<noteq> {}"
proof -
have "ide (Dom f) \<and> comp f (Dom f) \<noteq> null"
using f comp_def ide_Ide C1.comp_arr_dom C1.arr_dom_iff_arr C2.arr_dom_iff_arr
by auto
thus ?thesis using domains_def by blast
qed
qed
lemma has_codomain_char:
shows "codomains f \<noteq> {} \<longleftrightarrow> Arr f"
proof
show "codomains f \<noteq> {} \<Longrightarrow> Arr f"
unfolding codomains_def comp_def null_char by (auto; metis)
assume f: "Arr f"
show "codomains f \<noteq> {}"
proof -
have "ide (Cod f) \<and> comp (Cod f) f \<noteq> null"
using f comp_def ide_Ide C1.comp_cod_arr C1.arr_cod_iff_arr C2.arr_cod_iff_arr
by auto
thus ?thesis using codomains_def by blast
qed
qed
lemma arr_char [iff]:
shows "arr f \<longleftrightarrow> Arr f"
using has_domain_char has_codomain_char arr_def by simp
lemma arrI [intro]:
assumes "C1.arr f1" and "C2.arr f2"
shows "arr (f1, f2)"
using assms by simp
lemma arrE:
assumes "arr f"
and "C1.arr (fst f) \<and> C2.arr (snd f) \<Longrightarrow> T"
shows "T"
using assms by auto
lemma seqI [intro]:
assumes "C1.seq g1 f1 \<and> C2.seq g2 f2"
shows "seq (g1, g2) (f1, f2)"
using assms comp_def by auto
lemma seqE [elim]:
assumes "seq g f"
and "C1.seq (fst g) (fst f) \<Longrightarrow> C2.seq (snd g) (snd f) \<Longrightarrow> T"
shows "T"
using assms comp_def
by (metis (no_types, lifting) C1.seqI C2.seqI Pair_inject not_arr_null null_char)
lemma seq_char [iff]:
shows "seq g f \<longleftrightarrow> C1.seq (fst g) (fst f) \<and> C2.seq (snd g) (snd f)"
using comp_def by auto
lemma Dom_comp:
assumes "seq g f"
shows "Dom (g \<cdot> f) = Dom f"
using assms comp_def
apply (cases "C1.arr (fst g)"; cases "C1.arr (fst f)";
cases "C2.arr (snd f)"; cases "C2.arr (snd g)"; simp_all)
by auto
lemma Cod_comp:
assumes "seq g f"
shows "Cod (g \<cdot> f) = Cod g"
using assms comp_def
apply (cases "C1.arr (fst f)"; cases "C2.arr (snd f)";
cases "C1.arr (fst g)"; cases "C2.arr (snd g)"; simp_all)
by auto
theorem is_category:
shows "category comp"
proof
fix f
show "(domains f \<noteq> {}) = (codomains f \<noteq> {})"
using has_domain_char has_codomain_char by simp
fix g
show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
using comp_def seq_char by (metis C1.seqI C2.seqI Pair_inject null_char)
fix h
show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
using comp_def null_char seq_char by (elim seqE C1.seqE C2.seqE, simp)
show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
using comp_def null_char seq_char by (elim seqE C1.seqE C2.seqE, simp)
show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
using comp_def null_char seq_char by (elim seqE C1.seqE C2.seqE, simp)
show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
- using comp_def null_char seq_char C1.comp_assoc C2.comp_assoc comp_assoc
+ using comp_def null_char seq_char C1.comp_assoc C2.comp_assoc
by (elim seqE C1.seqE C2.seqE, simp)
qed
end
sublocale product_category \<subseteq> category comp
using is_category comp_def by auto
context product_category
begin
lemma dom_char:
shows "dom f = Dom f"
proof (cases "Arr f")
show "\<not>Arr f \<Longrightarrow> dom f = Dom f"
unfolding dom_def using has_domain_char by auto
show "Arr f \<Longrightarrow> dom f = Dom f"
using ide_Ide apply (intro dom_eqI, simp)
using seq_char comp_def C1.arr_dom_iff_arr C2.arr_dom_iff_arr by auto
qed
lemma dom_simp [simp]:
assumes "arr f"
shows "dom f = (C1.dom (fst f), C2.dom (snd f))"
using assms dom_char by auto
lemma cod_char:
shows "cod f = Cod f"
proof (cases "Arr f")
show "\<not>Arr f \<Longrightarrow> cod f = Cod f"
unfolding cod_def using has_codomain_char by auto
show "Arr f \<Longrightarrow> cod f = Cod f"
using ide_Ide seqI apply (intro cod_eqI, simp)
using seq_char comp_def C1.arr_cod_iff_arr C2.arr_cod_iff_arr by auto
qed
lemma cod_simp [simp]:
assumes "arr f"
shows "cod f = (C1.cod (fst f), C2.cod (snd f))"
using assms cod_char by auto
lemma in_homI [intro, simp]:
assumes "\<guillemotleft>fst f: fst a \<rightarrow>\<^sub>1 fst b\<guillemotright>" and "\<guillemotleft>snd f: snd a \<rightarrow>\<^sub>2 snd b\<guillemotright>"
shows "\<guillemotleft>f: a \<rightarrow> b\<guillemotright>"
using assms by fastforce
lemma in_homE [elim]:
assumes "\<guillemotleft>f: a \<rightarrow> b\<guillemotright>"
and "\<guillemotleft>fst f: fst a \<rightarrow>\<^sub>1 fst b\<guillemotright> \<Longrightarrow> \<guillemotleft>snd f: snd a \<rightarrow>\<^sub>2 snd b\<guillemotright> \<Longrightarrow> T"
shows "T"
using assms
by (metis C1.in_homI C2.in_homI arr_char cod_simp dom_simp fst_conv in_homE snd_conv)
lemma ide_char [iff]:
shows "ide f \<longleftrightarrow> Ide f"
using ide_in_hom C1.ide_in_hom C2.ide_in_hom by blast
lemma comp_char:
shows "g \<cdot> f = (if C1.arr (C1 (fst g) (fst f)) \<and> C2.arr (C2 (snd g) (snd f)) then
(C1 (fst g) (fst f), C2 (snd g) (snd f))
else Null)"
using comp_def by auto
lemma comp_simp [simp]:
assumes "C1.seq (fst g) (fst f)" and "C2.seq (snd g) (snd f)"
shows "g \<cdot> f = (fst g \<cdot>\<^sub>1 fst f, snd g \<cdot>\<^sub>2 snd f)"
using assms comp_char by simp
lemma iso_char [iff]:
shows "iso f \<longleftrightarrow> C1.iso (fst f) \<and> C2.iso (snd f)"
proof
assume f: "iso f"
obtain g where g: "inverse_arrows f g" using f by auto
have 1: "ide (g \<cdot> f) \<and> ide (f \<cdot> g)"
using f g by (simp add: inverse_arrows_def)
have "g \<cdot> f = (fst g \<cdot>\<^sub>1 fst f, snd g \<cdot>\<^sub>2 snd f) \<and> f \<cdot> g = (fst f \<cdot>\<^sub>1 fst g, snd f \<cdot>\<^sub>2 snd g)"
using 1 comp_char arr_char by (meson ideD(1) seq_char)
hence "C1.ide (fst g \<cdot>\<^sub>1 fst f) \<and> C2.ide (snd g \<cdot>\<^sub>2 snd f) \<and>
C1.ide (fst f \<cdot>\<^sub>1 fst g) \<and> C2.ide (snd f \<cdot>\<^sub>2 snd g)"
using 1 ide_char by simp
hence "C1.inverse_arrows (fst f) (fst g) \<and> C2.inverse_arrows (snd f) (snd g)"
by auto
thus "C1.iso (fst f) \<and> C2.iso (snd f)" by auto
next
assume f: "C1.iso (fst f) \<and> C2.iso (snd f)"
obtain g1 where g1: "C1.inverse_arrows (fst f) g1" using f by blast
obtain g2 where g2: "C2.inverse_arrows (snd f) g2" using f by blast
have "C1.ide (g1 \<cdot>\<^sub>1 fst f) \<and> C2.ide (g2 \<cdot>\<^sub>2 snd f) \<and>
C1.ide (fst f \<cdot>\<^sub>1 g1) \<and> C2.ide (snd f \<cdot>\<^sub>2 g2)"
using g1 g2 ide_char by force
hence "inverse_arrows f (g1, g2)"
using f g1 g2 ide_char comp_char by (intro inverse_arrowsI, auto)
thus "iso f" by auto
qed
lemma isoI [intro, simp]:
assumes "C1.iso (fst f)" and "C2.iso (snd f)"
shows "iso f"
using assms by simp
lemma isoD:
assumes "iso f"
shows "C1.iso (fst f)" and "C2.iso (snd f)"
using assms by auto
lemma inv_simp [simp]:
assumes "iso f"
shows "inv f = (C1.inv (fst f), C2.inv (snd f))"
proof -
have "inverse_arrows f (C1.inv (fst f), C2.inv (snd f))"
proof
have 1: "C1.inverse_arrows (fst f) (C1.inv (fst f))"
using assms iso_char C1.inv_is_inverse by simp
have 2: "C2.inverse_arrows (snd f) (C2.inv (snd f))"
using assms iso_char C2.inv_is_inverse by simp
show "ide ((C1.inv (fst f), C2.inv (snd f)) \<cdot> f)"
using 1 2 ide_char comp_char by auto
show "ide (f \<cdot> (C1.inv (fst f), C2.inv (snd f)))"
using 1 2 ide_char comp_char by auto
qed
thus ?thesis using inverse_unique by auto
qed
end
end
diff --git a/thys/Category3/SetCat.thy b/thys/Category3/SetCat.thy
--- a/thys/Category3/SetCat.thy
+++ b/thys/Category3/SetCat.thy
@@ -1,999 +1,728 @@
(* Title: SetCat
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter SetCat
theory SetCat
-imports SetCategory AbstractedCategory
+imports SetCategory ConcreteCategory
begin
text\<open>
This theory proves the consistency of the \<open>set_category\<close> locale by giving
- a particular concrete construction of an interpretation for it. Although the
- construction used here is probably the first one that would come to mind
- (arrows are defined as triples @{term "(F, (A, B))"} where @{term A} and @{term B}
- are sets and @{term F} is an extensional function from @{term A} to @{term B}),
- there is nothing particularly unique or special about it.
- Because of this, we don't want clients of this theory to have implicit dependencies
- on the specific details of the construction we use. We therefore go to some
- trouble to hide these details behind an opaque arrow type and export only the
- definitions and facts that are made explicit in the \<open>set_category\<close> locale.
-\<close>
-
- text\<open>
- We first define a locale \<open>setcat\<close> that gives the details of the particular
- construction of ``the category of @{typ 'a}-sets and functions between them''.
- We use a locale so that we can later interpret it once in a local context,
- prove the main fact, which is that we thereby obtain an interpretation of the
- \<open>set_category\<close> locale, and leave no other permanent vestiges of it
- in this theory.
+ a particular concrete construction of an interpretation for it.
+ Applying the general construction given by @{locale concrete_category},
+ we define arrows to be terms \<open>MkArr A B F\<close>, where \<open>A\<close> and \<open>B\<close> are sets
+ and \<open>F\<close> is an extensional function that maps \<open>A\<close> to \<open>B\<close>.
\<close>
locale setcat
begin
- text\<open>
- We represent an arrow as a tuple @{term "(F, (A, B))"}, where @{term A} and
- @{term B} are @{typ 'a}-sets and @{term "(F :: 'a \<Rightarrow> 'a) \<in> extensional A \<inter> (A \<rightarrow> B)"}.
- Since in HOL every type is inhabited, we can avoid using option types here
- by letting @{term "(\<lambda>x. x, ({undefined}, {}))"} serve as the null element of
- the arrow type. This term can never denote an arrow, because the set
- @{term "{undefined} \<rightarrow> {}"} is empty at any type.
-\<close>
-
- type_synonym 'a arr = "('a \<Rightarrow> 'a) * 'a set * 'a set"
-
- abbreviation Null :: "'a arr"
- where "Null \<equiv> (\<lambda>x. x, ({undefined}, {}))"
-
- abbreviation MkArr :: "'a set => 'a set => ('a \<Rightarrow> 'a) \<Rightarrow> 'a arr"
- where "MkArr A B F \<equiv> (restrict F A, (A, B))"
-
- abbreviation Dom :: "'a arr \<Rightarrow> 'a set"
- where "Dom f \<equiv> fst (snd f)"
-
- abbreviation Cod :: "'a arr \<Rightarrow> 'a set"
- where "Cod f \<equiv> snd (snd f)"
-
- abbreviation Fun :: "'a arr \<Rightarrow> 'a \<Rightarrow> 'a"
- where "Fun f \<equiv> fst f"
-
- definition Id :: "'a set \<Rightarrow> 'a arr"
- where "Id A \<equiv> (\<lambda>x \<in> A. x, (A, A))"
-
- (*
- * I attempted to use here the notion A \<rightarrow>\<^sub>E B ("extensional_funcset") defined
- * in FuncSet, but it seems that the rules provided for reasoning directly about
- * it are somewhat weak. So for the moment I am just using the following
- * longer definition, which caused me less trouble.
- *)
- definition Arr :: "'a arr \<Rightarrow> bool"
- where "Arr f \<equiv> Fun f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
-
- (*
- * Similarly, it is not clear that there is much to be gained from using
- * "FuncSet.compose A G F" rather than the more basic "restrict (G o F) A".
- * However, the differences were not that significant, so I went with the
- * former.
- *)
- definition comp :: "'a arr \<Rightarrow> 'a arr \<Rightarrow> 'a arr" (infixr "\<cdot>" 55)
- where "g \<cdot> f = (if Arr f \<and> Arr g \<and> Cod f = Dom g then
- (compose (Dom f) (Fun g) (Fun f), (Dom f, Cod g))
- else Null)"
-
- text\<open>
- Our first objective is to develop just enough properties of the preceding
- definitions to show that they yield a category.
-\<close>
-
- lemma Arr_Id:
- shows "Arr (Id A)"
- unfolding Id_def Arr_def by force
-
- lemma Dom_Id:
- shows "Dom (Id A) = A"
- by (simp add: Id_def)
-
- lemma Cod_Id:
- shows "Cod (Id A) = A"
- by (simp add: Id_def)
-
- lemma comp_Id_Dom:
- assumes "Arr f"
- shows "f \<cdot> Id (Dom f) = f"
- proof -
- have "\<And>F A. F \<in> extensional A \<Longrightarrow> compose A F (\<lambda>x \<in> A. x) = F"
- using compose_extensional extensional_arb by fastforce
- thus ?thesis
- using assms Arr_Id Id_def comp_def
- by (metis (no_types, lifting) Arr_def Cod_Id Dom_Id IntD1 prod.collapse prod.sel(1))
- qed
+ type_synonym 'aa arr = "('aa set, 'aa \<Rightarrow> 'aa) concrete_category.arr"
- lemma comp_Cod_Id:
- assumes "Arr f"
- shows "Id (Cod f) \<cdot> f = f"
- proof -
- have 1: "Fun f \<in> Dom f \<rightarrow> Cod f"
- by (metis (no_types) Arr_def IntD2 assms)
- have 2: "Fun (Id (Cod f)) = (\<lambda>x \<in> Cod f. x) \<and> snd (Id (Cod f)) = (Cod f, Cod f)"
- by (simp add: Id_def)
- hence "compose (Dom f) (Fun (Id (Cod f))) (Fun f) = Fun f"
- using 1 by (metis (no_types) Arr_def Id_compose IntD1 assms)
- then show ?thesis
- using 2 by (simp add: Arr_Id assms comp_def)
- qed
-
- lemma Arr_comp:
- assumes "Arr f" and "Arr g" and "Cod f = Dom g"
- shows "Arr (g \<cdot> f)"
- proof -
- have "\<forall>x. x \<in> Dom g \<longrightarrow> Fun g x \<in> Cod g"
- using assms(2) Arr_def by fast
- moreover have "\<forall>x. x \<in> Dom f \<longrightarrow> Fun f x \<in> Cod f"
- using assms(1) Arr_def by fast
- moreover have "g \<cdot> f = (compose (Dom f) (Fun g) (Fun f), Dom f, Cod g)"
- by (simp add: assms(1-3) comp_def)
- ultimately show ?thesis by (simp add: Arr_def assms(3))
- qed
-
- lemma not_Arr_Null:
- shows "\<not>Arr Null"
- by (simp add: Arr_def)
-
- interpretation partial_magma comp
- proof
- show "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
- proof
- let ?P = "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
- show 1: "?P Null" using comp_def not_Arr_Null by metis
- thus "\<And>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n \<Longrightarrow> n = Null" by metis
- qed
- qed
-
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
-
- lemma null_char:
- shows "null = Null"
- using comp_def not_Arr_Null ex_un_null by (metis comp_null(2))
+ interpretation concrete_category \<open>UNIV :: 'a set set\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
+ \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
+ using compose_Id Id_compose
+ apply unfold_locales
+ apply auto[3]
+ apply blast
+ by (metis IntD2 compose_assoc)
- lemma ide_Id:
- shows "ide (Id A)"
- proof -
- have "Id A \<cdot> Id A = Id A"
- unfolding comp_def apply (auto simp add: Arr_Id Dom_Id Cod_Id)
- unfolding Id_def by auto
- moreover have "\<And>f. f \<cdot> Id A \<noteq> null \<Longrightarrow> f \<cdot> Id A = f"
- by (metis Cod_Id comp_Id_Dom comp_def null_char)
- moreover have "\<And>f. Id A \<cdot> f \<noteq> null \<Longrightarrow> Id A \<cdot> f = f"
- by (metis Dom_Id comp_Cod_Id comp_def null_char)
- ultimately show ?thesis
- unfolding ide_def
- using null_char not_Arr_Null Arr_Id by metis
- qed
+ abbreviation Comp (infixr "\<cdot>" 55)
+ where "Comp \<equiv> COMP"
+ notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
- lemma has_domain_char:
- shows "Arr f \<Longrightarrow> Id (Dom f) \<in> domains f"
- and "domains f \<noteq> {} \<Longrightarrow> Arr f"
- proof -
- assume f: "domains f \<noteq> {}"
- obtain x where x: "x \<in> domains f"
- using f by blast
- have "f \<cdot> x \<noteq> null"
- using x by (simp add: domains_def)
- thus "Arr f"
- using comp_def null_char by metis
- next
- assume f: "Arr f"
- have "f \<noteq> null"
- by (metis f not_Arr_Null null_char)
- hence "Id (Dom f) \<in> {p. ide p \<and> comp f p \<noteq> null}"
- by (simp add: f comp_Id_Dom ide_Id)
- thus "Id (Dom f) \<in> domains f"
- using domains_def by blast
- qed
-
- lemma has_codomain_char:
- shows "Arr f \<Longrightarrow> Id (Cod f) \<in> codomains f"
- and "codomains f \<noteq> {} \<Longrightarrow> Arr f"
- proof -
- assume f: "codomains f \<noteq> {}"
- obtain x where x: "x \<in> codomains f"
- using f by blast
- have "x \<cdot> f \<noteq> null"
- using x by (simp add: codomains_def)
- thus "Arr f"
- using comp_def null_char by metis
- next
- assume f: "Arr f"
- have "f \<noteq> null"
- by (metis f not_Arr_Null null_char)
- hence "Id (Cod f) \<in> {p. ide p \<and> comp p f \<noteq> null}"
- by (simp add: f comp_Cod_Id ide_Id)
- thus "Id (Cod f) \<in> codomains f"
- using codomains_def by blast
+ lemma MkArr_expansion:
+ assumes "arr f"
+ shows "f = MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x)"
+ proof (intro arr_eqI)
+ show "arr f" by fact
+ show "arr (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
+ using assms arr_char
+ by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
+ show "Dom f = Dom (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
+ by simp
+ show "Cod f = Cod (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
+ by simp
+ show "Map f = Map (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
+ using assms arr_char
+ by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
qed
lemma arr_char:
- shows "arr f \<longleftrightarrow> Arr f"
- using has_domain_char has_codomain_char arr_def by blast
-
- lemma comp_assoc:
- assumes "g \<cdot> f \<noteq> null" and "h \<cdot> g \<noteq> null"
- shows "h \<cdot> g \<cdot> f = (h \<cdot> g) \<cdot> f"
- proof -
- have 1: "Arr f \<and> Arr g \<and> Cod f = Dom g"
- using assms(1) comp_def null_char by metis
- have 2: "Arr g \<and> Arr h \<and> Cod g = Dom h"
- using assms(2) comp_def null_char by metis
- have 3: "Arr (comp g f) \<and>
- comp g f = (compose (Dom f) (Fun g) (Fun f), (Dom f, Cod g))"
- using 1 comp_def Arr_comp by metis
- have 4: "Arr (comp h g) \<and>
- comp h g = (compose (Dom g) (Fun h) (Fun g), (Dom g, Cod h))"
- using 2 comp_def Arr_comp by metis
- have "h \<cdot> g \<cdot> f =
- (compose (Dom f) (Fun h) (compose (Dom f) (Fun g) (Fun f)), (Dom f, Cod h))"
- using 1 2 3 comp_def by (metis (no_types, lifting) fst_conv snd_conv)
- also have
- "... = (compose (Dom f) (compose (Dom g) (Fun h) (Fun g)) (Fun f), (Dom f, Cod h))"
- using 1 2 unfolding Arr_def using compose_assoc by fastforce
- also have "... = (h \<cdot> g) \<cdot> f"
- using 1 2 4 comp_def by (metis (no_types) fst_conv snd_conv)
- finally show ?thesis by auto
- qed
-
- theorem is_category:
- shows "category comp"
- proof
- fix f g h :: "'a arr"
- show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
- using null_char comp_def Arr_comp arr_char by metis
- show "(domains f \<noteq> {}) = (codomains f \<noteq> {})"
- using has_domain_char has_codomain_char by blast
- show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
- using Arr_comp arr_char comp_def [of h g] comp_def [of g f] comp_def [of "comp h g" f]
- by (metis fst_conv snd_conv)
- show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
- using Arr_comp arr_char comp_def [of h g] comp_def [of g f] comp_def [of h "comp g f"]
- by (metis snd_conv)
- show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
- using Arr_comp arr_char comp_def [of h g] comp_def [of g f] comp_def [of "comp h g" f]
- by (metis fst_conv snd_conv)
- show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
- using comp_assoc not_arr_null by metis
- qed
-
- interpretation category comp
- using is_category by auto
-
- text\<open>
- Next, we obtain characterizations of the basic notions of the \<open>category\<close>
- locale in terms of the concrete structure.
-\<close>
-
- lemma dom_simp:
- assumes "arr f"
- shows "dom f = Id (Dom f)"
- using assms has_domain_char domain_unique dom_in_domains has_domain_iff_arr
- by blast
-
- lemma cod_simp:
- assumes "arr f"
- shows "cod f = Id (Cod f)"
- using assms has_codomain_char codomain_unique cod_in_codomains has_codomain_iff_arr
- by blast
-
- lemma dom_char:
- shows "dom f = (if arr f then (\<lambda>x \<in> Dom f. x, (Dom f, Dom f)) else null)"
- using Id_def dom_simp has_domain_iff_arr dom_def by metis
-
- lemma cod_char:
- shows "cod f = (if arr f then (\<lambda>x \<in> Cod f. x, (Cod f, Cod f)) else null)"
- using Id_def cod_simp has_codomain_iff_arr cod_def by metis
-
- lemma ide_char:
- shows "ide a \<longleftrightarrow> Dom a = Cod a \<and> Fun a = (\<lambda>x \<in> Dom a. x)"
- using dom_char in_homE [of a a a] arr_char dom_char ide_dom Arr_Id Id_def ide_in_hom
- by (metis fst_conv snd_conv prod.collapse)
-
- lemma seq_char:
- shows "seq g f \<longleftrightarrow> Arr f \<and> Arr g \<and> Cod f = Dom g"
- proof -
- have "seq g f \<longrightarrow> snd (snd f) = fst (snd g)"
- by (metis not_arr_null comp_def null_char)
- thus ?thesis
- using arr_char dom_char cod_char seqI seqE by metis
- qed
-
- lemma comp_char:
- shows "g \<cdot> f = (if seq g f then
- (compose (Dom f) (Fun g) (Fun f), (Dom f, Cod g))
- else Null)"
- using seq_char comp_def null_char by metis
-
- end
-
- sublocale setcat \<subseteq> category comp
- using is_category by auto
-
- text\<open>
- Now we want to apply the preceding construction to obtain an actual interpretation
- of the \<open>set_category\<close> locale that hides the concrete details of the construction.
- To do this, we first import the preceding construction into a local context,
- then define an opaque new arrow type for the arrows, and lift just enough
- of the properties of the concrete construction to the abstract setting to make
- it possible to prove that the abstracted category interprets the \<open>set_category\<close>
- locale. We can then forget about everything except the \<open>set_category\<close> axioms.
- All of this is done within a local context to avoid making any global interpretations.
- Everything except what we ultimately want to export is declared ``private''.
-\<close>
-
- context begin
-
- interpretation SC: setcat .
- no_notation SC.comp (infixr "\<cdot>" 55)
-
- typedef 'a arr = "UNIV :: (('a \<Rightarrow> 'a) * ('a set * 'a set)) set" ..
-
- interpretation AC: abstracted_category SC.comp Abs_arr Rep_arr UNIV
- using Rep_arr_inverse Abs_arr_inverse by (unfold_locales, auto)
-
- definition comp
- where "comp \<equiv> AC.comp"
-
- lemma is_category:
- shows "category comp"
- using comp_def AC.category_axioms by metis
-
- interpretation category comp using is_category by auto
-
- notation comp (infixr "\<cdot>" 55)
- notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
-
- text\<open>
- To be able to accomplish anything with the category we just defined,
- we have to lift a certain amount of the features of the concrete structure
- through the abstraction.
-\<close>
+ shows "arr f \<longleftrightarrow> f \<noteq> Null \<and> Map f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
+ using arr_char by auto
- private definition MkArr
- where "MkArr A B F \<equiv> Abs_arr (restrict F A, (A, B))"
-
- private abbreviation Id
- where "Id A \<equiv> MkArr A A id"
-
- private definition Dom
- where "Dom f \<equiv> SC.Dom (Rep_arr f)"
-
- private definition Cod
- where "Cod f \<equiv> SC.Cod (Rep_arr f)"
-
- private definition Fun
- where "Fun f \<equiv> SC.Fun (Rep_arr f)"
-
- private lemma Dom_MkArr [simp]:
- shows "Dom (MkArr A B F) = A"
- using Dom_def MkArr_def by (metis AC.rep_abs UNIV_I fst_conv snd_conv)
-
- private lemma Cod_MkArr [simp]:
- shows "Cod (MkArr A B F) = B"
- using Cod_def MkArr_def by (metis AC.rep_abs UNIV_I snd_conv)
-
- private lemma Fun_MkArr [simp]:
- shows "Fun (MkArr A B F) = restrict F A"
- using Fun_def MkArr_def by (metis AC.rep_abs UNIV_I fst_conv)
-
- private lemma null_char:
- shows "null = Abs_arr SC.Null"
- using comp_def by (metis AC.null_char SC.null_char)
-
- private lemma arr_char:
- shows "arr f \<longleftrightarrow> Fun f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
- using comp_def AC.arr_char SC.arr_char SC.Arr_def Dom_def Cod_def Fun_def by metis
-
- private lemma dom_char:
- shows "dom f = (if arr f then MkArr (Dom f) (Dom f) id else null)"
- using MkArr_def id_apply restrict_ext comp_def AC.dom_char AC.arr_char SC.dom_char
- Dom_def
- by metis
-
- private lemma cod_char:
- shows "cod f = (if arr f then MkArr (Cod f) (Cod f) id else null)"
- using MkArr_def id_apply restrict_ext comp_def AC.cod_char AC.arr_char SC.cod_char
- Cod_def
- by metis
-
- private lemma ide_char:
- shows "ide f = (Dom f = Cod f \<and> Fun f = (\<lambda>x \<in> Dom f. x))"
- using comp_def AC.ide_char SC.ide_char Dom_def Cod_def Fun_def by metis
-
- private lemma seq_char:
- shows "seq g f = (arr f \<and> arr g \<and> Cod f = Dom g)"
- using dom_char cod_char Dom_MkArr seqI seqE by metis
-
- private lemma comp_char:
- shows "g \<cdot> f = (if seq g f then
- MkArr (Dom f) (Cod g) (compose (Dom f) (Fun g) (Fun f))
- else null)"
- proof (cases "seq g f")
- show "\<not>seq g f \<Longrightarrow> ?thesis"
- using comp_def AC.comp_char by metis
- show "seq g f \<Longrightarrow> ?thesis"
+ lemma terminal_char:
+ shows "terminal a \<longleftrightarrow> (\<exists>x. a = MkIde {x})"
+ proof
+ show "\<exists>x. a = MkIde {x} \<Longrightarrow> terminal a"
proof -
- assume gf: "seq g f"
- have "g \<cdot> f = Abs_arr (compose (Dom f) (Fun g) (Fun f), Dom f, Cod g)"
- using gf
- by (metis (no_types, lifting) AC.comp_char Cod_def Dom_def Fun_def
- comp_def has_codomain_iff_arr null_char setcat.comp_def codomains_null)
- also have "... = MkArr (Dom f) (Cod g) (compose (Dom f) (Fun g) (Fun f))"
- using MkArr_def [of "Dom f" "Cod g" "compose (Dom f) (Fun g) (Fun f)"]
- compose_def
- by simp
- finally have "g \<cdot> f = MkArr (Dom f) (Cod g) (compose (Dom f) (Fun g) (Fun f))"
- by auto
- thus ?thesis using gf by auto
- qed
- qed
-
- private lemma arr_MkArr:
- assumes "F \<in> A \<rightarrow> B"
- shows "arr (MkArr A B F)"
- using assms arr_char Fun_MkArr Dom_MkArr Cod_MkArr by force
-
- private lemma MkArr_Fun:
- assumes "arr f"
- shows "MkArr (Dom f) (Cod f) (Fun f) = f"
- using assms arr_char MkArr_def Dom_def Cod_def Fun_def
- by (metis AC.abs_rep IntD1 extensional_restrict prod.collapse)
-
- private lemma arr_eqI:
- assumes "arr f" and "arr f'"
- and "Dom f = Dom f'" and "Cod f = Cod f'" and "Fun f = Fun f'"
- shows "f = f'"
- using assms MkArr_Fun by metis
-
- private lemma ide_Id:
- shows "ide (Id A)"
- using ide_char Fun_MkArr Dom_MkArr Cod_MkArr id_apply restrict_ext by metis
-
- private lemma Id_Dom:
- assumes "ide a"
- shows "Id (Dom a) = a"
- using assms dom_char ide_in_hom by (metis in_homE)
-
- private lemma Id_Cod:
- assumes "ide a"
- shows "Id (Cod a) = a"
- using assms ide_char by (metis Id_Dom)
-
- private lemma MkArr_in_hom:
- assumes "F \<in> A \<rightarrow> B"
- shows "\<guillemotleft>MkArr A B F : Id A \<rightarrow> Id B\<guillemotright>"
- proof -
- have 1: "arr (MkArr A B F)" using assms arr_MkArr by blast
- moreover have "dom (MkArr A B F) = Id A"
- using 1 dom_char Dom_MkArr by metis
- moreover have "cod (MkArr A B F) = Id B"
- using 1 cod_char Cod_MkArr by metis
- ultimately show ?thesis by blast
- qed
-
- private lemma terminal_char:
- shows "terminal a \<longleftrightarrow> (\<exists>x. a = Id {x})"
- proof
- show "\<exists>x. a = Id {x} \<Longrightarrow> terminal a"
- proof -
- assume a: "\<exists>x. a = Id {x}"
- from this obtain x where x: "a = Id {x}" by blast
- have "terminal (Id {x})"
+ assume a: "\<exists>x. a = MkIde {x}"
+ from this obtain x where x: "a = MkIde {x}" by blast
+ have "terminal (MkIde {x})"
proof
- show 1: "ide (Id {x})"
- using ide_Id by metis
- show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> Id {x}\<guillemotright>"
+ show "ide (MkIde {x})"
+ using ide_MkIde by auto
+ show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
proof
- fix a :: "'a arr"
+ fix a :: "'a setcat.arr"
assume a: "ide a"
- show "\<guillemotleft>MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x) : a \<rightarrow> Id {x}\<guillemotright>"
- using a Id_Dom MkArr_in_hom
- by (metis restrictI singletonI)
- fix f :: "'a arr"
- assume f: "\<guillemotleft>f : a \<rightarrow> Id {x}\<guillemotright>"
+ show "\<guillemotleft>MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x) : a \<rightarrow> MkIde {x}\<guillemotright>"
+ using a MkArr_in_hom
+ by (metis (mono_tags, lifting) IntI MkIde_Dom' restrictI restrict_extensional
+ singletonI UNIV_I)
+ fix f :: "'a setcat.arr"
+ assume f: "\<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
show "f = MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)"
proof -
- have 2: "Dom f = Dom a \<and> Cod f = {x}"
- using a f Dom_MkArr dom_char cod_char in_homE by metis
- moreover have "Fun f = (\<lambda>_ \<in> Dom a. x)"
+ have 1: "Dom f = Dom a \<and> Cod f = {x}"
+ using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
+ moreover have "Map f = (\<lambda>_ \<in> Dom a. x)"
proof
fix z
- have "z \<notin> Dom a \<Longrightarrow> Fun f z = (\<lambda>_ \<in> Dom a. x) z"
- by (metis f 2 Fun_MkArr MkArr_Fun in_homE restrict_def)
- moreover have "z \<in> Dom a \<Longrightarrow> Fun f z = (\<lambda>_ \<in> Dom a. x) z"
- using f 2 arr_char [of f] by auto
- ultimately show "Fun f z = (\<lambda>_ \<in> Dom a. x) z" by auto
+ have "z \<notin> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
+ using f 1 MkArr_expansion
+ by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
+ moreover have "z \<in> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
+ using f 1 arr_char [of f] by fastforce
+ ultimately show "Map f z = (\<lambda>_ \<in> Dom a. x) z" by auto
qed
ultimately show ?thesis
- using a f arr_eqI MkArr_Fun mem_Collect_eq by fastforce
+ using f MkArr_expansion [of f] by fastforce
qed
qed
qed
thus "terminal a" using x by simp
qed
- show "terminal a \<Longrightarrow> \<exists>x. a = Id {x}"
+ show "terminal a \<Longrightarrow> \<exists>x. a = MkIde {x}"
proof -
assume a: "terminal a"
hence "ide a" using terminal_def by auto
have 1: "\<exists>!x. x \<in> Dom a"
proof -
have "Dom a = {} \<Longrightarrow> \<not>terminal a"
proof -
assume "Dom a = {}"
- hence 1: "a = Id {}" using \<open>ide a\<close> Id_Dom by force
- have "\<And>f. f \<in> hom (Id {undefined}) (Id {}) \<Longrightarrow> Fun f \<in> {undefined} \<rightarrow> {}"
- by (metis Cod_MkArr CollectD IntD2 arrI arr_char cod_char dom_char in_homE)
- hence "hom (Id {undefined}) a = {}" using 1 by auto
- moreover have "ide (Id {undefined})" using ide_Id by auto
- ultimately show "\<not>terminal a" by auto
+ hence 1: "a = MkIde {}" using \<open>ide a\<close> MkIde_Dom' by force
+ have "\<And>f. f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'a set))
+ \<Longrightarrow> Map f \<in> {undefined} \<rightarrow> {}"
+ proof -
+ fix f
+ assume f: "f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'a set))"
+ show "Map f \<in> {undefined} \<rightarrow> {}"
+ using f MkArr_expansion arr_char [of f] in_hom_char by auto
+ qed
+ hence "hom (MkIde {undefined}) a = {}" using 1 by auto
+ moreover have "ide (MkIde {undefined})" using ide_MkIde by auto
+ ultimately show "\<not>terminal a" by blast
qed
moreover have "\<And>x x'. x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>terminal a"
proof -
fix x x'
assume 1: "x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x'"
- have "\<guillemotleft>MkArr {undefined} (Dom a) (\<lambda>_. x) : Id {undefined} \<rightarrow> a\<guillemotright>"
- using 1 MkArr_in_hom [of "\<lambda>_. x" "{undefined}" "Dom a"] Id_Dom [of a] \<open>ide a\<close>
- by simp
- moreover have "\<guillemotleft>MkArr {undefined} (Dom a) (\<lambda>_. x') : Id {undefined} \<rightarrow> a\<guillemotright>"
- using 1 MkArr_in_hom [of "\<lambda>_. x'" "{undefined}" "Dom a"] Id_Dom [of a] \<open>ide a\<close>
- by simp
+ have "\<guillemotleft>MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x) : MkIde {undefined} \<rightarrow> a\<guillemotright>"
+ using 1
+ by (metis (mono_tags, lifting) IntI MkIde_Dom' \<open>ide a\<close> restrictI
+ restrict_extensional MkArr_in_hom UNIV_I)
moreover have
- "MkArr {undefined} (Dom a) (\<lambda>_. x) \<noteq> MkArr {undefined} (Dom a) (\<lambda>_. x')"
- using 1 Fun_MkArr restrict_apply by (metis singletonI)
+ "\<guillemotleft>MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x') : MkIde {undefined} \<rightarrow> a\<guillemotright>"
+ using 1
+ by (metis (mono_tags, lifting) IntI MkIde_Dom' \<open>ide a\<close> restrictI
+ restrict_extensional MkArr_in_hom UNIV_I)
+ moreover have "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x) \<noteq>
+ MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x')"
+ using 1 by (metis arr.inject restrict_apply' singletonI)
ultimately show "\<not>terminal a"
- using terminal_arr_unique by (metis arrI in_homE)
+ using terminal_arr_unique
+ by (metis (mono_tags, lifting) in_homE)
qed
ultimately show ?thesis
using a by auto
qed
hence "Dom a = {THE x. x \<in> Dom a}"
using theI [of "\<lambda>x. x \<in> Dom a"] by auto
- hence "a = Id {THE x. x \<in> Dom a}"
- using a Id_Dom terminal_def by metis
- thus "\<exists>x. a = Id {x}"
+ hence "a = MkIde {THE x. x \<in> Dom a}"
+ using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
+ thus "\<exists>x. a = MkIde {x}"
by auto
qed
qed
- private definition Img :: "'a arr \<Rightarrow> 'a arr"
- where "Img f = Id (Fun f ` Dom f)"
+ definition Img :: "'a setcat.arr \<Rightarrow> 'a setcat.arr"
+ where "Img f = MkIde (Map f ` Dom f)"
- interpretation set_category_data comp Img ..
+ interpretation set_category_data Comp Img ..
- private lemma terminal_unity:
+ lemma terminal_unity:
shows "terminal unity"
- using terminal_char unity_def someI_ex [of terminal] by metis
+ using terminal_char unity_def someI_ex [of terminal]
+ by (metis (mono_tags, lifting))
text\<open>
The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
the inhabitants of type @{typ 'a} and the corresponding terminal objects.
These are exported so that a client of the theory can relate the concrete
element type @{typ 'a} to the otherwise abstract arrow type.
\<close>
- definition UP :: "'a \<Rightarrow> 'a arr"
- where "UP x \<equiv> Id {x}"
+ definition UP :: "'a \<Rightarrow> 'a setcat.arr"
+ where "UP x \<equiv> MkIde {x}"
- definition DOWN :: "'a arr \<Rightarrow> 'a"
+ definition DOWN :: "'a setcat.arr \<Rightarrow> 'a"
where "DOWN t \<equiv> the_elem (Dom t)"
- abbreviation U :: 'a
+ abbreviation U
where "U \<equiv> DOWN unity"
lemma UP_mapsto:
shows "UP \<in> UNIV \<rightarrow> Univ"
using terminal_char UP_def by fast
lemma DOWN_mapsto:
shows "DOWN \<in> Univ \<rightarrow> UNIV"
by auto
lemma DOWN_UP [simp]:
shows "DOWN (UP x) = x"
by (simp add: DOWN_def UP_def)
lemma UP_DOWN [simp]:
assumes "t \<in> Univ"
shows "UP (DOWN t) = t"
using assms terminal_char UP_def DOWN_def
- by (metis CollectD Dom_MkArr the_elem_eq)
+ by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)
lemma inj_UP:
shows "inj UP"
by (metis DOWN_UP injI)
lemma bij_UP:
shows "bij_betw UP UNIV Univ"
proof (intro bij_betwI)
- interpret category comp using is_category by auto
- show DOWN_UP: "\<And>x :: 'a. DOWN (UP x) = x" by auto
- show UP_DOWN: "\<And>t. t \<in> Univ \<Longrightarrow> UP (DOWN t) = t" by auto
+ interpret category Comp using is_category by auto
+ show DOWN_UP: "\<And>x :: 'a. DOWN (UP x) = x" by simp
+ show UP_DOWN: "\<And>t. t \<in> Univ \<Longrightarrow> UP (DOWN t) = t" by simp
show "UP \<in> UNIV \<rightarrow> Univ" using UP_mapsto by auto
show "DOWN \<in> Collect terminal \<rightarrow> UNIV" by auto
qed
- private lemma Dom_terminal:
+ lemma Dom_terminal:
assumes "terminal t"
shows "Dom t = {DOWN t}"
- using assms UP_DOWN UP_def
- by (metis Dom_MkArr mem_Collect_eq)
+ using assms UP_def
+ by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)
text\<open>
The image of a point @{term "p \<in> hom unity a"} is a terminal object, which is given
by the formula @{term "(UP o Fun p o DOWN) unity"}.
\<close>
- private lemma Img_point:
+ lemma Img_point:
assumes "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright>"
shows "Img \<in> hom unity a \<rightarrow> Univ"
- and "Img p = (UP o Fun p o DOWN) unity"
+ and "Img p = (UP o Map p o DOWN) unity"
proof -
show "Img \<in> hom unity a \<rightarrow> Univ"
proof
- fix x
- assume x: "x \<in> hom unity a"
- have "terminal (Id (Fun x ` Dom unity))"
- using x terminal_char
- by (metis (no_types, lifting) Dom_terminal image_empty image_insert terminal_unity)
- hence "Id (Fun x ` Dom unity) \<in> Univ" by simp
- moreover have "Id (Fun x ` Dom unity) = Img x"
- using x dom_char Dom_MkArr Img_def in_homE by (metis CollectD)
- ultimately show "Img x \<in> Univ" by auto
+ fix f
+ assume f: "f \<in> hom unity a"
+ have "terminal (MkIde (Map f ` Dom unity))"
+ proof -
+ obtain u :: 'a where u: "unity = MkIde {u}"
+ using terminal_unity terminal_char
+ by (metis (mono_tags, lifting))
+ have "Map f ` Dom unity = {Map f u}"
+ using u by simp
+ thus ?thesis
+ using terminal_char by auto
+ qed
+ hence "MkIde (Map f ` Dom unity) \<in> Univ" by simp
+ moreover have "MkIde (Map f ` Dom unity) = Img f"
+ using f dom_char Img_def in_homE
+ by (metis (mono_tags, lifting) Dom.simps(1) mem_Collect_eq)
+ ultimately show "Img f \<in> Univ" by auto
qed
- have 1: "Dom p = Dom unity"
- using assms dom_char Dom_MkArr by (metis in_homE)
- have "Img p = Id (Fun p ` Dom p)" using Img_def by blast
- also have "... = Id (Fun p ` {U})"
- using 1 terminal_unity Dom_terminal by metis
- also have "... = (UP o Fun p o DOWN) unity" by (simp add: UP_def)
- finally show "Img p = (UP o Fun p o DOWN) unity" using assms by auto
+ have "Img p = MkIde (Map p ` Dom p)" using Img_def by blast
+ also have "... = MkIde (Map p ` {U})"
+ using assms in_hom_char terminal_unity Dom_terminal
+ by (metis (mono_tags, lifting))
+ also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
+ finally show "Img p = (UP o Map p o DOWN) unity" using assms by auto
qed
text\<open>
The function @{term Img} is injective on @{term "hom unity a"} and its inverse takes
a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
constant-@{term t} function.
\<close>
- private abbreviation MkElem
+ abbreviation MkElem :: "'a setcat.arr => 'a setcat.arr => 'a setcat.arr"
where "MkElem t a \<equiv> MkArr {U} (Dom a) (\<lambda>_ \<in> {U}. DOWN t)"
- private lemma MkElem_in_hom:
+ lemma MkElem_in_hom:
assumes "arr f" and "x \<in> Dom f"
shows "\<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
proof -
have "(\<lambda>_ \<in> {U}. DOWN (UP x)) \<in> {U} \<rightarrow> Dom (dom f)"
- using assms dom_char [of f] by fastforce
- moreover have "Id {U} = unity"
- by (metis Dom_MkArr Dom_terminal terminal_char terminal_unity)
- moreover have "Id (Dom (dom f)) = dom f"
- using assms by (simp add: dom_char)
+ using assms dom_char [of f] by simp
+ moreover have "MkIde {U} = unity"
+ using terminal_char terminal_unity
+ by (metis (mono_tags, lifting) DOWN_UP UP_def)
+ moreover have "MkIde (Dom (dom f)) = dom f"
+ using assms dom_char MkIde_Dom' ide_dom by blast
ultimately show ?thesis
- using assms MkArr_in_hom [of "\<lambda>_ \<in> {U}. DOWN (UP x)" "{U}" "Dom (dom f)"] by metis
+ using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "\<lambda>_ \<in> {U}. DOWN (UP x)"]
+ by (metis (mono_tags, lifting) IntI restrict_extensional UNIV_I)
qed
- private lemma MkElem_Img:
+ lemma MkElem_Img:
assumes "p \<in> hom unity a"
shows "MkElem (Img p) a = p"
proof -
- have 0: "Img p = UP (Fun p U)"
+ have 0: "Img p = UP (Map p U)"
using assms Img_point(2) by auto
have 1: "Dom p = {U}"
- using assms dom_char Dom_MkArr terminal_unity Dom_terminal
- by (metis in_homE CollectD)
+ using assms terminal_unity Dom_terminal
+ by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
moreover have "Cod p = Dom a"
- using assms cod_char by (metis Dom_MkArr in_homE CollectD)
- moreover have "Fun p = (\<lambda>_ \<in> {U}. DOWN (Img p))"
+ using assms
+ by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
+ moreover have "Map p = (\<lambda>_ \<in> {U}. DOWN (Img p))"
proof
fix e
- show "Fun p e = (\<lambda>_ \<in> {U}. DOWN (Img p)) e"
- using assms 0 1 Fun_MkArr MkArr_Fun in_homE
- by (metis DOWN_UP restrict_apply singleton_iff CollectD)
+ show "Map p e = (\<lambda>_ \<in> {U}. DOWN (Img p)) e"
+ proof -
+ have "Map p e = (\<lambda>x \<in> Dom p. Map p x) e"
+ using assms MkArr_expansion [of p]
+ by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
+ also have "... = (\<lambda>_ \<in> {U}. DOWN (Img p)) e"
+ using assms 0 1 by simp
+ finally show ?thesis by blast
+ qed
qed
ultimately show "MkElem (Img p) a = p"
- using assms arr_eqI Dom_MkArr Cod_MkArr Fun_MkArr MkArr_Fun CollectD by fastforce
+ using assms MkArr_Map CollectD
+ by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
qed
- private lemma inj_Img:
+ lemma inj_Img:
assumes "ide a"
shows "inj_on Img (hom unity a)"
- using assms MkElem_Img inj_onI [of "hom unity a" Img] by metis
+ proof (intro inj_onI)
+ fix x y
+ assume x: "x \<in> hom unity a"
+ assume y: "y \<in> hom unity a"
+ assume eq: "Img x = Img y"
+ show "x = y"
+ proof (intro arr_eqI)
+ show "arr x" using x by blast
+ show "arr y" using y by blast
+ show "Dom x = Dom y"
+ using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
+ show "Cod x = Cod y"
+ using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
+ show "Map x = Map y"
+ proof -
+ have "Map x = (\<lambda>z \<in> {U}. Map x z) \<and> Map y = (\<lambda>z \<in> {U}. Map y z)"
+ using x y \<open>arr x\<close> \<open>arr y\<close> Dom_terminal terminal_unity MkArr_expansion
+ by (metis (mono_tags, lifting) CollectD Map.simps(1) in_hom_char)
+ moreover have "Map x U = Map y U"
+ using x y eq
+ by (metis (mono_tags, lifting) CollectD Img_point(2) o_apply setcat.DOWN_UP)
+ ultimately show ?thesis
+ by (metis (mono_tags, lifting) restrict_ext singletonD)
+ qed
+ qed
+ qed
- private lemma set_char:
+ lemma set_char:
assumes "ide a"
shows "set a = UP ` Dom a"
proof
show "set a \<subseteq> UP ` Dom a"
proof
fix t
assume "t \<in> set a"
from this obtain p where p: "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright> \<and> t = Img p"
using set_def by blast
- have 1: "Dom p = Dom unity"
- using p dom_char Dom_MkArr by (metis in_homE)
- have "t = (UP o Fun p o DOWN) unity"
+ have "t = (UP o Map p o DOWN) unity"
using p Img_point(2) by blast
- moreover have "(Fun p o DOWN) unity \<in> Dom a"
- using 1 p arr_char Dom_terminal terminal_unity cod_char
- by (metis Dom_MkArr IntD2 PiE comp_apply in_homE singletonI)
+ moreover have "(Map p o DOWN) unity \<in> Dom a"
+ using p arr_char in_hom_char Dom_terminal terminal_unity
+ by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
ultimately show "t \<in> UP ` Dom a" by simp
qed
show "UP ` Dom a \<subseteq> set a"
proof
fix t
assume "t \<in> UP ` Dom a"
from this obtain x where x: "x \<in> Dom a \<and> t = UP x" by blast
let ?p = "MkElem (UP x) a"
have p: "?p \<in> hom unity a"
- using assms x MkElem_in_hom [of "dom a"] by auto
- moreover have "Img ?p = t" using p x Img_point by force
+ using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
+ moreover have "Img ?p = t"
+ using p x DOWN_UP
+ by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
+ image_insert image_restrict_eq setcat.Img_def UP_def)
ultimately show "t \<in> set a" using set_def by blast
qed
qed
- private lemma Fun_via_comp:
+ lemma Map_via_comp:
assumes "arr f"
- shows "Fun f = restrict (\<lambda>x. Fun (comp f (MkElem (UP x) (dom f))) U) (Dom f)"
+ shows "Map f = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U)"
proof
fix x
- have "x \<notin> Dom f \<Longrightarrow>
- Fun f x = restrict (\<lambda>x. Fun (comp f (MkElem (UP x) (dom f))) U) (Dom f) x"
+ have "x \<notin> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
moreover have
- "x \<in> Dom f \<Longrightarrow>
- Fun f x = restrict (\<lambda>x. Fun (comp f (MkElem (UP x) (dom f))) U) (Dom f) x"
+ "x \<in> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
proof -
assume x: "x \<in> Dom f"
- have "\<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
+ let ?X = "MkElem (UP x) (dom f)"
+ have "\<guillemotleft>?X : unity \<rightarrow> dom f\<guillemotright>"
using assms x MkElem_in_hom by auto
- hence "f \<cdot> MkElem (UP x) (dom f) =
- MkArr {U} (Cod f) (compose {U} (Fun f) (\<lambda>_ \<in> {U}. x))"
- using assms MkArr_Fun comp_char [of f "MkElem (UP x) (dom f)"] by auto
- hence "Fun (f \<cdot> MkElem (UP x) (dom f)) = compose {U} (Fun f) (\<lambda>_ \<in> {U}. x)"
- by (simp add: extensional_restrict)
+ moreover have "Dom ?X = {U} \<and> Map ?X = (\<lambda>_ \<in> {U}. x)"
+ using x by simp
+ ultimately have
+ "Map (f \<cdot> MkElem (UP x) (dom f)) = compose {U} (Map f) (\<lambda>_ \<in> {U}. x)"
+ using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
+ by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
thus ?thesis
using x by (simp add: compose_eq restrict_apply' singletonI)
qed
- ultimately show
- "Fun f x = restrict (\<lambda>x. Fun (f \<cdot> MkElem (UP x) (dom f)) U) (Dom f) x"
+ ultimately show "Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
by auto
qed
+
+ lemma arr_eqI':
+ assumes "par f f'" and "\<And>t. \<guillemotleft>t : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> t = f' \<cdot> t"
+ shows "f = f'"
+ proof (intro arr_eqI)
+ show "arr f" using assms by simp
+ show "arr f'" using assms by simp
+ show "Dom f = Dom f'"
+ using assms by (metis (mono_tags, lifting) Dom_dom)
+ show "Cod f = Cod f'"
+ using assms by (metis (mono_tags, lifting) Cod_cod)
+ show "Map f = Map f'"
+ proof
+ have 1: "\<And>x. x \<in> Dom f \<Longrightarrow> \<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
+ using MkElem_in_hom by (metis (mono_tags, lifting) assms(1))
+ fix x
+ show "Map f x = Map f' x"
+ using assms 1 \<open>Dom f = Dom f'\<close> by (simp add: Map_via_comp)
+ qed
+ qed
text\<open>
The main result, which establishes the consistency of the \<open>set_category\<close> locale
and provides us with a way of obtaining ``set categories'' at arbitrary types.
\<close>
theorem is_set_category:
- shows "set_category comp"
+ shows "set_category Comp"
proof
- show "\<exists>img :: 'a arr \<Rightarrow> 'a arr. set_category_given_img comp img"
+ show "\<exists>img :: 'a setcat.arr \<Rightarrow> 'a setcat.arr. set_category_given_img Comp img"
proof
- show "set_category_given_img (comp :: 'a arr comp) Img"
+ show "set_category_given_img (Comp :: 'a setcat.arr comp) Img"
proof
show "Univ \<noteq> {}" using terminal_char by blast
- fix a :: "'a arr"
+ fix a :: "'a setcat.arr"
assume a: "ide a"
show "Img \<in> hom unity a \<rightarrow> Univ" using Img_point terminal_unity by blast
show "inj_on Img (hom unity a)" using a inj_Img terminal_unity by blast
next
- fix t :: "'a arr"
+ fix t :: "'a setcat.arr"
assume t: "terminal t"
show "t \<in> Img ` hom unity t"
proof -
- have "UP ` Dom t = {t}" using t Dom_terminal [of t] UP_DOWN by simp
- thus ?thesis using t set_char set_def terminal_def by blast
+ have "t \<in> set t"
+ using t set_char [of t]
+ by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
+ terminal_char terminal_def)
+ thus ?thesis
+ using t set_def [of t] by simp
qed
next
- fix A :: "'a arr set"
+ fix A :: "'a setcat.arr set"
assume A: "A \<subseteq> Univ"
show "\<exists>a. ide a \<and> set a = A"
proof
- let ?a = "MkArr (DOWN ` A) (DOWN ` A) (\<lambda>x. x)"
+ let ?a = "MkArr (DOWN ` A) (DOWN ` A) (\<lambda>x \<in> (DOWN ` A). x)"
show "ide ?a \<and> set ?a = A"
proof
show 1: "ide ?a"
- using ide_char by fastforce
+ using ide_char [of ?a] by simp
show "set ?a = A"
proof -
have 2: "\<And>x. x \<in> A \<Longrightarrow> x = UP (DOWN x)"
using A UP_DOWN by force
hence "UP ` DOWN ` A = A"
using A UP_DOWN by auto
thus ?thesis
using 1 A set_char [of ?a] by simp
qed
qed
qed
next
- fix a b :: "'a arr"
+ fix a b :: "'a setcat.arr"
assume a: "ide a" and b: "ide b" and ab: "set a = set b"
show "a = b"
- using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom by metis
+ using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
+ by (metis (mono_tags, lifting))
next
- fix f f' :: "'a arr"
+ fix f f' :: "'a setcat.arr"
assume par: "par f f'" and ff': "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
- have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
- using par dom_char cod_char Dom_MkArr by (metis (no_types, lifting))
- moreover have "Fun f = Fun f'"
- using 1 par ff' MkElem_in_hom Fun_via_comp Fun_via_comp by fastforce
- ultimately show "f = f'" using par arr_eqI by auto
+ show "f = f'" using par ff' arr_eqI' by blast
next
- fix a b :: "'a arr" and F :: "'a arr \<Rightarrow> 'a arr"
+ fix a b :: "'a setcat.arr" and F :: "'a setcat.arr \<Rightarrow> 'a setcat.arr"
assume a: "ide a" and b: "ide b" and F: "F \<in> hom unity a \<rightarrow> hom unity b"
show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
proof
- let ?f = "MkArr (Dom a) (Dom b) (\<lambda>x. Fun (F (MkElem (UP x) a)) U)"
- have "(\<lambda>x. Fun (F (MkElem (UP x) a)) U) \<in> Dom a \<rightarrow> Dom b"
- proof
- fix x
- assume x: "x \<in> Dom a"
- have "MkElem (UP x) a \<in> hom unity a"
- using x a MkElem_in_hom [of a x] ide_char by force
- hence 1: "F (MkElem (UP x) a) \<in> hom unity b"
- using F by auto
- moreover have "Dom (F (MkElem (UP x) a)) = {U}"
- using 1 by (metis Dom_MkArr MkElem_Img)
- moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
- using 1 by (metis Dom_MkArr cod_char in_homE CollectD)
- ultimately have "Fun (F (MkElem (UP x) a)) \<in> {U} \<rightarrow> Dom b"
- using arr_char [of "F (MkElem (UP x) a)"] by blast
- thus "Fun (F (MkElem (UP x) a)) U \<in> Dom b" by blast
+ let ?f = "MkArr (Dom a) (Dom b) (\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)"
+ have 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
+ proof -
+ have "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)
+ \<in> extensional (Dom a) \<inter> (Dom a \<rightarrow> Dom b)"
+ proof
+ show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> extensional (Dom a)"
+ using a F by simp
+ show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> Dom a \<rightarrow> Dom b"
+ proof
+ fix x
+ assume x: "x \<in> Dom a"
+ have "MkElem (UP x) a \<in> hom unity a"
+ using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
+ hence 1: "F (MkElem (UP x) a) \<in> hom unity b"
+ using F by auto
+ moreover have "Dom (F (MkElem (UP x) a)) = {U}"
+ using 1 MkElem_Img
+ by (metis (mono_tags, lifting) Dom.simps(1))
+ moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
+ using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
+ ultimately have "Map (F (MkElem (UP x) a)) \<in> {U} \<rightarrow> Dom b"
+ using arr_char [of "F (MkElem (UP x) a)"] by blast
+ thus "Map (F (MkElem (UP x) a)) U \<in> Dom b" by blast
+ qed
+ qed
+ hence "\<guillemotleft>?f : MkIde (Dom a) \<rightarrow> MkIde (Dom b)\<guillemotright>"
+ using a b MkArr_in_hom by blast
+ thus ?thesis
+ using a b by simp
qed
- hence 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
- using a b Id_Dom MkArr_in_hom by metis
- have "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
+ moreover have "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
proof -
fix x
assume x: "\<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright>"
have 2: "x = MkElem (Img x) a"
- using a x 1 MkElem_Img [of x a] by auto
+ using a x 1 MkElem_Img [of x a]
+ by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
moreover have 5: "Dom x = {U} \<and> Cod x = Dom a \<and>
- Fun x = (\<lambda>_ \<in> {U}. DOWN (Img x))"
- using x 2 Dom_MkArr [of "{U}" "Dom a" "\<lambda>_ \<in> {U}. DOWN (Img x)"]
- Cod_MkArr [of "{U}" "Dom a" "\<lambda>_ \<in> {U}. DOWN (Img x)"]
- Fun_MkArr [of "{U}" "Dom a" "\<lambda>_ \<in> {U}. DOWN (Img x)"]
- by simp
+ Map x = (\<lambda>_ \<in> {U}. DOWN (Img x))"
+ using x 2
+ by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
moreover have "Cod ?f = Dom b" using 1 by simp
ultimately have
3: "?f \<cdot> x =
- MkArr {U} (Dom b) (compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)))"
- using 1 x comp_char [of ?f "MkElem (Img x) a"] Dom_MkArr Cod_MkArr Fun_MkArr
- by fastforce
- have 4: "compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) = Fun (F x)"
+ MkArr {U} (Dom b) (compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)))"
+ using 1 x comp_char [of ?f "MkElem (Img x) a"]
+ by (metis (mono_tags, lifting) in_homE seqI)
+ have 4: "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) = Map (F x)"
proof
fix y
have "y \<notin> {U} \<Longrightarrow>
- compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Fun (F x) y"
+ compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
proof -
assume y: "y \<notin> {U}"
- have "compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = undefined"
+ have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = undefined"
using y compose_def extensional_arb by simp
- also have "... = Fun (F x) y"
+ also have "... = Map (F x) y"
proof -
have 5: "F x \<in> hom unity b" using x F 1 by fastforce
hence "Dom (F x) = {U}"
- by (metis Dom_MkArr MkElem_Img)
+ by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
thus ?thesis
- using y 5 arr_char [of "F x"] extensional_arb by fastforce
+ using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
+ by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
qed
ultimately show ?thesis by auto
qed
moreover have
"y \<in> {U} \<Longrightarrow>
- compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Fun (F x) y"
+ compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
proof -
assume y: "y \<in> {U}"
- have "compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y =
- Fun ?f (DOWN (Img x))"
+ have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y =
+ Map ?f (DOWN (Img x))"
using y by (simp add: compose_eq restrict_apply')
- also have "... = (\<lambda>x. Fun (F (MkElem (UP x) a)) U) (DOWN (Img x))"
+ also have "... = (\<lambda>x. Map (F (MkElem (UP x) a)) U) (DOWN (Img x))"
proof -
have "DOWN (Img x) \<in> Dom a"
using x y a 5 arr_char in_homE restrict_apply
- by (metis (no_types, lifting) IntD2 PiE)
+ by (metis (mono_tags, lifting) IntD2 PiE)
thus ?thesis
- using Fun_MkArr restrict_apply by simp
+ using restrict_apply by simp
qed
- also have "... = Fun (F x) y"
- using x y 1 MkElem_Img [of x a] by auto
+ also have "... = Map (F x) y"
+ using x y 1 2 MkElem_Img [of x a] by simp
finally show
- "compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Fun (F x) y"
+ "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
by auto
qed
ultimately show
- "compose {U} (Fun ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Fun (F x) y"
+ "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (Img x)) y = Map (F x) y"
by auto
qed
show "?f \<cdot> x = F x"
proof (intro arr_eqI)
- have 5: "?f \<cdot> x \<in> hom unity b" using 1 x by auto
- have 6: "F x \<in> hom unity b" using x F 1 by force
- show "arr (comp ?f x)" using 5 by auto
- show "arr (F x)" using 6 by auto
- show "Dom (comp ?f x) = Dom (F x)"
- using 5 6 Dom_MkArr MkElem_Img by metis
- show "Cod (comp ?f x) = Cod (F x)"
- using 5 6 Cod_MkArr MkElem_Img by metis
- show "Fun (comp ?f x) = Fun (F x)"
- using 3 4 Fun_MkArr
- by (metis compose_def extensional_restrict restrict_extensional)
+ have 5: "?f \<cdot> x \<in> hom unity b" using 1 x by blast
+ have 6: "F x \<in> hom unity b"
+ using x F 1
+ by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
+ show "arr (Comp ?f x)" using 5 by blast
+ show "arr (F x)" using 6 by blast
+ show "Dom (Comp ?f x) = Dom (F x)"
+ using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
+ show "Cod (Comp ?f x) = Cod (F x)"
+ using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
+ show "Map (Comp ?f x) = Map (F x)"
+ using 3 4 by simp
qed
qed
- thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<longrightarrow> comp ?f x = F x)"
+ thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<longrightarrow> Comp ?f x = F x)"
using 1 by blast
qed
qed
qed
qed
text\<open>
+ \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
+ @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
+ of \<open>SetCat\<close>.
+\<close>
+
+ corollary is_concrete_set_category:
+ shows "concrete_set_category Comp Univ UP"
+ proof -
+ interpret S: set_category Comp using is_set_category by auto
+ show ?thesis
+ proof
+ show 1: "UP \<in> Univ \<rightarrow> S.Univ"
+ using UP_def terminal_char by force
+ show "inj_on UP Univ"
+ by (metis (mono_tags, lifting) injD inj_UP inj_onI)
+ qed
+ qed
+
+ text\<open>
As a consequence of the categoricity of the \<open>set_category\<close> axioms,
if @{term S} interprets \<open>set_category\<close>, and if @{term \<phi>} is a bijection between
the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
to the category \<open>SetCat\<close> of @{typ 'a} sets and functions between them constructed here.
\<close>
corollary set_category_iso_SetCat:
fixes S :: "'s comp" and \<phi> :: "'s \<Rightarrow> 'a"
assumes "set_category S"
and "bij_betw \<phi> (Collect (category.terminal S)) UNIV"
- shows "\<exists>\<Phi>. invertible_functor S (SetCat.comp :: 'a arr comp) \<Phi>
- \<and> (\<forall>m. set_category.incl S m \<longrightarrow> set_category.incl SetCat.comp (\<Phi> m))"
+ shows "\<exists>\<Phi>. invertible_functor S (Comp :: 'a setcat.arr comp) \<Phi>
+ \<and> (\<forall>m. set_category.incl S m \<longrightarrow> set_category.incl Comp (\<Phi> m))"
proof -
interpret S: set_category S using assms by auto
let ?\<psi> = "inv_into S.Univ \<phi>"
- have "bij_betw (UP o \<phi>) S.Univ (Collect (category.terminal comp))"
+ have "bij_betw (UP o \<phi>) S.Univ (Collect terminal)"
proof (intro bij_betwI)
- show "UP o \<phi> \<in> S.Univ \<rightarrow> Collect (category.terminal comp)"
+ show "UP o \<phi> \<in> S.Univ \<rightarrow> Collect terminal"
using assms(2) UP_mapsto by auto
- show "?\<psi> o DOWN \<in> Collect (category.terminal comp) \<rightarrow> S.Univ"
- using assms(2) by (metis Pi_I UNIV_I bij_betw_def comp_apply inv_into_into)
+ show "?\<psi> o DOWN \<in> Collect terminal \<rightarrow> S.Univ"
+ proof
+ fix x :: "'a setcat.arr"
+ assume x: "x \<in> Univ"
+ show "(inv_into S.Univ \<phi> \<circ> DOWN) x \<in> S.Univ"
+ using x assms(2) bij_betw_def comp_apply inv_into_into
+ by (metis UNIV_I)
+ qed
fix t
assume "t \<in> S.Univ"
thus "(?\<psi> o DOWN) ((UP o \<phi>) t) = t"
- using assms(2) bij_betw_inv_into_left comp_def by fastforce
+ using assms(2) bij_betw_inv_into_left
+ by (metis comp_apply DOWN_UP)
next
- fix t' :: "'a arr"
- assume "t' \<in> Collect (category.terminal comp)"
+ fix t' :: "'a setcat.arr"
+ assume "t' \<in> Collect terminal"
thus "(UP o \<phi>) ((?\<psi> o DOWN) t') = t'"
- using assms(2) by (metis UNIV_I UP_DOWN bij_betw_def comp_apply f_inv_into_f)
+ using assms(2) by (simp add: bij_betw_def f_inv_into_f)
qed
thus ?thesis
- using assms(1) set_category_is_categorical [of S SetCat.comp "UP o \<phi>"] is_set_category
- by blast
+ using assms(1) set_category_is_categorical [of S Comp "UP o \<phi>"] is_set_category
+ by auto
qed
- text\<open>
- \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
- @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
- of \<open>SetCat\<close>.
+ end
+
+ text \<open>
+ The following context defines the entities that are intended to be exported
+ from this theory. The idea is to avoid exposing as little detail about the
+ construction used in the @{locale setcat} locale as possible, so that proofs
+ using the result of that construction will depend only on facts proved from
+ axioms in the @{locale set_category} locale and not on concrete details from
+ the construction of the interpretation.
\<close>
- corollary is_concrete_set_category:
- shows "concrete_set_category comp Univ UP"
- proof -
- interpret S: set_category comp using is_set_category by auto
- show ?thesis
- proof
- show 1: "UP \<in> S.Univ \<rightarrow> S.Univ" using UP_mapsto by auto
- show "inj_on UP S.Univ" by (metis injD inj_UP inj_onI)
- qed
- qed
+ context
+ begin
- no_notation comp (infixr "\<cdot>" 55)
- no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
+ interpretation S: setcat .
+
+ definition comp
+ where "comp \<equiv> S.Comp"
+
+ interpretation set_category comp
+ unfolding comp_def using S.is_set_category by simp
+
+ lemma is_set_category:
+ shows "set_category comp"
+ ..
+
+ definition DOWN
+ where "DOWN = S.DOWN"
+
+ definition UP
+ where "UP = S.UP"
+
+ lemma UP_mapsto:
+ shows "UP \<in> UNIV \<rightarrow> Univ"
+ using S.UP_mapsto
+ by (simp add: UP_def comp_def)
+
+ lemma DOWN_mapsto:
+ shows "DOWN \<in> Univ \<rightarrow> UNIV"
+ by auto
+
+ lemma DOWN_UP [simp]:
+ shows "DOWN (UP x) = x"
+ by (simp add: DOWN_def UP_def)
+
+ lemma UP_DOWN [simp]:
+ assumes "t \<in> Univ"
+ shows "UP (DOWN t) = t"
+ using assms DOWN_def UP_def
+ by (simp add: DOWN_def UP_def comp_def)
+
+ lemma inj_UP:
+ shows "inj UP"
+ by (metis DOWN_UP injI)
+
+ lemma bij_UP:
+ shows "bij_betw UP UNIV Univ"
+ by (metis S.bij_UP UP_def comp_def)
end
-
+
end
diff --git a/thys/Category3/SetCategory.thy b/thys/Category3/SetCategory.thy
--- a/thys/Category3/SetCategory.thy
+++ b/thys/Category3/SetCategory.thy
@@ -1,2442 +1,2443 @@
(* Title: SetCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter SetCategory
theory SetCategory
imports Category Functor
begin
text\<open>
This theory defines a locale \<open>set_category\<close> that axiomatizes the notion
``category of all @{typ 'a}-sets and functions between them'' in the context of HOL.
A primary reason for doing this is to make it possible to prove results
(such as the Yoneda Lemma) that use such categories without having to commit to a
particular element type @{typ 'a} and without having the results depend on the
concrete details of a particular construction.
The axiomatization given here is categorical, in the sense that if categories
@{term S} and @{term S'} each interpret the \<open>set_category\<close> locale,
then a bijection between the sets of terminal objects of @{term S} and @{term S'}
extends to an isomorphism of @{term S} and @{term S'} as categories.
The axiomatization is based on the following idea: if, for some type @{typ 'a},
category @{term S} is the category of all @{typ 'a}-sets and functions between
them, then the elements of type @{typ 'a} are in bijective correspondence with
the terminal objects of category @{term S}. In addition, if @{term unity}
is an arbitrarily chosen terminal object of @{term S}, then for each object @{term a},
the hom-set @{term "hom unity a"} (\emph{i.e.} the set of ``points'' or
``global elements'' of @{term a}) is in bijective correspondence with a subset
of the terminal objects of @{term S}. By making a specific, but arbitrary,
choice of such a correspondence, we can then associate with each object @{term a}
of @{term S} a set @{term "set a"} that consists of all terminal objects @{term t}
that correspond to some point @{term x} of @{term a}. Each arrow @{term f}
then induces a function \<open>Fun f \<in> set (dom f) \<rightarrow> set (cod f)\<close>,
defined on terminal objects of @{term S} by passing to points of @{term "dom f"},
composing with @{term f}, then passing back from points of @{term "cod f"}
to terminal objects. Once we can associate a set with each object of @{term S}
and a function with each arrow, we can force @{term S} to be isomorphic to the
category of @{typ 'a}-sets by imposing suitable extensionality and completeness axioms.
\<close>
section "Some Lemmas about Restriction"
text\<open>
+ \sloppypar
The development of the \<open>set_category\<close> locale makes heavy use of the
theory @{theory "HOL-Library.FuncSet"}. However, in some cases, I found that
- @{theory "HOL-Library.FuncSet"} did not provide results about restriction in the form that was
+ that theory did not provide results about restriction in the form that was
most useful to me. I used the following additional results in various places.
\<close>
(* This variant of FuncSet.restrict_ext is sometimes useful. *)
lemma restr_eqI:
assumes "A = A'" and "\<And>x. x \<in> A \<Longrightarrow> F x = F' x"
shows "restrict F A = restrict F' A'"
using assms by force
(* This rule avoided a long proof in at least one instance
where FuncSet.restrict_apply did not work.
*)
lemma restr_eqE [elim]:
assumes "restrict F A = restrict F' A" and "x \<in> A"
shows "F x = F' x"
using assms restrict_def by metis
(* This seems more useful than compose_eq in FuncSet. *)
lemma compose_eq' [simp]:
shows "compose A G F = restrict (G o F) A"
unfolding compose_def restrict_def by auto
section "Set Categories"
text\<open>
We first define the locale \<open>set_category_data\<close>, which sets out the basic
data and definitions for the \<open>set_category\<close> locale, without imposing any conditions
other than that @{term S} is a category and that @{term img} is a function defined
on the arrow type of @{term S}. The function @{term img} should be thought of
as a mapping that takes a point @{term "x \<in> hom unity a"} to a corresponding
terminal object @{term "img x"}. Eventually, assumptions will be introduced so
that this is in fact the case.
\<close>
locale set_category_data = category S
for S :: "'s comp" (infixr "\<cdot>" 55)
and img :: "'s \<Rightarrow> 's"
begin
notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
text\<open>
Call the set of all terminal objects of S the ``universe''.
\<close>
abbreviation Univ :: "'s set"
where "Univ \<equiv> Collect terminal"
text\<open>
Choose an arbitrary element of the universe and call it @{term unity}.
\<close>
definition unity :: 's
where "unity = (SOME t. terminal t)"
text\<open>
Each object @{term a} determines a subset @{term "set a"} of the universe,
consisting of all those terminal objects @{term t} such that @{term "t = img x"}
for some @{term "x \<in> hom unity a"}.
\<close>
definition set :: "'s \<Rightarrow> 's set"
where "set a = img ` hom unity a"
text\<open>
The inverse of the map @{term set} is a map @{term mkIde} that takes each subset
of the universe to an identity of @{term[source=true] S}.
\<close>
definition mkIde :: "'s set \<Rightarrow> 's"
where "mkIde A = (if A \<subseteq> Univ then inv_into (Collect ide) set A else null)"
end
text\<open>
Next, we define a locale \<open>set_category_given_img\<close> that augments the
\<open>set_category_data\<close> locale with assumptions that serve to define
the notion of a set category with a chosen correspondence between points
and terminal objects. The assumptions require that the universe be nonempty
(so that the definition of @{term unity} makes sense), that the map
@{term img} is a locally injective map taking points to terminal objects,
that each terminal object @{term t} belongs to @{term "set t"},
that two objects of @{term S} are equal if they determine the same set,
that two parallel arrows of @{term S} are equal if they determine the same
function, that there is an object corresponding to each subset of the universe,
and for any objects @{term a} and @{term b} and function
@{term "F \<in> hom unity a \<rightarrow> hom unity b"} there is an arrow @{term "f \<in> hom a b"}
whose action under the composition of @{term S} coincides with the function @{term F}.
\<close>
locale set_category_given_img = set_category_data S img
for S :: "'s comp" (infixr "\<cdot>" 55)
and img :: "'s \<Rightarrow> 's" +
assumes nonempty_Univ: "Univ \<noteq> {}"
and img_mapsto: "ide a \<Longrightarrow> img \<in> hom unity a \<rightarrow> Univ"
and inj_img: "ide a \<Longrightarrow> inj_on img (hom unity a)"
and stable_img: "terminal t \<Longrightarrow> t \<in> img ` hom unity t"
and extensional_set: "\<lbrakk> ide a; ide b; set a = set b \<rbrakk> \<Longrightarrow> a = b"
and extensional_arr: "\<lbrakk> par f f'; \<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x \<rbrakk> \<Longrightarrow> f = f'"
and set_complete: "A \<subseteq> Univ \<Longrightarrow> \<exists>a. ide a \<and> set a = A"
and fun_complete1: "\<lbrakk> ide a; ide b; F \<in> hom unity a \<rightarrow> hom unity b \<rbrakk>
\<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
begin
text\<open>
Each arrow @{term "f \<in> hom a b"} determines a function @{term "Fun f \<in> Univ \<rightarrow> Univ"},
by passing from @{term Univ} to @{term "hom a unity"}, composing with @{term f},
then passing back to @{term Univ}.
\<close>
definition Fun :: "'s \<Rightarrow> 's \<Rightarrow> 's"
where "Fun f = restrict (img o S f o inv_into (hom unity (dom f)) img) (set (dom f))"
lemma comp_arr_point:
assumes "arr f" and "\<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright>"
shows "f \<cdot> x = inv_into (hom unity (cod f)) img (Fun f (img x))"
proof -
have "\<guillemotleft>f \<cdot> x : unity \<rightarrow> cod f\<guillemotright>"
using assms by blast
thus ?thesis
using assms Fun_def inj_img set_def by simp
qed
text\<open>
Parallel arrows that determine the same function are equal.
\<close>
lemma arr_eqI:
assumes "par f f'" and "Fun f = Fun f'"
shows "f = f'"
using assms comp_arr_point extensional_arr by metis
lemma terminal_unity:
shows "terminal unity"
using unity_def nonempty_Univ by (simp add: someI_ex)
lemma ide_unity [simp]:
shows "ide unity"
using terminal_unity terminal_def by blast
lemma set_subset_Univ [simp]:
assumes "ide a"
shows "set a \<subseteq> Univ"
using assms set_def img_mapsto by auto
lemma inj_on_set:
shows "inj_on set (Collect ide)"
using extensional_set by (intro inj_onI, auto)
text\<open>
The mapping @{term mkIde}, which takes subsets of the universe to identities,
and @{term set}, which takes identities to subsets of the universe, are inverses.
\<close>
lemma mkIde_set [simp]:
assumes "ide a"
shows "mkIde (set a) = a"
using assms mkIde_def inj_on_set inv_into_f_f by simp
lemma set_mkIde [simp]:
assumes "A \<subseteq> Univ"
shows "set (mkIde A) = A"
using assms mkIde_def set_complete someI_ex [of "\<lambda>a. a \<in> Collect ide \<and> set a = A"]
by (simp add: inv_into_def)
lemma ide_mkIde [simp]:
assumes "A \<subseteq> Univ"
shows "ide (mkIde A)"
using assms mkIde_def mkIde_set set_complete by metis
lemma arr_mkIde [iff]:
shows "arr (mkIde A) \<longleftrightarrow> A \<subseteq> Univ"
using not_arr_null mkIde_def ide_mkIde by auto
lemma dom_mkIde [simp]:
assumes "A \<subseteq> Univ"
shows "dom (mkIde A) = mkIde A"
using assms ide_mkIde by simp
lemma cod_mkIde [simp]:
assumes "A \<subseteq> Univ"
shows "cod (mkIde A) = mkIde A"
using assms ide_mkIde by simp
text\<open>
Each arrow @{term f} determines an extensional function from
@{term "set (dom f)"} to @{term "set (cod f)"}.
\<close>
lemma Fun_mapsto:
assumes "arr f"
shows "Fun f \<in> extensional (set (dom f)) \<inter> (set (dom f) \<rightarrow> set (cod f))"
proof
show "Fun f \<in> extensional (set (dom f))" using Fun_def by fastforce
show "Fun f \<in> set (dom f) \<rightarrow> set (cod f)"
proof
fix t
assume t: "t \<in> set (dom f)"
have "Fun f t = img (f \<cdot> inv_into (hom unity (dom f)) img t)"
using assms t Fun_def comp_def by simp
moreover have "... \<in> set (cod f)"
using assms t set_def inv_into_into [of t img "hom unity (dom f)"] by blast
ultimately show "Fun f t \<in> set (cod f)" by auto
qed
qed
text\<open>
Identities of @{term[source=true] S} correspond to restrictions of the identity function.
\<close>
lemma Fun_ide [simp]:
assumes "ide a"
shows "Fun a = restrict (\<lambda>x. x) (set a)"
using assms Fun_def inj_img set_def comp_cod_arr by fastforce
lemma Fun_mkIde [simp]:
assumes "A \<subseteq> Univ"
shows "Fun (mkIde A) = restrict (\<lambda>x. x) A"
using assms by simp
text\<open>
Composition in @{term S} corresponds to extensional function composition.
\<close>
lemma Fun_comp [simp]:
assumes "seq g f"
shows "Fun (g \<cdot> f) = restrict (Fun g o Fun f) (set (dom f))"
proof -
have "restrict (img o S (g \<cdot> f) o (inv_into (hom unity (dom (g \<cdot> f))) img))
(set (dom (g \<cdot> f)))
= restrict (Fun g o Fun f) (set (dom f))"
proof -
have 1: "set (dom (g \<cdot> f)) = set (dom f)"
using assms by auto
let ?img' = "\<lambda>a. \<lambda>t. inv_into (hom unity a) img t"
have 2: "\<And>t. t \<in> set (dom (g \<cdot> f)) \<Longrightarrow>
(img o S (g \<cdot> f) o ?img' (dom (g \<cdot> f))) t = (Fun g o Fun f) t"
proof -
fix t
assume "t \<in> set (dom (g \<cdot> f))"
hence t: "t \<in> set (dom f)" by (simp add: 1)
have 3: "\<And>a x. x \<in> hom unity a \<Longrightarrow> ?img' a (img x) = x"
using assms img_mapsto inj_img ide_cod inv_into_f_eq
by (metis arrI in_homE mem_Collect_eq)
have 4: "?img' (dom f) t \<in> hom unity (dom f)"
using assms t inv_into_into [of t img "hom unity (dom f)"] set_def by simp
have "(img o S (g \<cdot> f) o ?img' (dom (g \<cdot> f))) t = img (g \<cdot> f \<cdot> ?img' (dom f) t)"
using assms dom_comp comp_assoc by simp
also have "... = img (g \<cdot> ?img' (dom g) (Fun f t))"
using assms t 3 Fun_def set_def comp_arr_point by auto
also have "... = Fun g (Fun f t)"
proof -
have "Fun f t \<in> img ` hom unity (cod f)"
using assms t Fun_mapsto set_def by fast
thus ?thesis using assms by (auto simp add: set_def Fun_def)
qed
finally show "(img o S (g \<cdot> f) o ?img' (dom (g \<cdot> f))) t = (Fun g o Fun f) t"
by auto
qed
show ?thesis using 1 2 by auto
qed
thus ?thesis using Fun_def by auto
qed
text\<open>
The constructor @{term mkArr} is used to obtain an arrow given subsets
@{term A} and @{term B} of the universe and a function @{term "F \<in> A \<rightarrow> B"}.
\<close>
definition mkArr :: "'s set \<Rightarrow> 's set \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> 's"
where "mkArr A B F = (if A \<subseteq> Univ \<and> B \<subseteq> Univ \<and> F \<in> A \<rightarrow> B
then (THE f. f \<in> hom (mkIde A) (mkIde B) \<and> Fun f = restrict F A)
else null)"
text\<open>
Each function @{term "F \<in> set a \<rightarrow> set b"} determines a unique arrow @{term "f \<in> hom a b"},
such that @{term "Fun f"} is the restriction of @{term F} to @{term "set a"}.
\<close>
lemma fun_complete:
assumes "ide a" and "ide b" and "F \<in> set a \<rightarrow> set b"
shows "\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> Fun f = restrict F (set a)"
proof -
let ?P = "\<lambda>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> Fun f = restrict F (set a)"
show "\<exists>!f. ?P f"
proof
have "\<exists>f. ?P f"
proof -
let ?F' = "\<lambda>x. inv_into (hom unity b) img (F (img x))"
have "?F' \<in> hom unity a \<rightarrow> hom unity b"
proof
fix x
assume x: "x \<in> hom unity a"
have "F (img x) \<in> set b" using assms(3) x set_def by auto
thus "inv_into (hom unity b) img (F (img x)) \<in> hom unity b"
using assms img_mapsto inj_img set_def by auto
qed
hence "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = ?F' x)"
using assms fun_complete1 by force
from this obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = ?F' x)"
by blast
let ?img' = "\<lambda>a. \<lambda>t. inv_into (hom unity a) img t"
have "Fun f = restrict F (set a)"
proof (unfold Fun_def, intro restr_eqI)
show "set (dom f) = set a" using f by auto
show "\<And>t. t \<in> set (dom f) \<Longrightarrow> (img \<circ> S f \<circ> ?img' (dom f)) t = F t"
proof -
fix t
assume t: "t \<in> set (dom f)"
have "(img \<circ> S f \<circ> ?img' (dom f)) t = img (f \<cdot> ?img' (dom f) t)"
by simp
also have "... = img (?F' (?img' (dom f) t))"
proof -
have "?img' (dom f) t \<in> hom unity (dom f)"
using t set_def inv_into_into by metis
thus ?thesis using f by auto
qed
also have "... = img (?img' (cod f) (F t))"
using f t set_def inj_img by auto
also have "... = F t"
proof -
have "F t \<in> set (cod f)"
using assms f t by auto
thus ?thesis
using f t set_def inj_img by auto
qed
finally show "(img \<circ> S f \<circ> ?img' (dom f)) t = F t" by auto
qed
qed
thus ?thesis using f by blast
qed
thus F: "?P (SOME f. ?P f)" using someI_ex [of ?P] by fast
show "\<And>f'. ?P f' \<Longrightarrow> f' = (SOME f. ?P f)"
using F arr_eqI
by (metis (no_types, lifting) in_homE)
qed
qed
lemma mkArr_in_hom:
assumes "A \<subseteq> Univ" and "B \<subseteq> Univ" and "F \<in> A \<rightarrow> B"
shows "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>"
using assms mkArr_def fun_complete [of "mkIde A" "mkIde B" F]
theI' [of "\<lambda>f. f \<in> hom (mkIde A) (mkIde B) \<and> Fun f = restrict F A"]
by simp
text\<open>
The ``only if'' direction of the next lemma can be achieved only if there exists a
non-arrow element of type @{typ 's}, which can be used as the value of @{term "mkArr A B F"}
in cases where @{term "F \<notin> A \<rightarrow> B"}. Nevertheless, it is essential to have this,
because without the ``only if'' direction, we can't derive any useful
consequences from an assumption of the form @{term "arr (mkArr A B F)"};
instead we have to obtain @{term "F \<in> A \<rightarrow> B"} some other way.
This is is usually highly inconvenient and it makes the theory very weak and almost
unusable in practice. The observation that having a non-arrow value of type @{typ 's}
solves this problem is ultimately what led me to incorporate @{term null} first into the
definition of the \<open>set_category\<close> locale and then, ultimately, into the definition
of the \<open>category\<close> locale. I believe this idea is critical to the usability of the
entire development.
\<close>
(* TODO: This gets used as an introduction rule, but the conjunction on the right-hand side
is not very convenient. *)
lemma arr_mkArr [iff]:
shows "arr (mkArr A B F) \<longleftrightarrow> A \<subseteq> Univ \<and> B \<subseteq> Univ \<and> F \<in> A \<rightarrow> B"
proof
show "arr (mkArr A B F) \<Longrightarrow> A \<subseteq> Univ \<and> B \<subseteq> Univ \<and> F \<in> A \<rightarrow> B"
using mkArr_def not_arr_null ex_un_null someI_ex [of "\<lambda>f. \<not>arr f"] by metis
show "A \<subseteq> Univ \<and> B \<subseteq> Univ \<and> F \<in> A \<rightarrow> B \<Longrightarrow> arr (mkArr A B F)"
using mkArr_in_hom by auto
qed
lemma Fun_mkArr':
assumes "arr (mkArr A B F)"
shows "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>"
and "Fun (mkArr A B F) = restrict F A"
proof -
have 1: "A \<subseteq> Univ \<and> B \<subseteq> Univ \<and> F \<in> A \<rightarrow> B" using assms by fast
have 2: "mkArr A B F \<in> hom (mkIde A) (mkIde B) \<and>
Fun (mkArr A B F) = restrict F (set (mkIde A))"
proof -
have "\<exists>!f. f \<in> hom (mkIde A) (mkIde B) \<and> Fun f = restrict F (set (mkIde A))"
using 1 fun_complete [of "mkIde A" "mkIde B" F] by simp
thus ?thesis using 1 mkArr_def theI' by simp
qed
show "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>" using 1 2 by auto
show "Fun (mkArr A B F) = restrict F A" using 1 2 by auto
qed
lemma mkArr_Fun [simp]:
assumes "arr f"
shows "mkArr (set (dom f)) (set (cod f)) (Fun f) = f"
proof -
have 1: "set (dom f) \<subseteq> Univ \<and> set (cod f) \<subseteq> Univ \<and> ide (dom f) \<and> ide (cod f) \<and>
Fun f \<in> extensional (set (dom f)) \<inter> (set (dom f) \<rightarrow> set (cod f))"
using assms Fun_mapsto by force
hence "\<exists>!f'. f' \<in> hom (dom f) (cod f) \<and> Fun f' = restrict (Fun f) (set (dom f))"
using fun_complete by force
moreover have "f \<in> hom (dom f) (cod f) \<and> Fun f = restrict (Fun f) (set (dom f))"
using assms 1 extensional_restrict by force
ultimately have "f = (THE f'. f' \<in> hom (dom f) (cod f) \<and>
Fun f' = restrict (Fun f) (set (dom f)))"
using theI' [of "\<lambda>f'. f' \<in> hom (dom f) (cod f) \<and> Fun f' = restrict (Fun f) (set (dom f))"]
by blast
also have "... = mkArr (set (dom f)) (set (cod f)) (Fun f)"
using assms 1 mkArr_def by simp
finally show ?thesis by auto
qed
lemma dom_mkArr [simp]:
assumes "arr (mkArr A B F)"
shows "dom (mkArr A B F) = mkIde A"
using assms Fun_mkArr' by auto
lemma cod_mkArr [simp]:
assumes "arr (mkArr A B F)"
shows "cod (mkArr A B F) = mkIde B"
using assms Fun_mkArr' by auto
lemma Fun_mkArr [simp]:
assumes "arr (mkArr A B F)"
shows "Fun (mkArr A B F) = restrict F A"
using assms Fun_mkArr' by auto
text\<open>
The following provides the basic technique for showing that arrows
constructed using @{term mkArr} are equal.
\<close>
lemma mkArr_eqI [intro]:
assumes "arr (mkArr A B F)"
and "A = A'" and "B = B'" and "\<And>x. x \<in> A \<Longrightarrow> F x = F' x"
shows "mkArr A B F = mkArr A' B' F'"
using assms arr_mkArr Fun_mkArr
by (intro arr_eqI, auto simp add: Pi_iff)
text\<open>
This version avoids trivial proof obligations when the domain and codomain
sets are identical from the context.
\<close>
lemma mkArr_eqI' [intro]:
assumes "arr (mkArr A B F)" and "\<And>x. x \<in> A \<Longrightarrow> F x = F' x"
shows "mkArr A B F = mkArr A B F'"
using assms mkArr_eqI by simp
lemma mkArr_restrict_eq [simp]:
assumes "arr (mkArr A B F)"
shows "mkArr A B (restrict F A) = mkArr A B F"
using assms by (intro mkArr_eqI', auto)
lemma mkArr_restrict_eq':
assumes "arr (mkArr A B (restrict F A))"
shows "mkArr A B (restrict F A) = mkArr A B F"
using assms by (intro mkArr_eqI', auto)
lemma mkIde_as_mkArr [simp]:
assumes "A \<subseteq> Univ"
shows "mkArr A A (\<lambda>x. x) = mkIde A"
using assms by (intro arr_eqI, auto)
lemma comp_mkArr [simp]:
assumes "arr (mkArr A B F)" and "arr (mkArr B C G)"
shows "mkArr B C G \<cdot> mkArr A B F = mkArr A C (G \<circ> F)"
proof (intro arr_eqI)
have 1: "seq (mkArr B C G) (mkArr A B F)" using assms by force
have 2: "G o F \<in> A \<rightarrow> C" using assms by auto
show "par (mkArr B C G \<cdot> mkArr A B F) (mkArr A C (G \<circ> F))"
using 1 2 by auto
show "Fun (mkArr B C G \<cdot> mkArr A B F) = Fun (mkArr A C (G \<circ> F))"
using 1 2 by fastforce
qed
text\<open>
The locale assumption @{prop stable_img} forces @{term "t \<in> set t"} in case
@{term t} is a terminal object. This is very convenient, as it results in the
characterization of terminal objects as identities @{term t} for which
@{term "set t = {t}"}. However, it is not absolutely necessary to have this.
The following weaker characterization of terminal objects can be proved without
the @{prop stable_img} assumption.
\<close>
lemma terminal_char1:
shows "terminal t \<longleftrightarrow> ide t \<and> (\<exists>!x. x \<in> set t)"
proof -
have "terminal t \<Longrightarrow> ide t \<and> (\<exists>!x. x \<in> set t)"
proof -
assume t: "terminal t"
have "ide t" using t terminal_def by auto
moreover have "\<exists>!x. x \<in> set t"
proof -
have "\<exists>!x. x \<in> hom unity t"
using t terminal_unity terminal_def by auto
thus ?thesis using set_def by auto
qed
ultimately show "ide t \<and> (\<exists>!x. x \<in> set t)" by auto
qed
moreover have "ide t \<and> (\<exists>!x. x \<in> set t) \<Longrightarrow> terminal t"
proof -
assume t: "ide t \<and> (\<exists>!x. x \<in> set t)"
from this obtain t' where "set t = {t'}" by blast
hence t': "set t = {t'} \<and> {t'} \<subseteq> Univ \<and> t = mkIde {t'}"
using t set_subset_Univ mkIde_set by metis
show "terminal t"
proof
show "ide t" using t by simp
show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
proof -
fix a
assume a: "ide a"
show "\<exists>!f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
proof
show 1: "\<guillemotleft>mkArr (set a) {t'} (\<lambda>x. t') : a \<rightarrow> t\<guillemotright>"
using a t t' mkArr_in_hom
by (metis Pi_I' mkIde_set set_subset_Univ singletonD)
show "\<And>f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright> \<Longrightarrow> f = mkArr (set a) {t'} (\<lambda>x. t')"
proof -
fix f
assume f: "\<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
show "f = mkArr (set a) {t'} (\<lambda>x. t')"
proof (intro arr_eqI)
show 1: "par f (mkArr (set a) {t'} (\<lambda>x. t'))" using 1 f in_homE by metis
show "Fun f = Fun (mkArr (set a) {t'} (\<lambda>x. t'))"
proof -
have "Fun (mkArr (set a) {t'} (\<lambda>x. t')) = (\<lambda>x\<in>set a. t')"
using 1 Fun_mkArr by simp
also have "... = Fun f"
proof -
have "\<And>x. x \<in> set a \<Longrightarrow> Fun f x = t'"
using f t' Fun_def mkArr_Fun arr_mkArr
by (metis PiE in_homE singletonD)
moreover have "\<And>x. x \<notin> set a \<Longrightarrow> Fun f x = undefined"
using f Fun_def by auto
ultimately show ?thesis by auto
qed
finally show ?thesis by force
qed
qed
qed
qed
qed
qed
qed
ultimately show ?thesis by blast
qed
text\<open>
As stated above, in the presence of the @{prop stable_img} assumption we have
the following stronger characterization of terminal objects.
\<close>
lemma terminal_char2:
shows "terminal t \<longleftrightarrow> ide t \<and> set t = {t}"
proof
assume t: "terminal t"
show "ide t \<and> set t = {t}"
proof
show "ide t" using t terminal_char1 by auto
show "set t = {t}"
proof -
have "\<exists>!x. x \<in> hom unity t" using t terminal_def terminal_unity by force
moreover have "t \<in> img ` hom unity t" using t stable_img set_def by simp
ultimately show ?thesis using set_def by auto
qed
qed
next
assume "ide t \<and> set t = {t}"
thus "terminal t" using terminal_char1 by force
qed
end
text\<open>
At last, we define the \<open>set_category\<close> locale by existentially quantifying
out the choice of a particular @{term img} map. We need to know that such a map
exists, but it does not matter which one we choose.
\<close>
locale set_category = category S
for S :: "'s comp" (infixr "\<cdot>" 55) +
assumes ex_img: "\<exists>img. set_category_given_img S img"
begin
notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
definition some_img
where "some_img = (SOME img. set_category_given_img S img)"
end
sublocale set_category \<subseteq> set_category_given_img S some_img
proof -
have "\<exists>img. set_category_given_img S img" using ex_img by auto
thus "set_category_given_img S some_img"
using someI_ex [of "\<lambda>img. set_category_given_img S img"] some_img_def
by metis
qed
context set_category
begin
text\<open>
The arbitrary choice of @{term img} induces a system of inclusions,
which are arrows corresponding to inclusions of subsets.
\<close>
definition incl :: "'s \<Rightarrow> bool"
where "incl f = (arr f \<and> set (dom f) \<subseteq> set (cod f) \<and>
f = mkArr (set (dom f)) (set (cod f)) (\<lambda>x. x))"
lemma Fun_incl:
assumes "incl f"
shows "Fun f = (\<lambda>x \<in> set (dom f). x)"
using assms incl_def by (metis Fun_mkArr)
lemma ex_incl_iff_subset:
assumes "ide a" and "ide b"
shows "(\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> incl f) \<longleftrightarrow> set a \<subseteq> set b"
proof
show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> incl f \<Longrightarrow> set a \<subseteq> set b"
using incl_def by auto
show "set a \<subseteq> set b \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> incl f"
proof
assume 1: "set a \<subseteq> set b"
show "\<guillemotleft>mkArr (set a) (set b) (\<lambda>x. x) : a \<rightarrow> b\<guillemotright> \<and> incl (mkArr (set a) (set b) (\<lambda>x. x))"
proof
show "\<guillemotleft>mkArr (set a) (set b) (\<lambda>x. x) : a \<rightarrow> b\<guillemotright>"
proof -
have "(\<lambda>x. x) \<in> set a \<rightarrow> set b" using 1 by auto
thus ?thesis
using assms mkArr_in_hom set_subset_Univ in_homI by auto
qed
thus "incl (mkArr (set a) (set b) (\<lambda>x. x))"
using 1 incl_def by force
qed
qed
qed
end
section "Categoricity"
text\<open>
In this section we show that the \<open>set_category\<close> locale completely characterizes
the structure of its interpretations as categories, in the sense that for any two
interpretations @{term S} and @{term S'}, a bijection between the universe of @{term S}
and the universe of @{term S'} extends to an isomorphism of @{term S} and @{term S'}.
\<close>
locale two_set_categories_bij_betw_Univ =
S: set_category S +
S': set_category S'
for S :: "'s comp" (infixr "\<cdot>" 55)
and S' :: "'t comp" (infixr "\<cdot>\<acute>" 55)
and \<phi> :: "'s \<Rightarrow> 't" +
assumes bij_\<phi>: "bij_betw \<phi> S.Univ S'.Univ"
begin
notation S.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation S'.in_hom ("\<guillemotleft>_ : _ \<rightarrow>' _\<guillemotright>")
abbreviation \<psi>
where "\<psi> \<equiv> inv_into S.Univ \<phi>"
lemma \<psi>_\<phi>:
assumes "t \<in> S.Univ"
shows "\<psi> (\<phi> t) = t"
using assms bij_\<phi> bij_betw_inv_into_left by metis
lemma \<phi>_\<psi>:
assumes "t' \<in> S'.Univ"
shows "\<phi> (\<psi> t') = t'"
using assms bij_\<phi> bij_betw_inv_into_right by metis
lemma \<psi>_img_\<phi>_img:
assumes "A \<subseteq> S.Univ"
shows "\<psi> ` \<phi> ` A = A"
using assms bij_\<phi> by (simp add: bij_betw_def)
lemma \<phi>_img_\<psi>_img:
assumes "A' \<subseteq> S'.Univ"
shows "\<phi> ` \<psi> ` A' = A'"
using assms bij_\<phi> by (simp add: bij_betw_def image_inv_into_cancel)
text\<open>
The object map @{term \<Phi>o} of a functor from @{term[source=true] S}
to @{term[source=true] S'}.
\<close>
definition \<Phi>o
where "\<Phi>o = (\<lambda>a \<in> Collect S.ide. S'.mkIde (\<phi> ` S.set a))"
lemma set_\<Phi>o:
assumes "S.ide a"
shows "S'.set (\<Phi>o a) = \<phi> ` S.set a"
proof -
from assms have "S.set a \<subseteq> S.Univ" by simp
then show ?thesis
using S'.set_mkIde \<Phi>o_def assms bij_\<phi> bij_betw_def image_mono mem_Collect_eq restrict_def
by (metis (no_types, lifting))
qed
lemma \<Phi>o_preserves_ide:
assumes "S.ide a"
shows "S'.ide (\<Phi>o a)"
using assms S'.ide_mkIde S.set_subset_Univ bij_\<phi> bij_betw_def image_mono restrict_apply'
unfolding \<Phi>o_def
by (metis (mono_tags, lifting) mem_Collect_eq)
text\<open>
The map @{term \<Phi>a} assigns to each arrow @{term f} of @{term[source=true] S} the function on
the universe of @{term[source=true] S'} that is the same as the function induced by @{term f}
on the universe of @{term[source=true] S}, up to the bijection @{term \<phi>} between the two
universes.
\<close>
definition \<Phi>a
where "\<Phi>a = (\<lambda>f. \<lambda>x' \<in> \<phi> ` S.set (S.dom f). \<phi> (S.Fun f (\<psi> x')))"
lemma \<Phi>a_mapsto:
assumes "S.arr f"
shows "\<Phi>a f \<in> S'.set (\<Phi>o (S.dom f)) \<rightarrow> S'.set (\<Phi>o (S.cod f))"
proof -
have "\<Phi>a f \<in> \<phi> ` S.set (S.dom f) \<rightarrow> \<phi> ` S.set (S.cod f)"
proof
fix x
assume x: "x \<in> \<phi> ` S.set (S.dom f)"
have "\<psi> x \<in> S.set (S.dom f)"
using assms x \<psi>_img_\<phi>_img [of "S.set (S.dom f)"] S.set_subset_Univ by auto
hence "S.Fun f (\<psi> x) \<in> S.set (S.cod f)" using assms S.Fun_mapsto by auto
hence "\<phi> (S.Fun f (\<psi> x)) \<in> \<phi> ` S.set (S.cod f)" by simp
thus "\<Phi>a f x \<in> \<phi> ` S.set (S.cod f)" using x \<Phi>a_def by auto
qed
thus ?thesis using assms set_\<Phi>o \<Phi>o_preserves_ide by auto
qed
text\<open>
The map @{term \<Phi>a} takes composition of arrows to extensional
composition of functions.
\<close>
lemma \<Phi>a_comp:
assumes gf: "S.seq g f"
shows "\<Phi>a (g \<cdot> f) = restrict (\<Phi>a g o \<Phi>a f) (S'.set (\<Phi>o (S.dom f)))"
proof -
have "\<Phi>a (g \<cdot> f) = (\<lambda>x' \<in> \<phi> ` S.set (S.dom f). \<phi> (S.Fun (S g f) (\<psi> x')))"
using gf \<Phi>a_def by auto
also have "... = (\<lambda>x' \<in> \<phi> ` S.set (S.dom f).
\<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x')))"
using gf set_\<Phi>o S.Fun_comp by simp
also have "... = restrict (\<Phi>a g o \<Phi>a f) (S'.set (\<Phi>o (S.dom f)))"
proof -
have "\<And>x'. x' \<in> \<phi> ` S.set (S.dom f)
\<Longrightarrow> \<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x')) = \<Phi>a g (\<Phi>a f x')"
proof -
fix x'
assume X': "x' \<in> \<phi> ` S.set (S.dom f)"
hence 1: "\<psi> x' \<in> S.set (S.dom f)"
using gf \<psi>_img_\<phi>_img [of "S.set (S.dom f)"] S.set_subset_Univ S.ide_dom by blast
hence "\<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x'))
= \<phi> (S.Fun g (S.Fun f (\<psi> x')))"
using restrict_apply by auto
also have "... = \<phi> (S.Fun g (\<psi> (\<phi> (S.Fun f (\<psi> x')))))"
proof -
have "S.Fun f (\<psi> x') \<in> S.set (S.cod f)"
using gf 1 S.Fun_mapsto by fast
hence "\<psi> (\<phi> (S.Fun f (\<psi> x'))) = S.Fun f (\<psi> x')"
using assms bij_\<phi> S.set_subset_Univ bij_betw_def inv_into_f_f subsetCE S.ide_cod
by (metis S.seqE)
thus ?thesis by auto
qed
also have "... = \<Phi>a g (\<Phi>a f x')"
proof -
have "\<Phi>a f x' \<in> \<phi> ` S.set (S.cod f)"
using gf S.ide_dom S.ide_cod X' \<Phi>a_mapsto [of f] set_\<Phi>o [of "S.dom f"]
set_\<Phi>o [of "S.cod f"]
by blast
thus ?thesis using gf X' \<Phi>a_def by auto
qed
finally show "\<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x')) =
\<Phi>a g (\<Phi>a f x')"
by auto
qed
thus ?thesis using assms set_\<Phi>o by fastforce
qed
finally show ?thesis by auto
qed
text\<open>
Finally, we use @{term \<Phi>o} and @{term \<Phi>a} to define a functor @{term \<Phi>}.
\<close>
definition \<Phi>
where "\<Phi> f = (if S.arr f then
S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod f))) (\<Phi>a f)
else S'.null)"
lemma \<Phi>_in_hom:
assumes "S.arr f"
shows "\<Phi> f \<in> S'.hom (\<Phi>o (S.dom f)) (\<Phi>o (S.cod f))"
proof -
have "\<guillemotleft>\<Phi> f : S'.dom (\<Phi> f) \<rightarrow>' S'.cod (\<Phi> f)\<guillemotright>"
using assms \<Phi>_def \<Phi>a_mapsto \<Phi>o_preserves_ide
by (intro S'.in_homI, auto)
thus ?thesis
using assms \<Phi>_def \<Phi>a_mapsto \<Phi>o_preserves_ide by auto
qed
lemma \<Phi>_ide [simp]:
assumes "S.ide a"
shows "\<Phi> a = \<Phi>o a"
proof -
have "\<Phi> a = S'.mkArr (S'.set (\<Phi>o a)) (S'.set (\<Phi>o a)) (\<lambda>x'. x')"
proof -
have "\<guillemotleft>\<Phi> a : \<Phi>o a \<rightarrow>' \<Phi>o a\<guillemotright>"
using assms \<Phi>_in_hom S.ide_in_hom by fastforce
moreover have "\<Phi>a a = restrict (\<lambda>x'. x') (S'.set (\<Phi>o a))"
proof -
have "\<Phi>a a = (\<lambda>x' \<in> \<phi> ` S.set a. \<phi> (S.Fun a (\<psi> x')))"
using assms \<Phi>a_def restrict_apply by auto
also have "... = (\<lambda>x' \<in> S'.set (\<Phi>o a). \<phi> (\<psi> x'))"
proof -
have "S.Fun a = (\<lambda>x \<in> S.set a. x)" using assms S.Fun_ide by simp
moreover have "\<And>x'. x' \<in> \<phi> ` S.set a \<Longrightarrow> \<psi> x' \<in> S.set a"
using assms bij_\<phi> S.set_subset_Univ image_iff by (metis \<psi>_img_\<phi>_img)
ultimately show ?thesis
using assms set_\<Phi>o by auto
qed
also have "... = restrict (\<lambda>x'. x') (S'.set (\<Phi>o a))"
using assms S'.set_subset_Univ \<Phi>o_preserves_ide \<phi>_\<psi>
by (meson restr_eqI subsetCE)
ultimately show ?thesis by auto
qed
ultimately show ?thesis
using assms \<Phi>_def \<Phi>o_preserves_ide S'.mkArr_restrict_eq'
by (metis S'.arrI S.ide_char)
qed
thus ?thesis
using assms S'.mkIde_as_mkArr \<Phi>o_preserves_ide \<Phi>_in_hom by simp
qed
lemma set_dom_\<Phi>:
assumes "S.arr f"
shows "S'.set (S'.dom (\<Phi> f)) = \<phi> ` (S.set (S.dom f))"
using assms S.ide_dom \<Phi>_in_hom \<Phi>_ide set_\<Phi>o by fastforce
lemma \<Phi>_comp:
assumes "S.seq g f"
shows "\<Phi> (g \<cdot> f) = \<Phi> g \<cdot>\<acute> \<Phi> f"
proof -
have "\<Phi> (g \<cdot> f) = S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a (S g f))"
using \<Phi>_def assms by auto
also have "... = S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g)))
(restrict (\<Phi>a g o \<Phi>a f) (S'.set (\<Phi>o (S.dom f))))"
using assms \<Phi>a_comp set_\<Phi>o by force
also have "... = S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a g o \<Phi>a f)"
proof -
have "S'.arr (S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a g o \<Phi>a f))"
using assms \<Phi>a_mapsto [of f] \<Phi>a_mapsto [of g] \<Phi>o_preserves_ide S'.arr_mkArr
by (elim S.seqE, auto)
thus ?thesis
using assms S'.mkArr_restrict_eq by auto
qed
also have "... = S' (S'.mkArr (S'.set (\<Phi>o (S.dom g))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a g))
(S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod f))) (\<Phi>a f))"
proof -
have "S'.arr (S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod f))) (\<Phi>a f))"
using assms \<Phi>a_mapsto set_\<Phi>o S.ide_dom S.ide_cod \<Phi>o_preserves_ide
S'.arr_mkArr S'.set_subset_Univ S.seqE
by metis
moreover have "S'.arr (S'.mkArr (S'.set (\<Phi>o (S.dom g))) (S'.set (\<Phi>o (S.cod g)))
(\<Phi>a g))"
using assms \<Phi>a_mapsto set_\<Phi>o S.ide_dom S.ide_cod \<Phi>o_preserves_ide S'.arr_mkArr
S'.set_subset_Univ S.seqE
by metis
ultimately show ?thesis using assms S'.comp_mkArr by force
qed
also have "... = \<Phi> g \<cdot>\<acute> \<Phi> f" using assms \<Phi>_def by force
finally show ?thesis by fast
qed
interpretation \<Phi>: "functor" S S' \<Phi>
apply unfold_locales
using \<Phi>_def
apply simp
using \<Phi>_in_hom \<Phi>_comp
by auto
lemma \<Phi>_is_functor:
shows "functor S S' \<Phi>" ..
lemma Fun_\<Phi>:
assumes "S.arr f" and "x \<in> S.set (S.dom f)"
shows "S'.Fun (\<Phi> f) (\<phi> x) = \<Phi>a f (\<phi> x)"
using assms \<Phi>_def \<Phi>.preserves_arr set_\<Phi>o by auto
lemma \<Phi>_acts_elementwise:
assumes "S.ide a"
shows "S'.set (\<Phi> a) = \<Phi> ` S.set a"
proof
have 0: "S'.set (\<Phi> a) = \<phi> ` S.set a"
using assms \<Phi>_ide set_\<Phi>o by simp
have 1: "\<And>x. x \<in> S.set a \<Longrightarrow> \<Phi> x = \<phi> x"
proof -
fix x
assume x: "x \<in> S.set a"
have 1: "S.terminal x" using assms x S.set_subset_Univ by blast
hence 2: "S'.terminal (\<phi> x)"
by (metis CollectD CollectI bij_\<phi> bij_betw_def image_iff)
have "\<Phi> x = \<Phi>o x"
using assms x 1 \<Phi>_ide S.terminal_def by auto
also have "... = \<phi> x"
proof -
have "\<Phi>o x = S'.mkIde (\<phi> ` S.set x)"
using assms 1 x \<Phi>o_def S.terminal_def by auto
moreover have "S'.mkIde (\<phi> ` S.set x) = \<phi> x"
using assms x 1 2 S.terminal_char2 S'.terminal_char2 S'.mkIde_set bij_\<phi>
by (metis image_empty image_insert)
ultimately show ?thesis by auto
qed
finally show "\<Phi> x = \<phi> x" by auto
qed
show "S'.set (\<Phi> a) \<subseteq> \<Phi> ` S.set a" using 0 1 by force
show "\<Phi> ` S.set a \<subseteq> S'.set (\<Phi> a)" using 0 1 by force
qed
lemma \<Phi>_preserves_incl:
assumes "S.incl m"
shows "S'.incl (\<Phi> m)"
proof -
have 1: "S.arr m \<and> S.set (S.dom m) \<subseteq> S.set (S.cod m) \<and>
m = S.mkArr (S.set (S.dom m)) (S.set (S.cod m)) (\<lambda>x. x)"
using assms S.incl_def by blast
have "S'.arr (\<Phi> m)" using 1 by auto
moreover have 2: "S'.set (S'.dom (\<Phi> m)) \<subseteq> S'.set (S'.cod (\<Phi> m))"
using 1 \<Phi>.preserves_dom \<Phi>.preserves_cod \<Phi>_acts_elementwise
by (metis (full_types) S.ide_cod S.ide_dom image_mono)
moreover have "\<Phi> m =
S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<lambda>x'. x')"
proof -
have "\<Phi> m = S'.mkArr (S'.set (\<Phi>o (S.dom m))) (S'.set (\<Phi>o (S.cod m))) (\<Phi>a m)"
using 1 \<Phi>_def by simp
also have "... = S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<Phi>a m)"
using 1 \<Phi>_ide by auto
finally have 3: "\<Phi> m =
S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<Phi>a m)"
by auto
also have "... = S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<lambda>x'. x')"
proof -
have 4: "S.Fun m = restrict (\<lambda>x. x) (S.set (S.dom m))"
using assms S.incl_def by (metis (full_types) S.Fun_mkArr)
hence "\<Phi>a m = restrict (\<lambda>x'. x') (\<phi> ` (S.set (S.dom m)))"
proof -
have 5: "\<And>x'. x' \<in> \<phi> ` S.set (S.dom m) \<Longrightarrow> \<phi> (\<psi> x') = x'"
using 1 bij_\<phi> bij_betw_def S'.set_subset_Univ S.ide_dom \<Phi>o_preserves_ide
f_inv_into_f set_\<Phi>o
by (metis subsetCE)
have "\<Phi>a m = restrict (\<lambda>x'. \<phi> (S.Fun m (\<psi> x'))) (\<phi> ` S.set (S.dom m))"
using \<Phi>a_def by simp
also have "... = restrict (\<lambda>x'. x') (\<phi> ` S.set (S.dom m))"
proof -
have "\<And>x. x \<in> \<phi> ` (S.set (S.dom m)) \<Longrightarrow> \<phi> (S.Fun m (\<psi> x)) = x"
proof -
fix x
assume x: "x \<in> \<phi> ` (S.set (S.dom m))"
hence "\<psi> x \<in> S.set (S.dom m)"
using 1 S.ide_dom S.set_subset_Univ \<psi>_img_\<phi>_img image_eqI by metis
thus "\<phi> (S.Fun m (\<psi> x)) = x" using 1 4 5 x by simp
qed
thus ?thesis by auto
qed
finally show ?thesis by auto
qed
hence "\<Phi>a m = restrict (\<lambda>x'. x') (S'.set (S'.dom (\<Phi> m)))"
using 1 set_dom_\<Phi> by auto
thus ?thesis
using 2 3 \<open>S'.arr (\<Phi> m)\<close> S'.mkArr_restrict_eq S'.ide_cod S'.ide_dom S'.incl_def
by (metis S'.arr_mkArr image_restrict_eq image_subset_iff_funcset)
qed
finally show ?thesis by auto
qed
ultimately show ?thesis using S'.incl_def by blast
qed
text\<open>
Interchange the role of @{term \<phi>} and @{term \<psi>} to obtain a functor \<open>\<Psi>\<close>
from @{term[source=true] S'} to @{term[source=true] S}.
\<close>
interpretation INV: two_set_categories_bij_betw_Univ S' S \<psi>
apply unfold_locales by (simp add: bij_\<phi> bij_betw_inv_into)
abbreviation \<Psi>o
where "\<Psi>o \<equiv> INV.\<Phi>o"
abbreviation \<Psi>a
where "\<Psi>a \<equiv> INV.\<Phi>a"
abbreviation \<Psi>
where "\<Psi> \<equiv> INV.\<Phi>"
interpretation \<Psi>: "functor" S' S \<Psi>
using INV.\<Phi>_is_functor by auto
text\<open>
The functors @{term \<Phi>} and @{term \<Psi>} are inverses.
\<close>
lemma Fun_\<Psi>:
assumes "S'.arr f'" and "x' \<in> S'.set (S'.dom f')"
shows "S.Fun (\<Psi> f') (\<psi> x') = \<Psi>a f' (\<psi> x')"
using assms INV.Fun_\<Phi> by blast
lemma \<Psi>o_\<Phi>o:
assumes "S.ide a"
shows "\<Psi>o (\<Phi>o a) = a"
using assms \<Phi>o_def INV.\<Phi>o_def \<psi>_img_\<phi>_img \<Phi>o_preserves_ide set_\<Phi>o by force
lemma \<Phi>\<Psi>:
assumes "S.arr f"
shows "\<Psi> (\<Phi> f) = f"
proof (intro S.arr_eqI)
show par: "S.par (\<Psi> (\<Phi> f)) f"
using assms \<Phi>o_preserves_ide \<Psi>o_\<Phi>o by auto
show "S.Fun (\<Psi> (\<Phi> f)) = S.Fun f"
proof -
have "S.arr (\<Psi> (\<Phi> f))" using assms by auto
moreover have "\<Psi> (\<Phi> f) = S.mkArr (S.set (S.dom f)) (S.set (S.cod f)) (\<Psi>a (\<Phi> f))"
using assms INV.\<Phi>_def \<Phi>_in_hom \<Psi>o_\<Phi>o by auto
moreover have "\<Psi>a (\<Phi> f) = (\<lambda>x \<in> S.set (S.dom f). \<psi> (S'.Fun (\<Phi> f) (\<phi> x)))"
proof -
have "\<Psi>a (\<Phi> f) = (\<lambda>x \<in> \<psi> ` S'.set (S'.dom (\<Phi> f)). \<psi> (S'.Fun (\<Phi> f) (\<phi> x)))"
proof -
have "\<And>x. x \<in> \<psi> ` S'.set (S'.dom (\<Phi> f)) \<Longrightarrow> INV.\<psi> x = \<phi> x"
using assms S.ide_dom S.set_subset_Univ \<Psi>.preserves_reflects_arr par bij_\<phi>
inv_into_inv_into_eq subsetCE INV.set_dom_\<Phi>
by metis
thus ?thesis
using INV.\<Phi>a_def by auto
qed
moreover have "\<psi> ` S'.set (S'.dom (\<Phi> f)) = S.set (S.dom f)"
using assms by (metis par \<Psi>.preserves_reflects_arr INV.set_dom_\<Phi>)
ultimately show ?thesis by auto
qed
ultimately have 1: "S.Fun (\<Psi> (\<Phi> f)) = (\<lambda>x \<in> S.set (S.dom f). \<psi> (S'.Fun (\<Phi> f) (\<phi> x)))"
using S'.Fun_mkArr by simp
show ?thesis
proof
fix x
have "x \<notin> S.set (S.dom f) \<Longrightarrow> S.Fun (\<Psi> (\<Phi> f)) x = S.Fun f x"
using 1 assms extensional_def S.Fun_mapsto S.Fun_def by auto
moreover have "x \<in> S.set (S.dom f) \<Longrightarrow> S.Fun (\<Psi> (\<Phi> f)) x = S.Fun f x"
proof -
assume x: "x \<in> S.set (S.dom f)"
have "S.Fun (\<Psi> (\<Phi> f)) x = \<psi> (\<phi> (S.Fun f (\<psi> (\<phi> x))))"
using assms x 1 Fun_\<Phi> bij_\<phi> \<Phi>a_def by auto
also have "... = S.Fun f x"
proof -
have 2: "\<And>x. x \<in> S.Univ \<Longrightarrow> \<psi> (\<phi> x) = x"
using bij_\<phi> bij_betw_inv_into_left by fast
have "S.Fun f (\<psi> (\<phi> x)) = S.Fun f x"
using assms x 2
by (metis S.ide_dom S.set_subset_Univ subsetCE)
moreover have "S.Fun f x \<in> S.Univ"
using x assms S.Fun_mapsto S.set_subset_Univ S.ide_cod by blast
ultimately show ?thesis using 2 by auto
qed
finally show ?thesis by auto
qed
ultimately show "S.Fun (\<Psi> (\<Phi> f)) x = S.Fun f x" by auto
qed
qed
qed
lemma \<Phi>o_\<Psi>o:
assumes "S'.ide a'"
shows "\<Phi>o (\<Psi>o a') = a'"
using assms \<Phi>o_def INV.\<Phi>o_def \<phi>_img_\<psi>_img INV.\<Phi>o_preserves_ide \<psi>_\<phi> INV.set_\<Phi>o
by force
lemma \<Psi>\<Phi>:
assumes "S'.arr f'"
shows "\<Phi> (\<Psi> f') = f'"
proof (intro S'.arr_eqI)
show par: "S'.par (\<Phi> (\<Psi> f')) f'"
using assms \<Phi>.preserves_ide \<Psi>.preserves_ide \<Phi>_ide INV.\<Phi>_ide \<Phi>o_\<Psi>o by auto
show "S'.Fun (\<Phi> (\<Psi> f')) = S'.Fun f'"
proof -
have "S'.arr (\<Phi> (\<Psi> f'))" using assms by blast
moreover have "\<Phi> (\<Psi> f') =
S'.mkArr (S'.set (S'.dom f')) (S'.set (S'.cod f')) (\<Phi>a (\<Psi> f'))"
using assms \<Phi>_def INV.\<Phi>_in_hom \<Phi>o_\<Psi>o by simp
moreover have "\<Phi>a (\<Psi> f') = (\<lambda>x' \<in> S'.set (S'.dom f'). \<phi> (S.Fun (\<Psi> f') (\<psi> x')))"
unfolding \<Phi>a_def
using assms par \<Psi>.preserves_arr set_dom_\<Phi> by metis
ultimately have 1: "S'.Fun (\<Phi> (\<Psi> f')) =
(\<lambda>x' \<in> S'.set (S'.dom f'). \<phi> (S.Fun (\<Psi> f') (\<psi> x')))"
using S'.Fun_mkArr by simp
show ?thesis
proof
fix x'
have "x' \<notin> S'.set (S'.dom f') \<Longrightarrow> S'.Fun (\<Phi> (\<Psi> f')) x' = S'.Fun f' x'"
using 1 assms S'.Fun_mapsto extensional_def by (simp add: S'.Fun_def)
moreover have "x' \<in> S'.set (S'.dom f') \<Longrightarrow> S'.Fun (\<Phi> (\<Psi> f')) x' = S'.Fun f' x'"
proof -
assume x': "x' \<in> S'.set (S'.dom f')"
have "S'.Fun (\<Phi> (\<Psi> f')) x' = \<phi> (S.Fun (\<Psi> f') (\<psi> x'))"
using x' 1 by auto
also have "... = \<phi> (\<Psi>a f' (\<psi> x'))"
using Fun_\<Psi> x' assms S'.set_subset_Univ bij_\<phi> by metis
also have "... = \<phi> (\<psi> (S'.Fun f' (\<phi> (\<psi> x'))))"
proof -
have "\<phi> (\<Psi>a f' (\<psi> x')) = \<phi> (\<psi> (S'.Fun f' x'))"
proof -
have "x' \<in> S'.Univ"
by (meson S'.ide_dom S'.set_subset_Univ assms subsetCE x')
thus ?thesis
by (simp add: INV.\<Phi>a_def INV.\<psi>_\<phi> x')
qed
also have "... = \<phi> (\<psi> (S'.Fun f' (\<phi> (\<psi> x'))))"
using assms x' \<phi>_\<psi> S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
finally show ?thesis by auto
qed
also have "... = S'.Fun f' x'"
proof -
have 2: "\<And>x'. x' \<in> S'.Univ \<Longrightarrow> \<phi> (\<psi> x') = x'"
using bij_\<phi> bij_betw_inv_into_right by fast
have "S'.Fun f' (\<phi> (\<psi> x')) = S'.Fun f' x'"
using assms x' 2 S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
moreover have "S'.Fun f' x' \<in> S'.Univ"
using x' assms S'.Fun_mapsto S'.set_subset_Univ S'.ide_cod by blast
ultimately show ?thesis using 2 by auto
qed
finally show ?thesis by auto
qed
ultimately show "S'.Fun (\<Phi> (\<Psi> f')) x' = S'.Fun f' x'" by auto
qed
qed
qed
lemma inverse_functors_\<Phi>_\<Psi>:
shows "inverse_functors S S' \<Phi> \<Psi>"
proof -
interpret \<Phi>\<Psi>: composite_functor S S' S \<Phi> \<Psi> ..
have inv: "\<Psi> o \<Phi> = S.map"
using \<Phi>\<Psi> S.map_def \<Phi>\<Psi>.is_extensional by auto
interpret \<Psi>\<Phi>: composite_functor S' S S' \<Psi> \<Phi> ..
have inv': "\<Phi> o \<Psi> = S'.map"
using \<Psi>\<Phi> S'.map_def \<Psi>\<Phi>.is_extensional by auto
show ?thesis
using inv inv' by (unfold_locales, auto)
qed
lemma are_isomorphic:
shows "\<exists>\<Phi>. invertible_functor S S' \<Phi> \<and> (\<forall>m. S.incl m \<longrightarrow> S'.incl (\<Phi> m))"
proof -
interpret inverse_functors S S' \<Phi> \<Psi>
using inverse_functors_\<Phi>_\<Psi> by auto
have 1: "inverse_functors S S' \<Phi> \<Psi>" ..
interpret invertible_functor S S' \<Phi>
apply unfold_locales using 1 by auto
have "invertible_functor S S' \<Phi>" ..
thus ?thesis using \<Phi>_preserves_incl by auto
qed
end
(*
* The main result: set_category is categorical, in the following (logical) sense:
* If S and S' are two "set categories", and if the sets of terminal objects of S and S'
* are in bijective correspondence, then S and S' are isomorphic as categories,
* via a functor that preserves inclusion maps, hence the inclusion relation between sets.
*)
theorem set_category_is_categorical:
assumes "set_category S" and "set_category S'"
and "bij_betw \<phi> (set_category_data.Univ S) (set_category_data.Univ S')"
shows "\<exists>\<Phi>. invertible_functor S S' \<Phi> \<and>
(\<forall>m. set_category.incl S m \<longrightarrow> set_category.incl S' (\<Phi> m))"
proof -
interpret S: set_category S using assms(1) by auto
interpret S': set_category S' using assms(2) by auto
interpret two_set_categories_bij_betw_Univ S S' \<phi>
apply (unfold_locales) using assms(3) by auto
show ?thesis using are_isomorphic by auto
qed
section "Further Properties of Set Categories"
text\<open>
In this section we further develop the consequences of the \<open>set_category\<close>
axioms, and establish characterizations of a number of standard category-theoretic
notions for a \<open>set_category\<close>.
\<close>
context set_category
begin
abbreviation Dom
where "Dom f \<equiv> set (dom f)"
abbreviation Cod
where "Cod f \<equiv> set (cod f)"
subsection "Initial Object"
text\<open>
The object corresponding to the empty set is an initial object.
\<close>
definition empty
where "empty = mkIde {}"
lemma initial_empty:
shows "initial empty"
proof
show 0: "ide empty" using empty_def by auto
show "\<And>b. ide b \<Longrightarrow> \<exists>!f. \<guillemotleft>f : empty \<rightarrow> b\<guillemotright>"
proof -
fix b
assume b: "ide b"
show "\<exists>!f. \<guillemotleft>f : empty \<rightarrow> b\<guillemotright>"
proof
show 1: "\<guillemotleft>mkArr {} (set b) (\<lambda>x. x) : empty \<rightarrow> b\<guillemotright>"
using b empty_def mkArr_in_hom mkIde_set set_subset_Univ
by (metis 0 Pi_empty UNIV_I arr_mkIde)
show "\<And>f. \<guillemotleft>f : empty \<rightarrow> b\<guillemotright> \<Longrightarrow> f = mkArr {} (set b) (\<lambda>x. x)"
proof -
fix f
assume f: "\<guillemotleft>f : empty \<rightarrow> b\<guillemotright>"
show "f = mkArr {} (set b) (\<lambda>x. x)"
proof (intro arr_eqI)
show 1: "par f (mkArr {} (set b) (\<lambda>x. x))"
using 1 f by force
show "Fun f = Fun (mkArr {} (set b) (\<lambda>x. x))"
using empty_def 1 f Fun_mapsto by fastforce
qed
qed
qed
qed
qed
subsection "Identity Arrows"
text\<open>
Identity arrows correspond to restrictions of the identity function.
\<close>
lemma ide_char:
assumes "arr f"
shows "ide f \<longleftrightarrow> Dom f = Cod f \<and> Fun f = (\<lambda>x \<in> Dom f. x)"
using assms mkIde_as_mkArr mkArr_Fun Fun_ide in_homE ide_cod mkArr_Fun mkIde_set
by (metis ide_char)
lemma ideI:
assumes "arr f" and "Dom f = Cod f" and "\<And>x. x \<in> Dom f \<Longrightarrow> Fun f x = x"
shows "ide f"
proof -
have "Fun f = (\<lambda>x \<in> Dom f. x)"
using assms Fun_def by auto
thus ?thesis using assms ide_char by blast
qed
subsection "Inclusions"
lemma ide_implies_incl:
assumes "ide a"
shows "incl a"
proof -
have "arr a \<and> Dom a \<subseteq> Cod a" using assms by auto
moreover have "a = mkArr (Dom a) (Cod a) (\<lambda>x. x)"
using assms by simp
ultimately show ?thesis using incl_def by simp
qed
definition incl_in :: "'s \<Rightarrow> 's \<Rightarrow> bool"
where "incl_in a b = (ide a \<and> ide b \<and> set a \<subseteq> set b)"
abbreviation incl_of
where "incl_of a b \<equiv> mkArr (set a) (set b) (\<lambda>x. x)"
lemma elem_set_implies_set_eq_singleton:
assumes "a \<in> set b"
shows "set a = {a}"
proof -
have "ide b" using assms set_def by auto
thus ?thesis using assms set_subset_Univ terminal_char2
by (metis mem_Collect_eq subsetCE)
qed
lemma elem_set_implies_incl_in:
assumes "a \<in> set b"
shows "incl_in a b"
proof -
have b: "ide b" using assms set_def by auto
hence "set b \<subseteq> Univ" by simp
hence "a \<in> Univ \<and> set a \<subseteq> set b"
using assms elem_set_implies_set_eq_singleton by auto
hence "ide a \<and> set a \<subseteq> set b"
using b terminal_char1 by simp
thus ?thesis using b incl_in_def by simp
qed
lemma incl_incl_of [simp]:
assumes "incl_in a b"
shows "incl (incl_of a b)"
and "\<guillemotleft>incl_of a b : a \<rightarrow> b\<guillemotright>"
proof -
show "\<guillemotleft>incl_of a b : a \<rightarrow> b\<guillemotright>"
using assms incl_in_def mkArr_in_hom
by (metis image_ident image_subset_iff_funcset mkIde_set set_subset_Univ)
thus "incl (incl_of a b)"
using assms incl_def incl_in_def by fastforce
qed
text\<open>
There is at most one inclusion between any pair of objects.
\<close>
lemma incls_coherent:
assumes "par f f'" and "incl f" and "incl f'"
shows "f = f'"
using assms incl_def fun_complete by auto
text\<open>
The set of inclusions is closed under composition.
\<close>
lemma incl_comp [simp]:
assumes "incl f" and "incl g" and "cod f = dom g"
shows "incl (g \<cdot> f)"
proof -
have 1: "seq g f" using assms incl_def by auto
moreover have "Dom (g \<cdot> f) \<subseteq> Cod (g \<cdot> f)"
using assms 1 incl_def by auto
moreover have "g \<cdot> f = mkArr (Dom f) (Cod g) (restrict (\<lambda>x. x) (Dom f))"
using assms 1 Fun_comp incl_def Fun_mkArr mkArr_Fun Fun_ide comp_cod_arr
ide_dom dom_comp cod_comp
by metis
ultimately show ?thesis using incl_def by force
qed
subsection "Image Factorization"
text\<open>
The image of an arrow is the object that corresponds to the set-theoretic
image of the domain set under the function induced by the arrow.
\<close>
abbreviation Img
where "Img f \<equiv> Fun f ` Dom f"
definition img
where "img f = mkIde (Img f)"
lemma ide_img [simp]:
assumes "arr f"
shows "ide (img f)"
proof -
have "Fun f ` Dom f \<subseteq> Cod f" using assms Fun_mapsto by blast
moreover have "Cod f \<subseteq> Univ" using assms by simp
ultimately show ?thesis using img_def by simp
qed
lemma set_img [simp]:
assumes "arr f"
shows "set (img f) = Img f"
proof -
have "Fun f ` set (dom f) \<subseteq> set (cod f) \<and> set (cod f) \<subseteq> Univ"
using assms Fun_mapsto by auto
hence "Fun f ` set (dom f) \<subseteq> Univ" by auto
thus ?thesis using assms img_def set_mkIde by auto
qed
lemma img_point_in_Univ:
assumes "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
shows "img x \<in> Univ"
proof -
have "set (img x) = {Fun x unity}"
using assms img_def terminal_unity terminal_char2
image_empty image_insert mem_Collect_eq set_img
by force
thus "img x \<in> Univ" using assms terminal_char1 by auto
qed
lemma incl_in_img_cod:
assumes "arr f"
shows "incl_in (img f) (cod f)"
proof (unfold img_def)
have 1: "Img f \<subseteq> Cod f \<and> Cod f \<subseteq> Univ"
using assms Fun_mapsto by auto
hence 2: "ide (mkIde (Img f))" by fastforce
moreover have "ide (cod f)" using assms by auto
moreover have "set (mkIde (Img f)) \<subseteq> Cod f"
using 1 2 by force
ultimately show "incl_in (mkIde (Img f)) (cod f)"
using incl_in_def by blast
qed
lemma img_point_elem_set:
assumes "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
shows "img x \<in> set a"
proof -
have "incl_in (img x) a"
using assms incl_in_img_cod by auto
hence "set (img x) \<subseteq> set a"
using incl_in_def by blast
moreover have "img x \<in> set (img x)"
using assms img_point_in_Univ terminal_char2 by simp
ultimately show ?thesis by auto
qed
text\<open>
The corestriction of an arrow @{term f} is the arrow
@{term "corestr f \<in> hom (dom f) (img f)"} that induces the same function
on the universe as @{term f}.
\<close>
definition corestr
where "corestr f = mkArr (Dom f) (Img f) (Fun f)"
lemma corestr_in_hom:
assumes "arr f"
shows "\<guillemotleft>corestr f : dom f \<rightarrow> img f\<guillemotright>"
proof -
have "Fun f \<in> Dom f \<rightarrow> Fun f ` Dom f \<and> Dom f \<subseteq> Univ"
using assms by auto
moreover have "Fun f ` Dom f \<subseteq> Univ"
proof -
have "Fun f ` Dom f \<subseteq> Cod f \<and> Cod f \<subseteq> Univ"
using assms Fun_mapsto by auto
thus ?thesis by blast
qed
ultimately have "mkArr (Dom f) (Fun f ` Dom f) (Fun f) \<in> hom (dom f) (img f)"
using assms img_def mkArr_in_hom [of "Dom f" "Fun f ` Dom f" "Fun f"] by simp
thus ?thesis using corestr_def by fastforce
qed
text\<open>
Every arrow factors as a corestriction followed by an inclusion.
\<close>
lemma img_fact:
assumes "arr f"
shows "S (incl_of (img f) (cod f)) (corestr f) = f"
proof (intro arr_eqI)
have 1: "\<guillemotleft>corestr f : dom f \<rightarrow> img f\<guillemotright>"
using assms corestr_in_hom by blast
moreover have 2: "\<guillemotleft>incl_of (img f) (cod f) : img f \<rightarrow> cod f\<guillemotright>"
using assms incl_in_img_cod incl_incl_of by fast
ultimately show P: "par (incl_of (img f) (cod f) \<cdot> corestr f) f"
using assms in_homE by blast
show "Fun (incl_of (img f) (cod f) \<cdot> corestr f) = Fun f"
proof -
have "Fun (incl_of (img f) (cod f) \<cdot> corestr f)
= restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
using Fun_comp 1 2 P by auto
also have
"... = restrict (restrict (\<lambda>x. x) (Img f) o restrict (Fun f) (Dom f)) (Dom f)"
proof -
have "Fun (corestr f) = restrict (Fun f) (Dom f)"
using assms corestr_def Fun_mkArr corestr_in_hom by force
moreover have "Fun (incl_of (img f) (cod f)) = restrict (\<lambda>x. x) (Img f)"
proof -
have "arr (incl_of (img f) (cod f))" using incl_incl_of P by blast
moreover have "incl_of (img f) (cod f) = mkArr (Img f) (Cod f) (\<lambda>x. x)"
using assms by fastforce
ultimately show ?thesis using assms img_def Fun_mkArr by metis
qed
ultimately show ?thesis by argo
qed
also have "... = Fun f"
proof
fix x
show "restrict (restrict (\<lambda>x. x) (Img f) o restrict (Fun f) (Dom f)) (Dom f) x = Fun f x"
using assms extensional_restrict Fun_mapsto extensional_arb [of "Fun f" "Dom f" x]
by (cases "x \<in> Dom f", auto)
qed
finally show ?thesis by auto
qed
qed
lemma Fun_corestr:
assumes "arr f"
shows "Fun (corestr f) = Fun f"
proof -
have 1: "f = incl_of (img f) (cod f) \<cdot> corestr f"
using assms img_fact by auto
hence 2: "Fun f = restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
using assms by (metis Fun_comp dom_comp)
also have "... = restrict (Fun (corestr f)) (Dom f)"
using assms by (metis 1 2 Fun_mkArr seqE mkArr_Fun corestr_def)
also have "... = Fun (corestr f)"
using assms 1 by (metis Fun_def dom_comp extensional_restrict restrict_extensional)
finally show ?thesis by auto
qed
subsection "Points and Terminal Objects"
text\<open>
To each element @{term t} of @{term "set a"} is associated a point
@{term "mkPoint a t \<in> hom unity a"}. The function induced by such
a point is the constant-@{term t} function on the set @{term "{unity}"}.
\<close>
definition mkPoint
where "mkPoint a t \<equiv> mkArr {unity} (set a) (\<lambda>_. t)"
lemma mkPoint_in_hom:
assumes "ide a" and "t \<in> set a"
shows "\<guillemotleft>mkPoint a t : unity \<rightarrow> a\<guillemotright>"
using assms mkArr_in_hom
by (metis Pi_I mkIde_set set_subset_Univ terminal_char2 terminal_unity mkPoint_def)
lemma Fun_mkPoint:
assumes "ide a" and "t \<in> set a"
shows "Fun (mkPoint a t) = (\<lambda>_ \<in> {unity}. t)"
using assms mkPoint_def terminal_unity by force
text\<open>
For each object @{term a} the function @{term "mkPoint a"} has as its inverse
the restriction of the function @{term img} to @{term "hom unity a"}
\<close>
lemma mkPoint_img:
shows "img \<in> hom unity a \<rightarrow> set a"
and "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkPoint a (img x) = x"
proof -
show "img \<in> hom unity a \<rightarrow> set a"
using img_point_elem_set by simp
show "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkPoint a (img x) = x"
proof -
fix x
assume x: "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
show "mkPoint a (img x) = x"
proof (intro arr_eqI)
have 0: "img x \<in> set a"
using x img_point_elem_set by metis
hence 1: "mkPoint a (img x) \<in> hom unity a"
using x mkPoint_in_hom by force
thus 2: "par (mkPoint a (img x)) x"
using x by fastforce
have "Fun (mkPoint a (img x)) = (\<lambda>_ \<in> {unity}. img x)"
using 1 mkPoint_def by auto
also have "... = Fun x"
proof
fix z
have "z \<noteq> unity \<Longrightarrow> (\<lambda>_ \<in> {unity}. img x) z = Fun x z"
using x Fun_mapsto Fun_def restrict_apply singletonD terminal_char2 terminal_unity
by auto
moreover have "(\<lambda>_ \<in> {unity}. img x) unity = Fun x unity"
using x 0 elem_set_implies_set_eq_singleton set_img terminal_char2 terminal_unity
by (metis 2 image_insert in_homE restrict_apply singletonI singleton_insert_inj_eq)
ultimately show "(\<lambda>_ \<in> {unity}. img x) z = Fun x z" by auto
qed
finally show "Fun (mkPoint a (img x)) = Fun x" by auto
qed
qed
qed
lemma img_mkPoint:
assumes "ide a"
shows "mkPoint a \<in> set a \<rightarrow> hom unity a"
and "\<And>t. t \<in> set a \<Longrightarrow> img (mkPoint a t) = t"
proof -
show "mkPoint a \<in> set a \<rightarrow> hom unity a"
using assms(1) mkPoint_in_hom by simp
show "\<And>t. t \<in> set a \<Longrightarrow> img (mkPoint a t) = t"
proof -
fix t
assume t: "t \<in> set a"
show "img (mkPoint a t) = t"
proof -
have 1: "arr (mkPoint a t)"
using assms t mkPoint_in_hom by auto
have "Fun (mkPoint a t) ` {unity} = {t}"
using 1 mkPoint_def by simp
thus ?thesis
by (metis 1 t elem_set_implies_incl_in elem_set_implies_set_eq_singleton img_def
incl_in_def dom_mkArr mkIde_set terminal_char2 terminal_unity mkPoint_def)
qed
qed
qed
text\<open>
For each object @{term a} the elements of @{term "hom unity a"} are therefore in
bijective correspondence with @{term "set a"}.
\<close>
lemma bij_betw_points_and_set:
assumes "ide a"
shows "bij_betw img (hom unity a) (set a)"
proof (intro bij_betwI)
show "img \<in> hom unity a \<rightarrow> set a"
using assms mkPoint_img by auto
show "mkPoint a \<in> set a \<rightarrow> hom unity a"
using assms img_mkPoint by auto
show "\<And>x. x \<in> hom unity a \<Longrightarrow> mkPoint a (img x) = x"
using assms mkPoint_img by auto
show "\<And>t. t \<in> set a \<Longrightarrow> img (mkPoint a t) = t"
using assms img_mkPoint by auto
qed
text\<open>
The function on the universe induced by an arrow @{term f} agrees, under the bijection
between @{term "hom unity (dom f)"} and @{term "Dom f"}, with the action of @{term f}
by composition on @{term "hom unity (dom f)"}.
\<close>
lemma Fun_point:
assumes "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
shows "Fun x = (\<lambda>_ \<in> {unity}. img x)"
using assms mkPoint_img img_mkPoint Fun_mkPoint [of a "img x"] img_point_elem_set
by auto
lemma comp_arr_mkPoint:
assumes "arr f" and "t \<in> Dom f"
shows "f \<cdot> mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
proof (intro arr_eqI)
have 0: "seq f (mkPoint (dom f) t)"
using assms mkPoint_in_hom [of "dom f" t] by auto
have 1: "\<guillemotleft>f \<cdot> mkPoint (dom f) t : unity \<rightarrow> cod f\<guillemotright>"
using assms mkPoint_in_hom [of "dom f" t] by auto
show "par (f \<cdot> mkPoint (dom f) t) (mkPoint (cod f) (Fun f t))"
proof -
have "\<guillemotleft>mkPoint (cod f) (Fun f t) : unity \<rightarrow> cod f\<guillemotright>"
using assms Fun_mapsto mkPoint_in_hom [of "cod f" "Fun f t"] by auto
thus ?thesis using 1 by fastforce
qed
show "Fun (f \<cdot> mkPoint (dom f) t) = Fun (mkPoint (cod f) (Fun f t))"
proof -
have "Fun (f \<cdot> mkPoint (dom f) t) = restrict (Fun f o Fun (mkPoint (dom f) t)) {unity}"
using assms 0 1 Fun_comp terminal_char2 terminal_unity by auto
also have "... = (\<lambda>_ \<in> {unity}. Fun f t)"
using assms Fun_mkPoint by auto
also have "... = Fun (mkPoint (cod f) (Fun f t))"
using assms Fun_mkPoint [of "cod f" "Fun f t"] Fun_mapsto by fastforce
finally show ?thesis by auto
qed
qed
lemma comp_arr_point:
assumes "arr f" and "\<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright>"
shows "f \<cdot> x = mkPoint (cod f) (Fun f (img x))"
proof -
have "x = mkPoint (dom f) (img x)" using assms mkPoint_img by simp
thus ?thesis using assms comp_arr_mkPoint [of f "img x"]
by (simp add: img_point_elem_set)
qed
text\<open>
This agreement allows us to express @{term "Fun f"} in terms of composition.
\<close>
lemma Fun_in_terms_of_comp:
assumes "arr f"
shows "Fun f = restrict (img o S f o mkPoint (dom f)) (Dom f)"
proof
fix t
have "t \<notin> Dom f \<Longrightarrow> Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
using assms by (simp add: Fun_def)
moreover have "t \<in> Dom f \<Longrightarrow>
Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
proof -
assume t: "t \<in> Dom f"
have 1: "f \<cdot> mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
using assms t comp_arr_mkPoint by simp
hence "img (f \<cdot> mkPoint (dom f) t) = img (mkPoint (cod f) (Fun f t))" by simp
thus ?thesis
proof -
have "Fun f t \<in> Cod f" using assms t Fun_mapsto by auto
thus ?thesis using assms t 1 img_mkPoint by auto
qed
qed
ultimately show "Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t" by auto
qed
text\<open>
We therefore obtain a rule for proving parallel arrows equal by showing
that they have the same action by composition on points.
\<close>
(*
* TODO: Find out why attempts to use this as the main rule for a proof loop
* unless the specific instance is given.
*)
lemma arr_eqI':
assumes "par f f'" and "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
shows "f = f'"
using assms Fun_in_terms_of_comp mkPoint_in_hom by (intro arr_eqI, auto)
text\<open>
An arrow can therefore be specified by giving its action by composition on points.
In many situations, this is more natural than specifying it as a function on the universe.
\<close>
definition mkArr'
where "mkArr' a b F = mkArr (set a) (set b) (img o F o mkPoint a)"
lemma mkArr'_in_hom:
assumes "ide a" and "ide b" and "F \<in> hom unity a \<rightarrow> hom unity b"
shows "\<guillemotleft>mkArr' a b F : a \<rightarrow> b\<guillemotright>"
proof -
have "img o F o mkPoint a \<in> set a \<rightarrow> set b"
proof
fix t
assume t: "t \<in> set a"
thus "(img o F o mkPoint a) t \<in> set b"
using assms mkPoint_in_hom img_point_elem_set [of "F (mkPoint a t)" b]
by auto
qed
thus ?thesis
using assms mkArr'_def mkArr_in_hom [of "set a" "set b"] by simp
qed
lemma comp_point_mkArr':
assumes "ide a" and "ide b" and "F \<in> hom unity a \<rightarrow> hom unity b"
shows "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkArr' a b F \<cdot> x = F x"
proof -
fix x
assume x: "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
have "Fun (mkArr' a b F) (img x) = img (F x)"
unfolding mkArr'_def
using assms x Fun_mkArr arr_mkArr img_point_elem_set mkPoint_img mkPoint_in_hom
by (simp add: Pi_iff)
hence "mkArr' a b F \<cdot> x = mkPoint b (img (F x))"
using assms x mkArr'_in_hom [of a b F] comp_arr_point by auto
thus "mkArr' a b F \<cdot> x = F x"
using assms x mkPoint_img(2) by auto
qed
text\<open>
A third characterization of terminal objects is as those objects whose set of
points is a singleton.
\<close>
lemma terminal_char3:
assumes "\<exists>!x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
shows "terminal a"
proof -
have a: "ide a"
using assms ide_cod mem_Collect_eq by blast
hence 1: "bij_betw img (hom unity a) (set a)"
using assms bij_betw_points_and_set by auto
hence "img ` (hom unity a) = set a"
by (simp add: bij_betw_def)
moreover have "hom unity a = {THE x. x \<in> hom unity a}"
using assms theI' [of "\<lambda>x. x \<in> hom unity a"] by auto
ultimately have "set a = {img (THE x. x \<in> hom unity a)}"
by (metis image_empty image_insert)
thus ?thesis using a terminal_char1 by simp
qed
text\<open>
The following is an alternative formulation of functional completeness, which says that
any function on points uniquely determines an arrow.
\<close>
lemma fun_complete':
assumes "ide a" and "ide b" and "F \<in> hom unity a \<rightarrow> hom unity b"
shows "\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
proof
have 1: "\<guillemotleft>mkArr' a b F : a \<rightarrow> b\<guillemotright>" using assms mkArr'_in_hom by auto
moreover have 2: "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkArr' a b F \<cdot> x = F x"
using assms comp_point_mkArr' by auto
ultimately show "\<guillemotleft>mkArr' a b F : a \<rightarrow> b\<guillemotright> \<and>
(\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> mkArr' a b F \<cdot> x = F x)" by blast
fix f
assume f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
show "f = mkArr' a b F"
using f 1 2 by (intro arr_eqI' [of f "mkArr' a b F"], fastforce, auto)
qed
subsection "The `Determines Same Function' Relation on Arrows"
text\<open>
An important part of understanding the structure of a category of sets and functions
is to characterize when it is that two arrows ``determine the same function''.
The following result provides one answer to this: two arrows with a common domain
determine the same function if and only if they can be rendered equal by composing with
a cospan of inclusions.
\<close>
lemma eq_Fun_iff_incl_joinable:
assumes "span f f'"
shows "Fun f = Fun f' \<longleftrightarrow>
(\<exists>m m'. incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f')"
proof
assume ff': "Fun f = Fun f'"
let ?b = "mkIde (Cod f \<union> Cod f')"
let ?m = "incl_of (cod f) ?b"
let ?m' = "incl_of (cod f') ?b"
have "incl ?m"
using assms incl_incl_of [of "cod f" ?b] incl_in_def by simp
have "incl ?m'"
using assms incl_incl_of [of "cod f'" ?b] incl_in_def by simp
have m: "?m = mkArr (Cod f) (Cod f \<union> Cod f') (\<lambda>x. x)"
by (simp add: assms)
have m': "?m' = mkArr (Cod f') (Cod f \<union> Cod f') (\<lambda>x. x)"
by (simp add: assms)
have seq: "seq ?m f \<and> seq ?m' f'"
using assms m m' by simp
have "?m \<cdot> f = ?m' \<cdot> f'"
proof (intro arr_eqI)
show par: "par (?m \<cdot> f) (?m' \<cdot> f')"
using assms m m' by simp
show "Fun (?m \<cdot> f) = Fun (?m' \<cdot> f')"
using assms seq par ff' Fun_mapsto Fun_comp seqE
by (metis Fun_ide Fun_mkArr comp_cod_arr ide_cod)
qed
hence "incl ?m \<and> incl ?m' \<and> seq ?m f \<and> seq ?m' f' \<and> ?m \<cdot> f = ?m' \<cdot> f'"
using seq \<open>incl ?m\<close> \<open>incl ?m'\<close> by simp
thus "\<exists>m m'. incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f'" by auto
next
assume ff': "\<exists>m m'. incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f'"
show "Fun f = Fun f'"
proof -
from ff' obtain m m'
where mm': "incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f'"
by blast
show ?thesis
using ff' mm' Fun_incl seqE
by (metis Fun_comp Fun_ide comp_cod_arr ide_cod)
qed
qed
text\<open>
Another answer to the same question: two arrows with a common domain determine the
same function if and only if their corestrictions are equal.
\<close>
lemma eq_Fun_iff_eq_corestr:
assumes "span f f'"
shows "Fun f = Fun f' \<longleftrightarrow> corestr f = corestr f'"
using assms corestr_def Fun_corestr by metis
subsection "Retractions, Sections, and Isomorphisms"
text\<open>
An arrow is a retraction if and only if its image coincides with its codomain.
\<close>
lemma retraction_if_Img_eq_Cod:
assumes "arr g" and "Img g = Cod g"
shows "retraction g"
and "ide (g \<cdot> mkArr (Cod g) (Dom g) (inv_into (Dom g) (Fun g)))"
proof -
let ?F = "inv_into (Dom g) (Fun g)"
let ?f = "mkArr (Cod g) (Dom g) ?F"
have f: "arr ?f"
proof
have "Cod g \<subseteq> Univ \<and> Dom g \<subseteq> Univ" using assms by auto
moreover have "?F \<in> Cod g \<rightarrow> Dom g"
proof
fix y
assume y: "y \<in> Cod g"
let ?P = "\<lambda>x. x \<in> Dom g \<and> Fun g x = y"
have "\<exists>x. ?P x" using y assms by force
hence "?P (SOME x. ?P x)" using someI_ex [of ?P] by fast
hence "?P (?F y)" using Hilbert_Choice.inv_into_def by metis
thus "?F y \<in> Dom g" by auto
qed
ultimately show "Cod g \<subseteq> Univ \<and> Dom g \<subseteq> Univ \<and> ?F \<in> Cod g \<rightarrow> Dom g" by auto
qed
show "ide (g \<cdot> ?f)"
proof -
have "g = mkArr (Dom g) (Cod g) (Fun g)" using assms by auto
hence "g \<cdot> ?f = mkArr (Cod g) (Cod g) (Fun g o ?F)"
using assms(1) f comp_mkArr by metis
moreover have "mkArr (Cod g) (Cod g) (\<lambda>y. y) = ..."
proof (intro mkArr_eqI')
show "arr (mkArr (Cod g) (Cod g) (\<lambda>y. y))"
using assms arr_cod_iff_arr by auto
show "\<And>y. y \<in> Cod g \<Longrightarrow> y = (Fun g o ?F) y"
using assms by (simp add: f_inv_into_f)
qed
ultimately show ?thesis using assms f by auto
qed
thus "retraction g" by auto
qed
lemma retraction_char:
shows "retraction g \<longleftrightarrow> arr g \<and> Img g = Cod g"
proof
assume G: "retraction g"
show "arr g \<and> Img g = Cod g"
proof
show "arr g" using G by blast
show "Img g = Cod g"
proof -
from G obtain f where f: "ide (g \<cdot> f)" by blast
have "restrict (Fun g o Fun f) (Cod g) = restrict (\<lambda>x. x) (Cod g)"
using f Fun_comp Fun_ide ide_compE by metis
hence "Fun g ` Fun f ` Cod g = Cod g"
by (metis image_comp image_ident image_restrict_eq)
moreover have "Fun f ` Cod g \<subseteq> Dom g"
using f Fun_mapsto arr_mkArr mkArr_Fun funcset_image
by (metis seqE ide_compE ide_compE)
moreover have "Img g \<subseteq> Cod g"
using f Fun_mapsto by blast
ultimately show ?thesis by blast
qed
qed
next
assume "arr g \<and> Img g = Cod g"
thus "retraction g" using retraction_if_Img_eq_Cod by blast
qed
text\<open>
Every corestriction is a retraction.
\<close>
lemma retraction_corestr:
assumes "arr f"
shows "retraction (corestr f)"
using assms retraction_char Fun_corestr corestr_in_hom by fastforce
text\<open>
An arrow is a section if and only if it induces an injective function on its
domain, except in the special case that it has an empty domain set and a
nonempty codomain set.
\<close>
lemma section_if_inj:
assumes "arr f" and "inj_on (Fun f) (Dom f)" and "Dom f = {} \<longrightarrow> Cod f = {}"
shows "section f"
and "ide (mkArr (Cod f) (Dom f)
(\<lambda>y. if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
else SOME x. x \<in> Dom f)
\<cdot> f)"
proof -
let ?P= "\<lambda>y. \<lambda>x. x \<in> Dom f \<and> Fun f x = y"
let ?G = "\<lambda>y. if y \<in> Img f then SOME x. ?P y x else SOME x. x \<in> Dom f"
let ?g = "mkArr (Cod f) (Dom f) ?G"
have g: "arr ?g"
proof -
have 1: "Cod f \<subseteq> Univ" using assms by simp
have 2: "Dom f \<subseteq> Univ" using assms by simp
have 3: "?G \<in> Cod f \<rightarrow> Dom f"
proof
fix y
assume Y: "y \<in> Cod f"
show "?G y \<in> Dom f"
proof (cases "y \<in> Img f")
assume "y \<in> Img f"
hence "(\<exists>x. ?P y x) \<and> ?G y = (SOME x. ?P y x)" using Y by auto
hence "?P y (?G y)" using someI_ex [of "?P y"] by argo
thus "?G y \<in> Dom f" by auto
next
assume "y \<notin> Img f"
hence "(\<exists>x. x \<in> Dom f) \<and> ?G y = (SOME x. x \<in> Dom f)" using assms Y by auto
thus "?G y \<in> Dom f" using someI_ex [of "\<lambda>x. x \<in> Dom f"] by argo
qed
qed
show ?thesis using 1 2 3 by simp
qed
show "ide (?g \<cdot> f)"
proof -
have "f = mkArr (Dom f) (Cod f) (Fun f)" using assms by auto
hence "?g \<cdot> f = mkArr (Dom f) (Dom f) (?G o Fun f)"
using assms(1) g comp_mkArr [of "Dom f" "Cod f" "Fun f" "Dom f" ?G] by argo
moreover have "mkArr (Dom f) (Dom f) (\<lambda>x. x) = ..."
proof (intro mkArr_eqI')
show "arr (mkArr (Dom f) (Dom f) (\<lambda>x. x))" using assms by auto
show "\<And>x. x \<in> Dom f \<Longrightarrow> x = (?G o Fun f) x"
proof -
fix x
assume x: "x \<in> Dom f"
have "Fun f x \<in> Img f" using x by blast
hence *: "(\<exists>x'. ?P (Fun f x) x') \<and> ?G (Fun f x) = (SOME x'. ?P (Fun f x) x')"
by auto
then have "?P (Fun f x) (?G (Fun f x))"
using someI_ex [of "?P (Fun f x)"] by argo
with * have "x = ?G (Fun f x)"
using assms x inj_on_def [of "Fun f" "Dom f"] by simp
thus "x = (?G o Fun f) x" by simp
qed
qed
ultimately show ?thesis using assms by auto
qed
thus "section f" by auto
qed
lemma section_char:
shows "section f \<longleftrightarrow> arr f \<and> (Dom f = {} \<longrightarrow> Cod f = {}) \<and> inj_on (Fun f) (Dom f)"
proof
assume f: "section f"
from f obtain g where g: "ide (g \<cdot> f)" using section_def by blast
show "arr f \<and> (Dom f = {} \<longrightarrow> Cod f = {}) \<and> inj_on (Fun f) (Dom f)"
proof -
have "arr f" using f by blast
moreover have "Dom f = {} \<longrightarrow> Cod f = {}"
proof -
have "Cod f \<noteq> {} \<longrightarrow> Dom f \<noteq> {}"
proof
assume "Cod f \<noteq> {}"
from this obtain y where "y \<in> Cod f" by blast
hence "Fun g y \<in> Dom f"
using g Fun_mapsto
by (metis seqE ide_compE image_eqI retractionI retraction_char)
thus "Dom f \<noteq> {}" by blast
qed
thus ?thesis by auto
qed
moreover have "inj_on (Fun f) (Dom f)"
proof -
have "restrict (Fun g o Fun f) (Dom f) = Fun (g \<cdot> f)"
using g Fun_comp by (metis Fun_comp ide_compE)
also have "... = restrict (\<lambda>x. x) (Dom f)"
using g Fun_ide by auto
finally have "restrict (Fun g o Fun f) (Dom f) = restrict (\<lambda>x. x) (Dom f)" by auto
thus ?thesis using inj_onI inj_on_imageI2 inj_on_restrict_eq by metis
qed
ultimately show ?thesis by auto
qed
next
assume F: "arr f \<and> (Dom f = {} \<longrightarrow> Cod f = {}) \<and> inj_on (Fun f) (Dom f)"
thus "section f" using section_if_inj by auto
qed
text\<open>
Section-retraction pairs can also be characterized by an inverse relationship
between the functions they induce.
\<close>
lemma section_retraction_char:
shows "ide (g \<cdot> f) \<longleftrightarrow> antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)"
proof
show "ide (g \<cdot> f) \<Longrightarrow> antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)"
proof -
assume fg: "ide (g \<cdot> f)"
have 1: "antipar f g" using fg by force
moreover have "compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)"
proof
fix x
have "x \<notin> Dom f \<Longrightarrow> compose (Dom f) (Fun g) (Fun f) x = (\<lambda>x \<in> Dom f. x) x"
by (simp add: compose_def)
moreover have "x \<in> Dom f \<Longrightarrow>
compose (Dom f) (Fun g) (Fun f) x = (\<lambda>x \<in> Dom f. x) x"
using fg 1 Fun_comp by (metis Fun_comp Fun_ide compose_eq' ide_compE)
ultimately show "compose (Dom f) (Fun g) (Fun f) x = (\<lambda>x \<in> Dom f. x) x" by auto
qed
ultimately show ?thesis by auto
qed
show "antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x) \<Longrightarrow> ide (g \<cdot> f)"
proof -
assume fg: "antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)"
show "ide (g \<cdot> f)"
proof -
have 1: "arr (g \<cdot> f)" using fg by auto
moreover have "Dom (g \<cdot> f) = Cod (S g f)"
using fg 1 by force
moreover have "Fun (g \<cdot> f) = (\<lambda>x \<in> Dom (g \<cdot> f). x)"
using fg 1 by force
ultimately show ?thesis using 1 ide_char by blast
qed
qed
qed
text\<open>
Antiparallel arrows @{term f} and @{term g} are inverses if the functions
they induce are inverses.
\<close>
lemma inverse_arrows_char:
shows "inverse_arrows f g \<longleftrightarrow>
antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)
\<and> compose (Dom g) (Fun f) (Fun g) = (\<lambda>y \<in> Dom g. y)"
using section_retraction_char by blast
text\<open>
An arrow is an isomorphism if and only if the function it induces is a bijection.
\<close>
lemma iso_char:
shows "iso f \<longleftrightarrow> arr f \<and> bij_betw (Fun f) (Dom f) (Cod f)"
proof -
have "iso f \<longleftrightarrow> section f \<and> retraction f"
using iso_iff_section_and_retraction by auto
also have "... \<longleftrightarrow> arr f \<and> inj_on (Fun f) (Dom f) \<and> Img f = Cod f"
using section_char retraction_char by force
also have "... \<longleftrightarrow> arr f \<and> bij_betw (Fun f) (Dom f) (Cod f)"
using inj_on_def bij_betw_def [of "Fun f" "Dom f" "Cod f"] by meson
finally show ?thesis by auto
qed
text\<open>
The inverse of an isomorphism is constructed by inverting the induced function.
\<close>
lemma inv_char:
assumes "iso f"
shows "inv f = mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
proof -
let ?g = "mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
have "ide (f \<cdot> ?g)"
using assms iso_is_retraction retraction_char retraction_if_Img_eq_Cod by simp
moreover have "ide (?g \<cdot> f)"
proof -
let ?g' = "mkArr (Cod f) (Dom f)
(\<lambda>y. if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
else SOME x. x \<in> Dom f)"
have 1: "ide (?g' \<cdot> f)"
using assms iso_is_section section_char section_if_inj by simp
moreover have "?g' = ?g"
proof
show "arr ?g'" using 1 ide_compE by blast
show "\<And>y. y \<in> Cod f \<Longrightarrow> (if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
else SOME x. x \<in> Dom f)
= inv_into (Dom f) (Fun f) y"
proof -
fix y
assume "y \<in> Cod f"
hence "y \<in> Img f" using assms iso_is_retraction retraction_char by metis
thus "(if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
else SOME x. x \<in> Dom f)
= inv_into (Dom f) (Fun f) y"
using inv_into_def by metis
qed
qed
ultimately show ?thesis by auto
qed
ultimately have "inverse_arrows f ?g" by auto
thus ?thesis using inverse_unique by blast
qed
lemma Fun_inv:
assumes "iso f"
shows "Fun (inv f) = restrict (inv_into (Dom f) (Fun f)) (Cod f)"
using assms inv_in_hom inv_char iso_inv_iso iso_is_arr Fun_mkArr by metis
subsection "Monomorphisms and Epimorphisms"
text\<open>
An arrow is a monomorphism if and only if the function it induces is injective.
\<close>
lemma mono_char:
shows "mono f \<longleftrightarrow> arr f \<and> inj_on (Fun f) (Dom f)"
proof
assume f: "mono f"
hence "arr f" using mono_def by auto
moreover have "inj_on (Fun f) (Dom f)"
proof (intro inj_onI)
have 0: "inj_on (S f) (hom unity (dom f))"
proof -
have "hom unity (dom f) \<subseteq> {g. seq f g}"
using f mono_def arrI by auto
hence "\<exists>A. hom unity (dom f) \<subseteq> A \<and> inj_on (S f) A"
using f mono_def by auto
thus ?thesis
by (meson subset_inj_on)
qed
fix x x'
assume x: "x \<in> Dom f" and x': "x' \<in> Dom f" and xx': "Fun f x = Fun f x'"
have 1: "mkPoint (dom f) x \<in> hom unity (dom f) \<and>
mkPoint (dom f) x' \<in> hom unity (dom f)"
using x x' \<open>arr f\<close> mkPoint_in_hom by simp
have "f \<cdot> mkPoint (dom f) x = f \<cdot> mkPoint (dom f) x'"
using \<open>arr f\<close> x x' xx' comp_arr_mkPoint by simp
hence "mkPoint (dom f) x = mkPoint (dom f) x'"
using 0 1 inj_onD [of "S f" "hom unity (dom f)" "mkPoint (dom f) x"] by simp
thus "x = x'"
using \<open>arr f\<close> x x' img_mkPoint(2) img_mkPoint(2) ide_dom by metis
qed
ultimately show "arr f \<and> inj_on (Fun f) (Dom f)" by auto
next
assume f: "arr f \<and> inj_on (Fun f) (Dom f)"
show "mono f"
proof
show "arr f" using f by auto
show "\<And>g g'. seq f g \<and> seq f g' \<and> f \<cdot> g = f \<cdot> g' \<Longrightarrow> g = g'"
proof -
fix g g'
assume gg': "seq f g \<and> seq f g' \<and> f \<cdot> g = f \<cdot> g'"
show "g = g'"
proof (intro arr_eqI)
show par: "par g g'"
using gg' dom_comp by (metis seqE)
show "Fun g = Fun g'"
proof
fix x
have "x \<notin> Dom g \<Longrightarrow> Fun g x = Fun g' x"
using gg' by (simp add: par Fun_def)
moreover have "x \<in> Dom g \<Longrightarrow> Fun g x = Fun g' x"
proof -
assume x: "x \<in> Dom g"
have "Fun f (Fun g x) = Fun (f \<cdot> g) x"
using gg' x Fun_comp [of f g] by auto
also have "... = Fun f (Fun g' x)"
using par f gg' x monoE by simp
finally have "Fun f (Fun g x) = Fun f (Fun g' x)" by auto
moreover have "Fun g x \<in> Dom f \<and> Fun g' x \<in> Dom f"
using par gg' x Fun_mapsto by fastforce
ultimately show "Fun g x = Fun g' x"
using f gg' inj_onD [of "Fun f" "Dom f" "Fun g x" "Fun g' x"]
by simp
qed
ultimately show "Fun g x = Fun g' x" by auto
qed
qed
qed
qed
qed
text\<open>
Inclusions are monomorphisms.
\<close>
lemma mono_imp_incl:
assumes "incl f"
shows "mono f"
using assms incl_def Fun_incl mono_char by auto
text\<open>
A monomorphism is a section, except in case it has an empty domain set and
a nonempty codomain set.
\<close>
lemma mono_imp_section:
assumes "mono f" and "Dom f = {} \<longrightarrow> Cod f = {}"
shows "section f"
using assms mono_char section_char by auto
text\<open>
An arrow is an epimorphism if and only if either its image coincides with its
codomain, or else the universe has only a single element (in which case all arrows
are epimorphisms).
\<close>
lemma epi_char:
shows "epi f \<longleftrightarrow> arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))"
proof
assume epi: "epi f"
show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))"
proof -
have f: "arr f" using epi epi_implies_arr by auto
moreover have "\<not>(\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t') \<Longrightarrow> Img f = Cod f"
proof -
assume "\<not>(\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t')"
from this obtain tt and ff
where B: "tt \<in> Univ \<and> ff \<in> Univ \<and> tt \<noteq> ff" by blast
show "Img f = Cod f"
proof
show "Img f \<subseteq> Cod f" using f Fun_mapsto by auto
show "Cod f \<subseteq> Img f"
proof
let ?g = "mkArr (Cod f) {ff, tt} (\<lambda>y. tt)"
let ?g' = "mkArr (Cod f) {ff, tt} (\<lambda>y. if \<exists>x. x \<in> Dom f \<and> Fun f x = y
then tt else ff)"
let ?b = "mkIde {ff, tt}"
have g: "\<guillemotleft>?g : cod f \<rightarrow> ?b\<guillemotright> \<and> Fun ?g = (\<lambda>y \<in> Cod f. tt)"
using f B in_homI [of ?g] by simp
have g': "?g' \<in> hom (cod f) ?b \<and>
Fun ?g' = (\<lambda>y \<in> Cod f. if \<exists>x. x \<in> Dom f \<and> Fun f x = y then tt else ff)"
using f B in_homI [of ?g'] by simp
have "?g \<cdot> f = ?g' \<cdot> f"
proof (intro arr_eqI)
show "par (?g \<cdot> f) (?g' \<cdot> f)"
using f g g' by auto
show "Fun (?g \<cdot> f) = Fun (?g' \<cdot> f)"
using f g g' Fun_comp comp_mkArr by force
qed
hence gg': "?g = ?g'"
using epi f g g' epiE [of f ?g ?g'] by fastforce
fix y
assume y: "y \<in> Cod f"
have "Fun ?g' y = tt" using gg' g y by simp
hence "(if \<exists>x. x \<in> Dom f \<and> Fun f x = y then tt else ff) = tt"
using g' y by simp
hence "\<exists>x. x \<in> Dom f \<and> Fun f x = y"
using B by argo
thus "y \<in> Img f" by blast
qed
qed
qed
ultimately show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))"
by fast
qed
next
show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t')) \<Longrightarrow> epi f"
proof -
have "arr f \<and> Img f = Cod f \<Longrightarrow> epi f"
proof -
assume f: "arr f \<and> Img f = Cod f"
show "epi f"
using f arr_eqI' epiE retractionI retraction_if_Img_eq_Cod retraction_is_epi
by meson
qed
moreover have "arr f \<and> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t') \<Longrightarrow> epi f"
proof -
assume f: "arr f \<and> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t')"
have "\<And>f f'. par f f' \<Longrightarrow> f = f'"
proof -
fix f f'
assume ff': "par f f'"
show "f = f'"
proof (intro arr_eqI)
show "par f f'" using ff' by simp
have "\<And>t t'. t \<in> Cod f \<and> t' \<in> Cod f \<Longrightarrow> t = t'"
using f ff' set_subset_Univ ide_cod subsetD by blast
thus "Fun f = Fun f'"
using ff' Fun_mapsto [of f] Fun_mapsto [of f']
extensional_arb [of "Fun f" "Dom f"] extensional_arb [of "Fun f'" "Dom f"]
by fastforce
qed
qed
moreover have "\<And>g g'. par (g \<cdot> f) (g' \<cdot> f) \<Longrightarrow> par g g'"
by force
ultimately show "epi f"
using f by (intro epiI; metis)
qed
ultimately show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))
\<Longrightarrow> epi f"
by auto
qed
qed
text\<open>
An epimorphism is a retraction, except in the case of a degenerate universe with only
a single element.
\<close>
lemma epi_imp_retraction:
assumes "epi f" and "\<exists>t t'. t \<in> Univ \<and> t' \<in> Univ \<and> t \<noteq> t'"
shows "retraction f"
using assms epi_char retraction_char by auto
text\<open>
Retraction/inclusion factorization is unique (not just up to isomorphism -- remember
that the notion of inclusion is not categorical but depends on the arbitrarily chosen
@{term img}).
\<close>
lemma unique_retr_incl_fact:
assumes "seq m e" and "seq m' e'" and "m \<cdot> e = m' \<cdot> e'"
and "incl m" and "incl m'" and "retraction e" and "retraction e'"
shows "m = m'" and "e = e'"
proof -
have 1: "cod m = cod m' \<and> dom e = dom e'"
using assms(1-3) by (metis dom_comp cod_comp)
hence 2: "span e e'" using assms(1-2) by blast
hence 3: "Fun e = Fun e'"
using assms eq_Fun_iff_incl_joinable by meson
hence "img e = img e'" using assms 1 img_def by auto
moreover have "img e = cod e \<and> img e' = cod e'"
using assms(6-7) retraction_char img_def by simp
ultimately have "par e e'" using 2 by simp
thus "e = e'" using 3 arr_eqI by blast
hence "par m m'" using assms(1) assms(2) 1 by fastforce
thus "m = m'" using assms(4) assms(5) incls_coherent by blast
qed
end
section "Concrete Set Categories"
text\<open>
The \<open>set_category\<close> locale is useful for stating results that depend on a
category of @{typ 'a}-sets and functions, without having to commit to a particular
element type @{typ 'a}. However, in applications we often need to work with a
category of sets and functions that is guaranteed to contain sets corresponding
to the subsets of some extrinsically given type @{typ 'a}.
A \emph{concrete set category} is a set category \<open>S\<close> that is equipped
with an injective function @{term \<iota>} from type @{typ 'a} to \<open>S.Univ\<close>.
The following locale serves to facilitate some of the technical aspects of passing
back and forth between elements of type @{typ 'a} and the elements of \<open>S.Univ\<close>.
\<close>
locale concrete_set_category = set_category S
for S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and U :: "'a set"
and \<iota> :: "'a \<Rightarrow> 's" +
assumes \<iota>_mapsto: "\<iota> \<in> U \<rightarrow> Univ"
and inj_\<iota>: "inj_on \<iota> U"
begin
abbreviation \<o>
where "\<o> \<equiv> inv_into U \<iota>"
lemma \<o>_mapsto:
shows "\<o> \<in> \<iota> ` U \<rightarrow> U"
by (simp add: inv_into_into)
lemma \<o>_\<iota> [simp]:
assumes "x \<in> U"
shows "\<o> (\<iota> x) = x"
using assms inj_\<iota> inv_into_f_f by simp
lemma \<iota>_\<o> [simp]:
assumes "t \<in> \<iota> ` U"
shows "\<iota> (\<o> t) = t"
using assms o_def inj_\<iota> by auto
end
end
diff --git a/thys/Category3/Yoneda.thy b/thys/Category3/Yoneda.thy
--- a/thys/Category3/Yoneda.thy
+++ b/thys/Category3/Yoneda.thy
@@ -1,1108 +1,1108 @@
(* Title: Yoneda
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter Yoneda
theory Yoneda
imports DualCategory SetCat FunctorCategory
begin
text\<open>
This theory defines the notion of a ``hom-functor'' and gives a proof of the Yoneda Lemma.
In traditional developments of category theory based on set theories such as ZFC,
hom-functors are normally defined to be functors into the large category \textbf{Set}
whose objects are of \emph{all} sets and whose arrows are functions between sets.
However, in HOL there does not exist a single ``type of all sets'', so the notion of
the category of \emph{all} sets and functions does not make sense. To work around this,
we consider a more general setting consisting of a category @{term C} together with
a set category @{term S} and a function @{term "\<phi> :: 'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"} such that
whenever @{term b} and @{term a} are objects of C then @{term "\<phi> (b, a)"} maps
\<open>C.hom b a\<close> injectively to \<open>S.Univ\<close>. We show that these data induce
a binary functor \<open>Hom\<close> from \<open>Cop\<times>C\<close> to @{term S} in such a way that @{term \<phi>}
is rendered natural in @{term "(b, a)"}. The Yoneda lemma is then proved for the
Yoneda functor determined by \<open>Hom\<close>.
\<close>
section "Hom-Functors"
text\<open>
A hom-functor for a category @{term C} allows us to regard the hom-sets of @{term C}
as objects of a category @{term S} of sets and functions. Any description of a
hom-functor for @{term C} must therefore specify the category @{term S} and provide
some sort of correspondence between arrows of @{term C} and elements of objects of @{term S}.
If we are to think of each hom-set \<open>C.hom b a\<close> of \<open>C\<close> as corresponding
to an object \<open>Hom (b, a)\<close> of @{term S} then at a minimum it ought to be the
case that the correspondence between arrows and elements is bijective between
\<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>. The \<open>hom_functor\<close> locale defined
below captures this idea by assuming a set category @{term S} and a function @{term \<phi>}
taking arrows of @{term C} to elements of \<open>S.Univ\<close>, such that @{term \<phi>} is injective
on each set \<open>C.hom b a\<close>. We show that these data induce a functor \<open>Hom\<close>
from \<open>Cop\<times>C\<close> to \<open>S\<close> in such a way that @{term \<phi>} becomes a natural
bijection between \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.
\<close>
locale hom_functor =
C: category C +
Cop: dual_category C +
CopxC: product_category Cop.comp C +
S: set_category S
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's" +
assumes maps_arr_to_Univ: "C.arr f \<Longrightarrow> \<phi> (C.dom f, C.cod f) f \<in> S.Univ"
and local_inj: "\<lbrakk> C.ide b; C.ide a \<rbrakk> \<Longrightarrow> inj_on (\<phi> (b, a)) (C.hom b a)"
begin
notation S.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
notation CopxC.comp (infixr "\<odot>" 55)
notation CopxC.in_hom ("\<guillemotleft>_ : _ \<rightleftharpoons> _\<guillemotright>")
definition set
where "set ba \<equiv> \<phi> (fst ba, snd ba) ` C.hom (fst ba) (snd ba)"
lemma set_subset_Univ:
assumes "C.ide b" and "C.ide a"
shows "set (b, a) \<subseteq> S.Univ"
using assms set_def maps_arr_to_Univ CopxC.ide_char by auto
definition \<psi> :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
where "\<psi> ba = inv_into (C.hom (fst ba) (snd ba)) (\<phi> ba)"
lemma \<phi>_mapsto:
assumes "C.ide b" and "C.ide a"
shows "\<phi> (b, a) \<in> C.hom b a \<rightarrow> set (b, a)"
using assms set_def maps_arr_to_Univ by auto
lemma \<psi>_mapsto:
assumes "C.ide b" and "C.ide a"
shows "\<psi> (b, a) \<in> set (b, a) \<rightarrow> C.hom b a"
using assms set_def \<psi>_def local_inj by auto
lemma \<psi>_\<phi> [simp]:
assumes "\<guillemotleft>f : b \<rightarrow> a\<guillemotright>"
shows "\<psi> (b, a) (\<phi> (b, a) f) = f"
using assms local_inj [of b a] \<psi>_def by fastforce
lemma \<phi>_\<psi> [simp]:
assumes "C.ide b" and "C.ide a"
and "x \<in> set (b, a)"
shows "\<phi> (b, a) (\<psi> (b, a) x) = x"
using assms set_def local_inj \<psi>_def by auto
lemma \<psi>_img_set:
assumes "C.ide b" and "C.ide a"
shows "\<psi> (b, a) ` set (b, a) = C.hom b a"
using assms \<psi>_def set_def local_inj by auto
text\<open>
A hom-functor maps each arrow @{term "(g, f)"} of @{term "CopxC"}
to the arrow of the set category @{term[source=true] S} corresponding to the function
that takes an arrow @{term h} of @{term C} to the arrow @{term "C f (C h g)"} of @{term C}
obtained by precomposing with @{term g} and postcomposing with @{term f}.
\<close>
definition map
where "map gf =
(if CopxC.arr gf then
S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf))
(\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf))
else S.null)"
lemma arr_map:
assumes "CopxC.arr gf"
shows "S.arr (map gf)"
proof -
have "\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf)
\<in> set (CopxC.dom gf) \<rightarrow> set (CopxC.cod gf)"
using assms \<phi>_mapsto [of "fst (CopxC.cod gf)" "snd (CopxC.cod gf)"]
\<psi>_mapsto [of "fst (CopxC.dom gf)" "snd (CopxC.dom gf)"]
by fastforce
thus ?thesis
using assms map_def set_subset_Univ by auto
qed
lemma map_ide [simp]:
assumes "C.ide b" and "C.ide a"
shows "map (b, a) = S.mkIde (set (b, a))"
proof -
have "map (b, a) = S.mkArr (set (b, a)) (set (b, a))
(\<phi> (b, a) o (\<lambda>h. a \<cdot> h \<cdot> b) o \<psi> (b, a))"
using assms map_def by auto
also have "... = S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h)"
proof -
have "S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h) = ..."
using assms S.arr_mkArr set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
by (intro S.mkArr_eqI', simp, fastforce)
thus ?thesis by auto
qed
also have "... = S.mkIde (set (b, a))"
using assms S.mkIde_as_mkArr set_subset_Univ by simp
finally show ?thesis by auto
qed
lemma set_map:
assumes "C.ide a" and "C.ide b"
shows "S.set (map (b, a)) = set (b, a)"
using assms map_ide S.set_mkIde set_subset_Univ by simp
text\<open>
The definition does in fact yield a functor.
\<close>
interpretation "functor" CopxC.comp S map
proof
fix gf
assume "\<not>CopxC.arr gf"
thus "map gf = S.null" using map_def by auto
next
fix gf
assume gf: "CopxC.arr gf"
thus arr: "S.arr (map gf)" using gf arr_map by blast
show "S.dom (map gf) = map (CopxC.dom gf)"
proof -
have "S.dom (map gf) = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf)) (\<lambda>x. x)"
using gf arr_map map_def by simp
also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf))
(\<phi> (CopxC.dom gf) o
(\<lambda>h. snd (CopxC.dom gf) \<cdot> h \<cdot> fst (CopxC.dom gf)) o
\<psi> (CopxC.dom gf))"
using gf set_subset_Univ \<psi>_mapsto map_def set_def
apply (intro S.mkArr_eqI', auto)
by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
also have "... = map (CopxC.dom gf)"
using gf map_def C.arr_dom_iff_arr C.arr_cod_iff_arr by simp
finally show ?thesis by auto
qed
show "S.cod (map gf) = map (CopxC.cod gf)"
proof -
have "S.cod (map gf) = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf)) (\<lambda>x. x)"
using gf map_def arr_map by simp
also have "... = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf))
(\<phi> (CopxC.cod gf) o
(\<lambda>h. snd (CopxC.cod gf) \<cdot> h \<cdot> fst (CopxC.cod gf)) o
\<psi> (CopxC.cod gf))"
using gf set_subset_Univ \<psi>_mapsto map_def set_def
apply (intro S.mkArr_eqI', auto)
by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
also have "... = map (CopxC.cod gf)" using gf map_def by simp
finally show ?thesis by auto
qed
next
fix gf gf'
assume gf': "CopxC.seq gf' gf"
hence seq: "C.arr (fst gf) \<and> C.arr (snd gf) \<and> C.dom (snd gf') = C.cod (snd gf) \<and>
C.arr (fst gf') \<and> C.arr (snd gf') \<and> C.dom (fst gf) = C.cod (fst gf')"
by (elim CopxC.seqE C.seqE, auto)
have 0: "S.arr (map (CopxC.comp gf' gf))"
using gf' arr_map by blast
have 1: "map (gf' \<odot> gf) =
S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
(\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
o \<psi> (CopxC.dom gf))"
using gf' map_def using CopxC.cod_comp CopxC.dom_comp by auto
also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf')
\<circ>
(\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
\<circ> \<psi> (CopxC.dom gf)))"
using 0 1 by simp
show "\<And>x. x \<in> set (CopxC.dom gf) \<Longrightarrow>
(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
\<psi> (CopxC.dom gf)) x =
(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
(\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
proof -
fix x
assume "x \<in> set (CopxC.dom gf)"
hence x: "x \<in> set (C.cod (fst gf), C.dom (snd gf))"
using gf' CopxC.seqE by (elim CopxC.seqE, fastforce)
show "(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
\<psi> (CopxC.dom gf)) x =
(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
(\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
proof -
have "(\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
o \<psi> (CopxC.dom gf)) x =
\<phi> (CopxC.cod gf') (snd (gf' \<odot> gf) \<cdot> \<psi> (CopxC.dom gf) x \<cdot> fst (gf' \<odot> gf))"
by simp
also have "... = \<phi> (CopxC.cod gf')
(((\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
(\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf)))
(\<psi> (CopxC.dom gf) x))"
proof -
have "C.ide (C.cod (fst gf)) \<and> C.ide (C.dom (snd gf))"
using gf' by (elim CopxC.seqE, auto)
hence "\<guillemotleft>\<psi> (C.cod (fst gf), C.dom (snd gf)) x : C.cod (fst gf) \<rightarrow> C.dom (snd gf)\<guillemotright>"
using x \<psi>_mapsto by auto
hence "\<guillemotleft>snd gf \<cdot> \<psi> (C.cod (fst gf), C.dom (snd gf)) x \<cdot> fst gf :
C.cod (fst gf') \<rightarrow> C.dom (snd gf')\<guillemotright>"
using x seq by auto
thus ?thesis
using seq \<psi>_\<phi> C.comp_assoc by auto
qed
also have "... = (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
(\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))
x"
by auto
finally show ?thesis using seq by simp
qed
qed
qed
also have "... = map gf' \<cdot>\<^sub>S map gf"
using seq gf' map_def arr_map [of gf] arr_map [of gf'] S.comp_mkArr by auto
finally show "map (gf' \<odot> gf) = map gf' \<cdot>\<^sub>S map gf"
using seq gf' by auto
qed
interpretation binary_functor Cop.comp C S map ..
lemma is_binary_functor:
shows "binary_functor Cop.comp C S map" ..
end
sublocale hom_functor \<subseteq> binary_functor Cop.comp C S map
using is_binary_functor by auto
context hom_functor
begin
text\<open>
The map @{term \<phi>} determines a bijection between @{term "C.hom b a"} and
@{term "set (b, a)"} which is natural in @{term "(b, a)"}.
\<close>
lemma \<phi>_local_bij:
assumes "C.ide b" and "C.ide a"
shows "bij_betw (\<phi> (b, a)) (C.hom b a) (set (b, a))"
using assms local_inj inj_on_imp_bij_betw set_def by auto
lemma \<phi>_natural:
assumes "C.arr g" and "C.arr f" and "h \<in> C.hom (C.cod g) (C.dom f)"
shows "\<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g) = S.Fun (map (g, f)) (\<phi> (C.cod g, C.dom f) h)"
proof -
let ?\<phi>h = "\<phi> (C.cod g, C.dom f) h"
have \<phi>h: "?\<phi>h \<in> set (C.cod g, C.dom f)"
using assms \<phi>_mapsto set_def by simp
have gf: "CopxC.arr (g, f)" using assms by simp
have "map (g, f) =
S.mkArr (set (C.cod g, C.dom f)) (set (C.dom g, C.cod f))
(\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))"
using assms map_def by simp
moreover have "S.arr (map (g, f))" using gf by simp
ultimately have
"S.Fun (map (g, f)) =
restrict (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))
(set (C.cod g, C.dom f))"
using S.Fun_mkArr by simp
hence "S.Fun (map (g, f)) ?\<phi>h =
(\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f)) ?\<phi>h"
using \<phi>h by simp
also have "... = \<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g)"
using assms(3) by simp
finally show ?thesis by auto
qed
lemma Dom_map:
assumes "C.arr g" and "C.arr f"
shows "S.Dom (map (g, f)) = set (C.cod g, C.dom f)"
using assms map_def preserves_arr by auto
lemma Cod_map:
assumes "C.arr g" and "C.arr f"
shows "S.Cod (map (g, f)) = set (C.dom g, C.cod f)"
using assms map_def preserves_arr by auto
lemma Fun_map:
assumes "C.arr g" and "C.arr f"
shows "S.Fun (map (g, f)) =
restrict (\<phi> (C.dom g, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> g) o \<psi> (C.cod g, C.dom f))
(set (C.cod g, C.dom f))"
using assms map_def preserves_arr by force
lemma map_simp_1:
assumes "C.arr g" and "C.ide a"
shows "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
(\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
proof -
have 1: "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
(\<phi> (C.dom g, a) o (\<lambda>h. a \<cdot> h \<cdot> g) o \<psi> (C.cod g, a))"
using assms map_def by force
also have "... = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
(\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
using assms 1 preserves_arr [of "(g, a)"] set_def C.in_homI C.comp_cod_arr
by (intro S.mkArr_eqI, auto)
finally show ?thesis by auto
qed
lemma map_simp_2:
assumes "C.ide b" and "C.arr f"
shows "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
(\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
proof -
have 1: "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
(\<phi> (b, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> b) o \<psi> (b, C.dom f))"
using assms map_def by force
also have "... = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
(\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
using assms 1 preserves_arr [of "(b, f)"] set_def C.in_homI C.comp_arr_dom
by (intro S.mkArr_eqI, auto)
finally show ?thesis by auto
qed
end
text\<open>
Every category @{term C} has a hom-functor: take @{term S} to be the set category
\<open>SetCat\<close> generated by the set of arrows of @{term C} and take @{term "\<phi> (b, a)"}
to be the map \<open>UP :: 'c \<Rightarrow> 'c SetCat.arr\<close>.
\<close>
context category
begin
interpretation Cop: dual_category C ..
interpretation CopxC: product_category Cop.comp C ..
- interpretation S: set_category "SetCat.comp :: 'a SetCat.arr comp"
- using SetCat.is_set_category by auto
- interpretation Hom: hom_functor C "SetCat.comp :: 'a SetCat.arr comp" "\<lambda>_. UP"
+ interpretation S: set_category \<open>SetCat.comp :: 'a setcat.arr comp\<close>
+ using is_set_category by auto
+ interpretation Hom: hom_functor C \<open>SetCat.comp :: 'a setcat.arr comp\<close> \<open>\<lambda>_. SetCat.UP\<close>
apply unfold_locales
using UP_mapsto apply auto[1]
using inj_UP injD inj_onI by metis
lemma has_hom_functor:
- shows "hom_functor C (SetCat.comp :: 'a SetCat.arr comp) (\<lambda>_. UP)" ..
+ shows "hom_functor C (SetCat.comp :: 'a setcat.arr comp) (\<lambda>_. UP)" ..
end
text\<open>
The locales \<open>set_valued_functor\<close> and \<open>set_valued_transformation\<close> provide some
abbreviations that are convenient when working with functors and natural transformations
into a set category.
\<close>
locale set_valued_functor =
C: category C +
S: set_category S +
"functor" C S F
for C :: "'c comp"
and S :: "'s comp"
and F :: "'c \<Rightarrow> 's"
begin
abbreviation SET :: "'c \<Rightarrow> 's set"
where "SET a \<equiv> S.set (F a)"
abbreviation DOM :: "'c \<Rightarrow> 's set"
where "DOM f \<equiv> S.Dom (F f)"
abbreviation COD :: "'c \<Rightarrow> 's set"
where "COD f \<equiv> S.Cod (F f)"
abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
where "FUN f \<equiv> S.Fun (F f)"
end
locale set_valued_transformation =
C: category C +
S: set_category S +
F: set_valued_functor C S F +
G: set_valued_functor C S G +
natural_transformation C S F G \<tau>
for C :: "'c comp"
and S :: "'s comp"
and F :: "'c \<Rightarrow> 's"
and G :: "'c \<Rightarrow> 's"
and \<tau> :: "'c \<Rightarrow> 's"
begin
abbreviation DOM :: "'c \<Rightarrow> 's set"
where "DOM f \<equiv> S.Dom (\<tau> f)"
abbreviation COD :: "'c \<Rightarrow> 's set"
where "COD f \<equiv> S.Cod (\<tau> f)"
abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
where "FUN f \<equiv> S.Fun (\<tau> f)"
end
section "Yoneda Functors"
text\<open>
A Yoneda functor is the functor from @{term C} to \<open>[Cop, S]\<close> obtained by ``currying''
a hom-functor in its first argument.
\<close>
locale yoneda_functor =
C: category C +
Cop: dual_category C +
CopxC: product_category Cop.comp C +
S: set_category S +
Hom: hom_functor C S \<phi> +
Cop_S: functor_category Cop.comp S +
curried_functor' Cop.comp C S Hom.map
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
begin
notation Cop_S.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] _\<guillemotright>")
abbreviation \<psi>
where "\<psi> \<equiv> Hom.\<psi>"
text\<open>
An arrow of the functor category \<open>[Cop, S]\<close> consists of a natural transformation
bundled together with its domain and codomain functors. However, when considering
a Yoneda functor from @{term[source=true] C} to \<open>[Cop, S]\<close> we generally are only
interested in the mapping @{term Y} that takes each arrow @{term f} of @{term[source=true] C}
to the corresponding natural transformation @{term "Y f"}. The domain and codomain functors
are then the identity transformations @{term "Y (C.dom f)"} and @{term "Y (C.cod f)"}.
\<close>
definition Y
- where "Y f \<equiv> Cop_S.Fun (map f)"
+ where "Y f \<equiv> Cop_S.Map (map f)"
lemma Y_simp [simp]:
assumes "C.arr f"
shows "Y f = (\<lambda>g. Hom.map (g, f))"
using assms preserves_arr Y_def by simp
lemma Y_ide_is_functor:
assumes "C.ide a"
shows "functor Cop.comp S (Y a)"
using assms Y_def Hom.fixing_ide_gives_functor_2 by force
lemma Y_arr_is_transformation:
assumes "C.arr f"
shows "natural_transformation Cop.comp S (Y (C.dom f)) (Y (C.cod f)) (Y f)"
using assms Y_def [of f] map_def Hom.fixing_arr_gives_natural_transformation_2
preserves_dom preserves_cod by fastforce
lemma Y_ide_arr [simp]:
assumes a: "C.ide a" and "\<guillemotleft>g : b' \<rightarrow> b\<guillemotright>"
shows "\<guillemotleft>Y a g : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b', a)\<guillemotright>"
and "Y a g =
S.mkArr (Hom.set (b, a)) (Hom.set (b', a)) (\<phi> (b', a) o Cop.comp g o \<psi> (b, a))"
using assms Hom.map_simp_1 by (fastforce, auto)
lemma Y_arr_ide [simp]:
assumes "C.ide b" and "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>"
shows "\<guillemotleft>Y f b : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b, a')\<guillemotright>"
and "Y f b = S.mkArr (Hom.set (b, a)) (Hom.set (b, a')) (\<phi> (b, a') o C f o \<psi> (b, a))"
using assms apply fastforce
using assms Hom.map_simp_2 by auto
end
locale yoneda_functor_fixed_object =
yoneda_functor C S \<phi>
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and a :: 'c +
assumes ide_a: "C.ide a"
sublocale yoneda_functor_fixed_object \<subseteq> "functor" Cop.comp S "(Y a)"
using ide_a Y_ide_is_functor by auto
sublocale yoneda_functor_fixed_object \<subseteq> set_valued_functor Cop.comp S "(Y a)" ..
text\<open>
The Yoneda lemma states that, given a category @{term C} and a functor @{term F}
from @{term Cop} to a set category @{term S}, for each object @{term a} of @{term C},
the set of natural transformations from the contravariant functor @{term "Y a"}
to @{term F} is in bijective correspondence with the set \<open>F.SET a\<close>
of elements of @{term "F a"}.
Explicitly, if @{term e} is an arbitrary element of the set \<open>F.SET a\<close>,
then the functions \<open>\<lambda>x. F.FUN (\<psi> (b, a) x) e\<close> are the components of a
natural transformation from @{term "Y a"} to @{term F}.
Conversely, if @{term \<tau>} is a natural transformation from @{term "Y a"} to @{term F},
then the component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
is completely determined by the single arrow \<open>\<tau>.FUN a (\<phi> (a, a) a)))\<close>,
which is the the element of \<open>F.SET a\<close> that corresponds to the image of the
identity @{term a} under the function \<open>\<tau>.FUN a\<close>.
Then @{term "\<tau> b"} is the arrow from @{term "Y a b"} to @{term "F b"} corresponding
to the function \<open>\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a)))\<close>
from \<open>S.set (Y a b)\<close> to \<open>F.SET b\<close>.
The above expressions look somewhat more complicated than the usual versions due to the
need to account for the coercions @{term \<phi>} and @{term \<psi>}.
\<close>
locale yoneda_lemma =
C: category C +
Cop: dual_category C +
S: set_category S +
F: set_valued_functor Cop.comp S F +
yoneda_functor_fixed_object C S \<phi> a
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and F :: "'c \<Rightarrow> 's"
and a :: 'c
begin
text\<open>
The mapping that evaluates the component @{term "\<tau> a"} at @{term a} of a
natural transformation @{term \<tau>} from @{term Y} to @{term F} on the element
@{term "\<phi> (a, a) a"} of @{term "SET a"}, yielding an element of @{term "F.SET a"}.
\<close>
definition \<E> :: "('c \<Rightarrow> 's) \<Rightarrow> 's"
where "\<E> \<tau> = S.Fun (\<tau> a) (\<phi> (a, a) a)"
text\<open>
The mapping that takes an element @{term e} of @{term "F.SET a"} and produces
a map on objects of @{term[source=true] C} whose value at @{term b} is the arrow of
@{term[source=true] S} corresponding to the function
@{term "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"}.
\<close>
definition \<T>o :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
where "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
lemma \<T>o_e_ide:
assumes e: "e \<in> S.set (F a)" and b: "C.ide b"
shows "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
and "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
proof -
show "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
using \<T>o_def by auto
moreover have "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"
proof
fix x
assume x: "x \<in> Hom.set (b, a)"
hence "\<guillemotleft>\<psi> (b, a) x : b \<rightarrow> a\<guillemotright>" using assms ide_a Hom.\<psi>_mapsto by auto
hence "F.FUN (\<psi> (b, a) x) \<in> F.SET a \<rightarrow> F.SET b"
using S.Fun_mapsto [of "F (\<psi> (b, a) x)"] by fastforce
thus "F.FUN (\<psi> (b, a) x) e \<in> F.SET b" using e by auto
qed
ultimately show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
using ide_a b S.mkArr_in_hom [of "Hom.set (b, a)" "F.SET b"] Hom.set_subset_Univ
by auto
qed
text\<open>
For each @{term "e \<in> F.SET a"}, the mapping @{term "\<T>o e"} gives the components
of a natural transformation @{term \<T>} from @{term "Y a"} to @{term F}.
\<close>
lemma \<T>o_e_induces_transformation:
assumes e: "e \<in> S.set (F a)"
shows "transformation_by_components Cop.comp S (Y a) F (\<T>o e)"
proof
fix b :: 'c
assume b: "Cop.ide b"
show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
using ide_a b e \<T>o_e_ide by simp
next
fix g :: 'c
assume g: "Cop.arr g"
let ?b = "Cop.dom g"
let ?b' = "Cop.cod g"
show "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
proof -
have 1: "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g
= S.mkArr (Hom.set (?b, a)) (F.SET ?b')
((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)))"
proof -
have "S.arr (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
(\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) \<and>
S.dom (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
(\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = Y a (Cop.cod g) \<and>
S.cod (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
(\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = F (Cop.cod g)"
using Cop.cod_char \<T>o_e_ide [of e ?b'] \<T>o_e_ide [of e ?b'] e g by force
moreover have "Y a g = S.mkArr (Hom.set (Cop.dom g, a)) (Hom.set (Cop.cod g, a))
(\<phi> (Cop.cod g, a) \<circ> Cop.comp g \<circ> \<psi> (Cop.dom g, a))"
using Y_ide_arr [of a g ?b' ?b] ide_a g by auto
ultimately show ?thesis
using ide_a e g Y_ide_arr Cop.cod_char \<T>o_e_ide
S.comp_mkArr [of "Hom.set (?b, a)" "Hom.set (?b', a)"
"\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)"
"F.SET ?b'" "\<lambda>x. F.FUN (\<psi> (?b', a) x) e"]
by (metis C.ide_dom Cop.arr_char preserves_arr)
qed
also have "... = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
(F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e))"
proof (intro S.mkArr_eqI')
have "(\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)) \<in> Hom.set (?b, a) \<rightarrow> F.SET ?b'"
proof -
have "S.arr (S (\<T>o e ?b') (Y a g))"
using ide_a e g \<T>o_e_ide [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
by auto
thus ?thesis using 1 by simp
qed
thus "S.arr (S.mkArr (Hom.set (?b, a)) (F.SET ?b')
((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))))"
using ide_a e g Hom.set_subset_Univ by simp
show "\<And>x. x \<in> Hom.set (?b, a) \<Longrightarrow>
((\<lambda>x. F.FUN (\<psi> (?b', a) x) e) o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
= (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
proof -
fix x
assume x: "x \<in> Hom.set (?b, a)"
have "((\<lambda>x. (F.FUN o \<psi> (?b', a)) x e)
o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
= F.FUN (\<psi> (?b', a) (\<phi> (?b', a) (C (\<psi> (?b, a) x) g))) e"
by simp
also have "... = (F.FUN g o (F.FUN o \<psi> (?b, a)) x) e"
proof -
have 1: "\<guillemotleft>\<psi> (Cop.dom g, a) x : Cop.dom g \<rightarrow> a\<guillemotright>"
using ide_a x g Hom.\<psi>_mapsto [of ?b a] by auto
moreover have "S.seq (F g) (F (\<psi> (C.cod g, a) x))"
using 1 g by (intro S.seqI', auto)
moreover have "\<psi> (C.dom g, a) (\<phi> (C.dom g, a) (C (\<psi> (C.cod g, a) x) g)) =
C (\<psi> (C.cod g, a) x) g"
using g 1 Hom.\<psi>_\<phi> [of "C (\<psi> (?b, a) x) g" ?b' a] by fastforce
ultimately show ?thesis
using assms F.preserves_comp by fastforce
qed
also have "... = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x" by fastforce
finally show "((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
= (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
by simp
qed
qed
also have "... = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
proof -
have "S.arr (F g) \<and> F g = S.mkArr (F.SET ?b) (F.SET ?b') (F.FUN g)"
using g S.mkArr_Fun [of "F g"] by simp
moreover have
"S.arr (\<T>o e ?b) \<and>
\<T>o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)"
using e g \<T>o_e_ide
by (metis C.ide_cod Cop.arr_char Cop.dom_char S.in_homE)
ultimately show ?thesis
using S.comp_mkArr [of "Hom.set (?b, a)" "F.SET ?b" "\<lambda>x. F.FUN (\<psi> (?b, a) x) e"
"F.SET ?b'" "F.FUN g"]
by metis
qed
finally show ?thesis by blast
qed
qed
abbreviation \<T> :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
where "\<T> e \<equiv> transformation_by_components.map Cop.comp S (Y a) (\<T>o e)"
end
locale yoneda_lemma_fixed_e =
yoneda_lemma C S \<phi> F a
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and F :: "'c \<Rightarrow> 's"
and a :: 'c
and e :: 's +
assumes E: "e \<in> F.SET a"
begin
- interpretation \<T>e: transformation_by_components Cop.comp S "Y a" F "\<T>o e"
+ interpretation \<T>e: transformation_by_components Cop.comp S \<open>Y a\<close> F \<open>\<T>o e\<close>
using E \<T>o_e_induces_transformation by auto
lemma natural_transformation_\<T>e:
shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
lemma \<T>e_ide:
assumes "Cop.ide b"
shows "S.arr (\<T> e b)"
and "\<T> e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
using assms apply fastforce
using assms \<T>o_def by auto
end
locale yoneda_lemma_fixed_\<tau> =
yoneda_lemma C S \<phi> F a +
\<tau>: set_valued_transformation Cop.comp S "Y a" F \<tau>
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and F :: "'c \<Rightarrow> 's"
and a :: 'c
and \<tau> :: "'c \<Rightarrow> 's"
begin
text\<open>
The key lemma: The component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
is completely determined by the single element @{term "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"}.
\<close>
lemma \<tau>_ide:
assumes b: "Cop.ide b"
shows "\<tau> b = S.mkArr (Hom.set (b, a)) (F.SET b)
(\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a))))"
proof -
let ?\<phi>a = "\<phi> (a, a) a"
have \<phi>a: "\<phi> (a, a) a \<in> Hom.set (a, a)" using ide_a Hom.\<phi>_mapsto [of a a] by fastforce
have 1: "\<tau> b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<tau>.FUN b)"
using ide_a b S.mkArr_Fun [of "\<tau> b"] Hom.set_map by auto
also have
"... = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a)))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (Hom.set (b, a)) (F.SET b) (\<tau>.FUN b))"
using ide_a b 1 S.mkArr_Fun [of "\<tau> b"] Hom.set_map by auto
show "\<And>x. x \<in> Hom.set (b, a) \<Longrightarrow> \<tau>.FUN b x = (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a))"
proof -
fix x
assume x: "x \<in> Hom.set (b, a)"
let ?\<psi>x = "\<psi> (b, a) x"
have \<psi>x: "\<guillemotleft>?\<psi>x : b \<rightarrow> a\<guillemotright>"
using ide_a b x Hom.\<psi>_mapsto [of b a] by auto
show "\<tau>.FUN b x = (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a))"
proof -
have "\<tau>.FUN b x = S.Fun (\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x) ?\<phi>a"
proof -
have "\<tau>.FUN b x = \<tau>.FUN b ((\<phi> (b, a) o Cop.comp ?\<psi>x) a)"
using ide_a b x \<psi>x Hom.\<phi>_\<psi>
by (metis C.comp_cod_arr C.in_homE C.ide_dom Cop.comp_def comp_apply)
also have "\<tau>.FUN b ((\<phi> (b, a) o Cop.comp ?\<psi>x) a)
= (\<tau>.FUN b o (\<phi> (b, a) o Cop.comp ?\<psi>x o \<psi> (a, a))) ?\<phi>a"
using ide_a b C.ide_in_hom by simp
also have "... = S.Fun (\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x) ?\<phi>a"
proof -
have "S.arr (Y a ?\<psi>x)"
using ide_a \<psi>x preserves_arr by (elim C.in_homE, auto)
moreover have "Y a ?\<psi>x = S.mkArr (Hom.set (a, a)) (SET b)
(\<phi> (b, a) \<circ> Cop.comp ?\<psi>x \<circ> \<psi> (a, a))"
using ide_a b \<psi>x preserves_hom Y_ide_arr Hom.set_map C.arrI by auto
moreover have "S.arr (\<tau> b) \<and> \<tau> b = S.mkArr (SET b) (F.SET b) (\<tau>.FUN b)"
using ide_a b S.mkArr_Fun [of "\<tau> b"] by simp
ultimately have
"S.seq (\<tau> b) (Y a ?\<psi>x) \<and>
\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x =
S.mkArr (Hom.set (a, a)) (F.SET b)
(\<tau>.FUN b o (\<phi> (b, a) \<circ> Cop.comp ?\<psi>x \<circ> \<psi> (a, a)))"
using 1 S.comp_mkArr S.seqI
by (metis S.cod_mkArr S.dom_mkArr)
thus ?thesis
using ide_a b x Hom.\<phi>_mapsto S.Fun_mkArr by force
qed
finally show ?thesis by auto
qed
also have "... = S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a) ?\<phi>a"
using ide_a b \<psi>x \<tau>.naturality [of ?\<psi>x] by force
also have "... = F.FUN ?\<psi>x (\<tau>.FUN a ?\<phi>a)"
proof -
have "restrict (S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a)) (Hom.set (a, a))
= restrict (F.FUN (\<psi> (b, a) x) o \<tau>.FUN a) (Hom.set (a, a))"
proof -
have
"S.arr (F ?\<psi>x \<cdot>\<^sub>S \<tau> a) \<and>
F ?\<psi>x \<cdot>\<^sub>S \<tau> a = S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?\<psi>x o \<tau>.FUN a)"
proof
show 1: "S.seq (F ?\<psi>x) (\<tau> a)"
using \<psi>x ide_a \<tau>.preserves_cod F.preserves_dom by (elim C.in_homE, auto)
have "\<tau> a = S.mkArr (Hom.set (a, a)) (F.SET a) (\<tau>.FUN a)"
using ide_a 1 S.mkArr_Fun [of "\<tau> a"] Hom.set_map by auto
moreover have "F ?\<psi>x = S.mkArr (F.SET a) (F.SET b) (F.FUN ?\<psi>x)"
using x \<psi>x 1 S.mkArr_Fun [of "F ?\<psi>x"] by fastforce
ultimately show "F ?\<psi>x \<cdot>\<^sub>S \<tau> a =
S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?\<psi>x o \<tau>.FUN a)"
using 1 S.comp_mkArr [of "Hom.set (a, a)" "F.SET a" "\<tau>.FUN a"
"F.SET b" "F.FUN ?\<psi>x"]
by (elim S.seqE, auto)
qed
thus ?thesis by force
qed
thus "S.Fun (F (\<psi> (b, a) x) \<cdot>\<^sub>S \<tau> a) ?\<phi>a = F.FUN ?\<psi>x (\<tau>.FUN a ?\<phi>a)"
using ide_a \<phi>a restr_eqE [of "S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a)"
"Hom.set (a, a)" "F.FUN ?\<psi>x o \<tau>.FUN a"]
by simp
qed
finally show ?thesis by simp
qed
qed
qed
finally show ?thesis by auto
qed
text\<open>
Consequently, if @{term \<tau>'} is any natural transformation from @{term "Y a"} to @{term F}
that agrees with @{term \<tau>} at @{term a}, then @{term "\<tau>' = \<tau>"}.
\<close>
lemma eqI:
assumes "natural_transformation Cop.comp S (Y a) F \<tau>'" and "\<tau>' a = \<tau> a"
shows "\<tau>' = \<tau>"
proof (intro NaturalTransformation.eqI)
- interpret \<tau>': natural_transformation Cop.comp S "Y a" F \<tau>' using assms by auto
+ interpret \<tau>': natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>' using assms by auto
interpret T': yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau>' ..
show "natural_transformation Cop.comp S (Y a) F \<tau>" ..
show "natural_transformation Cop.comp S (Y a) F \<tau>'" ..
show "\<And>b. Cop.ide b \<Longrightarrow> \<tau>' b = \<tau> b"
using assms(2) \<tau>_ide T'.\<tau>_ide by simp
qed
end
context yoneda_lemma
begin
text\<open>
One half of the Yoneda lemma:
The mapping @{term \<T>} is an injection, with left inverse @{term \<E>},
from the set @{term "F.SET a"} to the set of natural transformations from
@{term "Y a"} to @{term F}.
\<close>
lemma \<T>_is_injection:
assumes "e \<in> F.SET a"
shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" and "\<E> (\<T> e) = e"
proof -
interpret yoneda_lemma_fixed_e C S \<phi> F a e
using assms by (unfold_locales, auto)
- interpret \<T>e: natural_transformation Cop.comp S "Y a" F "\<T> e"
+ interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> e\<close>
using natural_transformation_\<T>e by auto
show "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
show "\<E> (\<T> e) = e"
unfolding \<E>_def
using assms \<T>e_ide S.Fun_mkArr Hom.\<phi>_mapsto Hom.\<psi>_\<phi> ide_a
F.preserves_ide S.Fun_ide restrict_apply C.ide_in_hom
by (auto simp add: Pi_iff)
qed
lemma \<E>\<tau>_in_Fa:
assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
shows "\<E> \<tau> \<in> F.SET a"
proof -
- interpret \<tau>: natural_transformation Cop.comp S "Y a" F \<tau> using assms by auto
+ interpret \<tau>: natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
show ?thesis
proof (unfold \<E>_def)
have "S.arr (\<tau> a) \<and> S.Dom (\<tau> a) = Hom.set (a, a) \<and> S.Cod (\<tau> a) = F.SET a"
using ide_a Hom.set_map by auto
hence "\<tau>.FUN a \<in> Hom.set (a, a) \<rightarrow> F.SET a"
using S.Fun_mapsto by blast
thus "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"
using ide_a Hom.\<phi>_mapsto by fastforce
qed
qed
text\<open>
The other half of the Yoneda lemma:
The mapping @{term \<T>} is a surjection, with right inverse @{term \<E>},
taking natural transformations from @{term "Y a"} to @{term F}
to elements of @{term "F.SET a"}.
\<close>
lemma \<T>_is_surjection:
assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
shows "\<E> \<tau> \<in> F.SET a" and "\<T> (\<E> \<tau>) = \<tau>"
proof -
- interpret natural_transformation Cop.comp S "Y a" F \<tau> using assms by auto
+ interpret natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
show 1: "\<E> \<tau> \<in> F.SET a" using assms \<E>\<tau>_in_Fa by auto
- interpret yoneda_lemma_fixed_e C S \<phi> F a "\<E> \<tau>"
+ interpret yoneda_lemma_fixed_e C S \<phi> F a \<open>\<E> \<tau>\<close>
using 1 by (unfold_locales, auto)
- interpret \<T>e: natural_transformation Cop.comp S "Y a" F "\<T> (\<E> \<tau>)"
+ interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> (\<E> \<tau>)\<close>
using natural_transformation_\<T>e by auto
show "\<T> (\<E> \<tau>) = \<tau>"
proof (intro eqI)
show "natural_transformation Cop.comp S (Y a) F (\<T> (\<E> \<tau>))" ..
show "\<T> (\<E> \<tau>) a = \<tau> a"
using ide_a \<tau>_ide [of a] \<T>e_ide \<E>_def by simp
qed
qed
text\<open>
The main result.
\<close>
theorem yoneda_lemma:
shows "bij_betw \<T> (F.SET a) {\<tau>. natural_transformation Cop.comp S (Y a) F \<tau>}"
using \<T>_is_injection \<T>_is_surjection by (intro bij_betwI, auto)
end
text\<open>
We now consider the special case in which @{term F} is the contravariant
functor @{term "Y a'"}. Then for any @{term e} in \<open>Hom.set (a, a')\<close>
we have @{term "\<T> e = Y (\<psi> (a, a') e)"}, and @{term \<T>} is a bijection from
\<open>Hom.set (a, a')\<close> to the set of natural transformations from @{term "Y a"}
to @{term "Y a'"}. It then follows that that the Yoneda functor @{term Y}
is a fully faithful functor from @{term C} to the functor category \<open>[Cop, S]\<close>.
\<close>
locale yoneda_lemma_for_hom =
C: category C +
Cop: dual_category C +
S: set_category S +
yoneda_functor_fixed_object C S \<phi> a +
Ya': yoneda_functor_fixed_object C S \<phi> a' +
yoneda_lemma C S \<phi> "Y a'" a
for C :: "'c comp" (infixr "\<cdot>" 55)
and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
and F :: "'c \<Rightarrow> 's"
and a :: 'c
and a' :: 'c +
assumes ide_a': "C.ide a'"
begin
text\<open>
In case @{term F} is the functor @{term "Y a'"}, for any @{term "e \<in> Hom.set (a, a')"}
the induced natural transformation @{term "\<T> e"} from @{term "Y a"} to @{term "Y a'"}
is just @{term "Y (\<psi> (a, a') e)"}.
\<close>
lemma \<T>_equals_Yo\<psi>:
assumes e: "e \<in> Hom.set (a, a')"
shows "\<T> e = Y (\<psi> (a, a') e)"
proof -
let ?\<psi>e = "\<psi> (a, a') e"
have \<psi>e: "\<guillemotleft>?\<psi>e : a \<rightarrow> a'\<guillemotright>" using ide_a ide_a' e Hom.\<psi>_mapsto [of a a'] by auto
- interpret Ye: natural_transformation Cop.comp S "Y a" "Y a'" "Y ?\<psi>e"
+ interpret Ye: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>Y ?\<psi>e\<close>
using Y_arr_is_transformation [of ?\<psi>e] \<psi>e by (elim C.in_homE, auto)
- interpret yoneda_lemma_fixed_e C S \<phi> "Y a'" a e
+ interpret yoneda_lemma_fixed_e C S \<phi> \<open>Y a'\<close> a e
using ide_a ide_a' e S.set_mkIde Hom.set_map
by (unfold_locales, simp_all)
- interpret \<T>e: natural_transformation Cop.comp S "Y a" "Y a'" "\<T> e"
+ interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>\<T> e\<close>
using natural_transformation_\<T>e by auto
- interpret yoneda_lemma_fixed_\<tau> C S \<phi> "Y a'" a "\<T> e" ..
+ interpret yoneda_lemma_fixed_\<tau> C S \<phi> \<open>Y a'\<close> a \<open>\<T> e\<close> ..
have "natural_transformation Cop.comp S (Y a) (Y a') (Y ?\<psi>e)" ..
moreover have "natural_transformation Cop.comp S (Y a) (Y a') (\<T> e)" ..
moreover have "\<T> e a = Y ?\<psi>e a"
proof -
have 1: "S.arr (\<T> e a)"
using ide_a e \<T>e.preserves_reflects_arr by simp
have 2: "\<T> e a = S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e)"
using ide_a \<T>o_def \<T>e_ide by simp
also have
"... = S.mkArr (Hom.set (a, a)) (Hom.set (a, a')) (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a))"
proof (intro S.mkArr_eqI)
show "S.arr (S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e))"
using ide_a e 1 2 by simp
show "Hom.set (a, a) = Hom.set (a, a)" ..
show 3: "Ya'.SET a = Hom.set (a, a')"
using ide_a ide_a' Y_simp Hom.set_map by simp
show "\<And>x. x \<in> Hom.set (a, a) \<Longrightarrow>
Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x"
proof -
fix x
assume x: "x \<in> Hom.set (a, a)"
have \<psi>x: "\<guillemotleft>\<psi> (a, a) x : a \<rightarrow> a\<guillemotright>" using ide_a x Hom.\<psi>_mapsto [of a a] by auto
have "S.arr (Y a' (\<psi> (a, a) x)) \<and>
Y a' (\<psi> (a, a) x) = S.mkArr (Hom.set (a, a')) (Hom.set (a, a'))
(\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a'))"
using Y_ide_arr ide_a ide_a' \<psi>x by blast
hence "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a')) e"
using e 3 S.Fun_mkArr Ya'.preserves_reflects_arr [of "\<psi> (a, a) x"] by simp
also have "... = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by simp
finally show "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by auto
qed
qed
also have "... = Y ?\<psi>e a"
using ide_a ide_a' Y_arr_ide \<psi>e by simp
finally show "\<T> e a = Y ?\<psi>e a" by auto
qed
ultimately show ?thesis using eqI by auto
qed
lemma Y_injective_on_homs:
assumes "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>" and "\<guillemotleft>f' : a \<rightarrow> a'\<guillemotright>" and "map f = map f'"
shows "f = f'"
proof -
have "f = \<psi> (a, a') (\<phi> (a, a') f)"
using assms ide_a Hom.\<psi>_\<phi> by simp
also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f)))"
using ide_a ide_a' assms(1) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
by (elim C.in_homE, simp add: Pi_iff)
also have "... = \<psi> (a, a') (\<E> (Y (\<psi> (a, a') (\<phi> (a, a') f))))"
using assms Hom.\<phi>_mapsto [of a a'] \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f"] by force
also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f')))"
using assms Hom.\<phi>_mapsto [of a a'] ide_a Hom.\<psi>_\<phi> Y_def
\<T>_equals_Yo\<psi> [of "\<phi> (a, a') f'"]
by fastforce
also have "... = \<psi> (a, a') (\<phi> (a, a') f')"
using ide_a ide_a' assms(2) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
by (elim C.in_homE, simp add: Pi_iff)
also have "... = f'"
using assms ide_a Hom.\<psi>_\<phi> by simp
finally show "f = f'" by auto
qed
lemma Y_surjective_on_homs:
assumes \<tau>: "natural_transformation Cop.comp S (Y a) (Y a') \<tau>"
shows "Y (\<psi> (a, a') (\<E> \<tau>)) = \<tau>"
using ide_a ide_a' \<tau> \<T>_is_surjection \<T>_equals_Yo\<psi> \<E>\<tau>_in_Fa Hom.set_map by simp
end
context yoneda_functor
begin
lemma is_faithful_functor:
shows "faithful_functor C Cop_S.comp map"
proof
fix f :: 'c and f' :: 'c
assume par: "C.par f f'" and ff': "map f = map f'"
show "f = f'"
proof -
- interpret Ya': yoneda_functor_fixed_object C S \<phi> "C.cod f"
+ interpret Ya': yoneda_functor_fixed_object C S \<phi> \<open>C.cod f\<close>
using par by (unfold_locales, auto)
- interpret yoneda_lemma_for_hom C S \<phi> "Y (C.cod f)" "C.dom f" "C.cod f"
+ interpret yoneda_lemma_for_hom C S \<phi> \<open>Y (C.cod f)\<close> \<open>C.dom f\<close> \<open>C.cod f\<close>
using par by (unfold_locales, auto)
show "f = f'" using par ff' Y_injective_on_homs [of f f'] by fastforce
qed
qed
lemma is_full_functor:
shows "full_functor C Cop_S.comp map"
proof
fix a :: 'c and a' :: 'c and t
assume a: "C.ide a" and a': "C.ide a'"
assume t: "\<guillemotleft>t : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
show "\<exists>e. \<guillemotleft>e : a \<rightarrow> a'\<guillemotright> \<and> map e = t"
proof
interpret Ya': yoneda_functor_fixed_object C S \<phi> a'
using a' by (unfold_locales, auto)
- interpret yoneda_lemma_for_hom C S \<phi> "Y a'" a a'
+ interpret yoneda_lemma_for_hom C S \<phi> \<open>Y a'\<close> a a'
using a a' by (unfold_locales, auto)
- have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Fun t)"
- using t a' Y_def Cop_S.Fun_dom Cop_S.Fun_cod Cop_S.dom_simp Cop_S.cod_simp
- Cop_S.arr_char Cop_S.in_homE
+ have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Map t)"
+ using t a' Y_def Cop_S.Map_dom Cop_S.Map_cod Cop_S.dom_char Cop_S.cod_char
+ Cop_S.in_homE Cop_S.arrE
by metis
- hence 1: "\<E> (Cop_S.Fun t) \<in> Hom.set (a, a')"
+ hence 1: "\<E> (Cop_S.Map t) \<in> Hom.set (a, a')"
using \<E>\<tau>_in_Fa ide_a ide_a' Hom.set_map by simp
- moreover have "map (\<psi> (a, a') (\<E> (Cop_S.Fun t))) = t"
+ moreover have "map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
proof (intro Cop_S.arr_eqI)
- have 2: "\<guillemotleft>map (\<psi> (a, a') (\<E> (Cop_S.Fun t))) : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
+ have 2: "\<guillemotleft>map (\<psi> (a, a') (\<E> (Cop_S.Map t))) : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
using 1 ide_a ide_a' Hom.\<psi>_mapsto [of a a'] by blast
show "Cop_S.arr t" using t by blast
- show "Cop_S.arr (map (\<psi> (a, a') (\<E> (Cop_S.Fun t))))" using 2 by blast
- show 3: "Cop_S.Fun (map (\<psi> (a, a') (\<E> (Cop_S.Fun t)))) = Cop_S.Fun t"
+ show "Cop_S.arr (map (\<psi> (a, a') (\<E> (Cop_S.Map t))))" using 2 by blast
+ show 3: "Cop_S.Map (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Map t"
using NT Y_surjective_on_homs Y_def by simp
- show 4: "Cop_S.Dom (map (\<psi> (a, a') (\<E> (Cop_S.Fun t)))) = Cop_S.Dom t"
- using t 2 natural_transformation_axioms Cop_S.Fun_dom by (metis Cop_S.in_homE)
- show "Cop_S.Cod (map (\<psi> (a, a') (\<E> (Cop_S.Fun t)))) = Cop_S.Cod t"
- using 2 3 4 t Cop_S.Fun_cod by (metis Cop_S.in_homE)
+ show 4: "Cop_S.Dom (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Dom t"
+ using t 2 natural_transformation_axioms Cop_S.Map_dom by (metis Cop_S.in_homE)
+ show "Cop_S.Cod (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Cod t"
+ using 2 3 4 t Cop_S.Map_cod by (metis Cop_S.in_homE)
qed
- ultimately show "\<guillemotleft>\<psi> (a, a') (\<E> (Cop_S.Fun t)) : a \<rightarrow> a'\<guillemotright> \<and>
- map (\<psi> (a, a') (\<E> (Cop_S.Fun t))) = t"
+ ultimately show "\<guillemotleft>\<psi> (a, a') (\<E> (Cop_S.Map t)) : a \<rightarrow> a'\<guillemotright> \<and>
+ map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
using ide_a ide_a' Hom.\<psi>_mapsto by auto
qed
qed
end
sublocale yoneda_functor \<subseteq> faithful_functor C Cop_S.comp map
using is_faithful_functor by auto
sublocale yoneda_functor \<subseteq> full_functor C Cop_S.comp map using is_full_functor by auto
sublocale yoneda_functor \<subseteq> fully_faithful_functor C Cop_S.comp map ..
end
diff --git a/thys/Category3/document/root.bib b/thys/Category3/document/root.bib
--- a/thys/Category3/document/root.bib
+++ b/thys/Category3/document/root.bib
@@ -1,48 +1,55 @@
@book{AHS,
author = "Ji\vr\'i. Adamek and Horst Herrlich and George E. Strecker",
title = "Abstract and Concrete Categories: The Joy of Cats",
publisher = "(online edition)",
note = {\url{http://katmat.math.uni-bremen.de/acc}},
year = 2004
}
@book{MacLane,
author = "Saunders MacLane",
title = "Categories for the Working Mathematician",
publisher = "Springer-Verlag",
year = 1971
}
@article{OKeefe-AFP05,
author = {Greg O'Keefe},
title = {Category Theory to {Y}oneda's Lemma},
journal = {Archive of Formal Proofs},
month = Apr,
year = 2005,
note = {\url{http://isa-afp.org/entries/Category.shtml}, Formal proof development},
ISSN = {2150-914x}
}
@article{Katovsky-AFP10,
author = {Alexander Katovsky},
title = {Category Theory},
journal = {Archive of Formal Proofs},
month = Jun,
year = 2010,
note = {\url{http://isa-afp.org/entries/Category2.shtml}, Formal proof development},
ISSN = {2150-914x}
}
@unpublished{Katovsky-CatThy10,
author = {Alexander Katovsky},
title = {Category Theory in {I}sabelle/{HOL}},
month = Jun,
year = 2010,
note = {\url{http://apk32.user.srcf.net/Isabelle/Category/Cat.pdf}}
}
@misc{Wikipedia-Adjoint-Functors,
author = "Wikipedia",
title = "Adjoint Functors --- {W}ikipedia{,} The Free Encyclopedia",
year = "2016",
note = {\url{http://en.wikipedia.org/w/index.php?title=Adjoint_functors&oldid=709540944},
[Online; accessed 23-June-2016]}
}
-
-
-
+@article{Bicategory-AFP,
+ author = {Eugene W. Stark},
+ title = {Bicategories},
+ journal = {Archive of Formal Proofs},
+ month = jan,
+ year = 2020,
+ note = {\url{http://isa-afp.org/entries/Bicategory.shtml},
+ Formal proof development},
+ ISSN = {2150-914x},
+}
diff --git a/thys/Category3/document/root.tex b/thys/Category3/document/root.tex
--- a/thys/Category3/document/root.tex
+++ b/thys/Category3/document/root.tex
@@ -1,238 +1,254 @@
\documentclass[11pt,notitlepage,a4paper]{report}
\usepackage{isabelle,isabellesym,eufrak}
\usepackage[english]{babel}
% this should be the last package used
\usepackage{pdfsetup}
% urls in roman style, theory text in math-similar italics
\urlstyle{rm}
\isabellestyle{it}
\input{xy}
\xyoption{curve}
\xyoption{arrow}
\xyoption{matrix}
\xyoption{2cell}
\UseAllTwocells
% Even though I stayed within the default boundary in the JEdit buffer,
% some proof lines wrap around in the PDF document. To minimize this,
% increase the text width a bit from the default.
\addtolength\textwidth{60pt}
\addtolength\oddsidemargin{-30pt}
\addtolength\evensidemargin{-30pt}
\begin{document}
\title{Category Theory with Adjunctions and Limits}
\author{Eugene W. Stark\\[\medskipamount]
Department of Computer Science\\
Stony Brook University\\
Stony Brook, New York 11794 USA}
\maketitle
\begin{abstract}
This article attempts to develop a usable framework for doing category theory in Isabelle/HOL.
Our point of view, which to some extent differs from that of the previous AFP articles
on the subject, is to try to explore how category theory can be done efficaciously within
HOL, rather than trying to match exactly the way things are done using a traditional
approach. To this end, we define the notion of category in an ``object-free''
style, in which a category is represented by a single partial composition operation on arrows.
This way of defining categories provides some advantages in the context of HOL, including
the ability to avoid the use of records and the possibility of defining functors and
natural transformations simply as certain functions on arrows, rather than as composite
objects. We define various constructions associated with the basic notions,
including: dual category, product category, functor category, discrete category, free category,
functor composition, and horizontal and vertical composite of natural transformations.
A ``set category'' locale is defined that axiomatizes the notion ``category of all sets at
a type and all functions between them,'' and a fairly extensive set of properties of set
categories is derived from the locale assumptions.
The notion of a set category is used to prove the Yoneda Lemma in a general setting
of a category equipped with a ``hom embedding,'' which maps arrows of the category
to the ``universe'' of the set category.
We also give a treatment of adjunctions, defining adjunctions via left and right adjoint
functors, natural bijections between hom-sets, and unit and counit natural transformations,
and showing the equivalence of these definitions.
We also develop the theory of limits, including representations of functors,
diagrams and cones, and diagonal functors. We show that right adjoint functors preserve
limits, and that limits can be constructed via products and equalizers. We characterize
the conditions under which limits exist in a set category. We also examine the case of
limits in a functor category, ultimately culminating in a proof that the Yoneda embedding
preserves limits.
\end{abstract}
\tableofcontents
\chapter{Introduction}
This article attempts to develop a usable framework for doing category theory in Isabelle/HOL.
Perhaps the main issue that one faces in doing this is how best to represent what is
essentially a theory of a partially defined operation (composition) in HOL, which is a theory
of total functions. The fact that in HOL every function is total means that a value must be
given for the composition of any pair of arrows of a category, even if those arrows are not
really composable. Proofs must constantly concern themselves with whether or not a
particular term does or does not denote an arrow, and whether particular pairs of arrows
are or are not composable. This kind of issue crops up in the most basic situations,
such as trying to use associativity of composition to prove that two arrows are equal.
Without some sort of systematic way of dealing with this issue, it is hard to do proofs
of interesting results, because one is constantly distracted from the main line of
reasoning by the necessity of proving lemmas that show that various expressions denote
well-defined arrows, that various pairs of arrows are composable, {\em etc.}
In trying to develop category theory in this setting, one notices fairly soon that some
of the problem can be solved by creating introduction rules that allow the proof assistant
to automatically infer, say, that a given term denotes an arrow with a particular
domain and codomain from similar properties of its proper subterms. This ``upward''
reasoning helps, but it goes only so far. Eventually one faces a situation in which it is
desired to prove theorems whose hypotheses state that certain terms denote arrows with
particular domains and codomains, but the proof requires similar lemmas about the proper
subterms. Without some way of doing this ``downward'' reasoning, it becomes very
tedious to establish the necessary lemmas.
Another issue that one faces when trying to formulate category theory within HOL
is the lack of the set-theoretic universe that is usually assumed in traditional
developments. Since there is no ``type of all sets'' in HOL, one cannot construct
``the'' category {\bf Set} of {\em all} sets and functions between them.
Instead, the best one can do is consider ``a'' category of all sets and functions at
a particular type. Although the lack of set-theoretic universe would likely cause
complications for some applications of category theory, there are many
applications for which the lack of a universe is not really a hindrance.
So one might well adopt a point of view that accepts {\em a priori} the lack of a
universe and asks instead how much of traditional category theory could be done in
such a setting.
There have been two previous category theory submissions to the AFP.
The first \cite{OKeefe-AFP05} is an exploratory work that develops just enough
category theory to enable the statement and proof of a version of the Yoneda Lemma.
The main features are: the use of records to define categories and functors,
construction of a category of all subsets of a given set, where the arrows are
domain set/codomain set/function triples, and the use of the category
of all sets of elements of the arrow type of category $C$ as the target for the
Yoneda functor for $C$.
The second category theory submission to the AFP \cite{Katovsky-AFP10} is somewhat
more extensive in its scope, and tries to match more closely a traditional development
of category theory through the use of a set-theoretic universe obtained by an
axiomatic extension of HOL. Categories, functors, and natural transformations
are defined as multi-component records, similarly to \cite{OKeefe-AFP05}.
``The'' category of sets is defined, having as its object and arrow type the type ZF,
which is the axiomatically defined set-theoretic universe.
Included in \cite{Katovsky-AFP10} is a more extensive development of natural
transformations, vertical composition, and functor categories than is to be found in
\cite{OKeefe-AFP05}. However, as in \cite{OKeefe-AFP05}, the main purely category-theoretic
result in \cite{Katovsky-AFP10} is the Yoneda Lemma.
Beyond the use of ``extensional'' functions, which take on a particular default value
outside of their domains of definition, neither \cite{OKeefe-AFP05} nor \cite{Katovsky-AFP10}
explicitly describe a systematic approach to the problem of obtaining lemmas that
establish when the various terms appearing in a proof denote well-defined arrows.
The present development differs in a number of respects from that of
\cite{OKeefe-AFP05} and \cite{Katovsky-AFP10}, both in style and scope.
The main stylistic features of the present development are as follows:
\begin{itemize}
\item The notion of a category is defined in an ``object-free'' style,
motivated by \cite{AHS}, Sec. 3.52-3.53, in which a category is represented by a
single partial composition operation on arrows.
This way of defining categories provides some advantages in the context of HOL,
including the possibility of avoiding extensive use of composite objects constructed
using records.
(Katovsky seemed to have had some similar ideas, since he refers in
\cite{Katovsky-CatThy10} to a theory ``PartialBinaryAlgebra'' that was also motivated
by \cite{AHS}, although this theory did not ultimately become part of his AFP article.)
\item Functors and natural transformation are defined simply to be certain
functions on arrows, where locale predicates are used to express the conditions
that must be satisfied. This makes it possible to define functors and natural
transformations easily using lambda notation without records.
\item Rules for reasoning about categories, functors, and natural transformations
are defined so that all ``diagrammatic'' hypotheses reduce to conjunctions of
assertions, each of which states that a given entity is an arrow, has a particular
domain or codomain, or inhabits a particular ``hom-set''. A system of introduction
and elimination rules is established which permits both ``upward'' reasoning,
in which such diagrammatic assertions are established for larger terms using corresponding
assertions about the proper subterms, as well as ``downward'' reasoning, in which diagrammatic
assertions about proper subterms are inferred from such assertions about a larger
term, to be carried out automatically.
\item Constructions on categories, functors, and natural transformations are defined
using locales in a formulaic fashion.
As an example, the product category construction is defined using a locale that
takes two categories (given by their partial composition operations) as parameters.
The partial composition operation for the product category is given by a function
``$comp$'' defined in the locale. Lemmas proved within the locale include the fact
that $comp$ indeed defines a category, as well as characterizations of the basic
notions (domain, codomain, identities, composition) in terms of those of the
parameter categories.
For some constructions, such as the product category, it is possible and convenient
to have a ``transparent'' arrow type, which permits reasoning about the construction
without having to introduce an elaborate system of constructors, destructors,
and associated rules. For other constructions, such as the functor category,
it is more desirable to use an ``opaque'' arrow type that hides the concrete
structure, and forces all reasoning to take place using a fixed set of rules.
\item Rather than commit to a specific concrete construction of a category of sets and
functions a ``set category'' locale is defined which axiomatizes the properties of the
category of sets with elements at a particular type and functions between such.
In keeping with the definitional approach, the axiomatization is shown consistent by
exhibiting a particular interpretation for the locale, however care is taken to
to ensure that any proofs making use of the interpretation depend only on the locale
assumptions and not on the concrete details of the construction. The set category
axioms are also shown to be categorical, in the sense that a bijection between the sets
of terminal objects of two interpretations of the locale extends to an isomorphism of
categories. This supports the idea that the locale axioms are an adequate
characterization of the properties of a category of sets and functions and the details
of a particular concrete construction can be kept hidden.
\end{itemize}
A brief synopsis of the formal mathematical content of the present development is as follows:
\begin{itemize}
\item Definitions are given for the notions: category, functor, and natural transformation.
\item Several constructions on categories are given, including: free category,
discrete category, dual category, product category, and functor category.
\item Composite functor, horizontal and vertical composite of natural transformations
are defined, and various properties proved.
\item The notion of a ``set category'' is defined and a fairly extensive development
of the consequences of the definition is carried out.
\item Hom-functors and Yoneda functors are defined and the Yoneda Lemma is proved.
\item Adjunctions are defined in several ways, including universal arrows,
natural isomorphisms between hom-sets, and unit and counit natural transformations.
The relationships between the definitions are established.
\item The theory of limits is developed, including the notions of diagram, cone, limit cone,
representable functors, products, and equalizers. It is proved that a category with
products at a particular index type has limits of all diagrams at that type.
The completeness properties of a set category are established.
Limits in functor categories are explored, culminating in a proof that the Yoneda
embedding preserves limits.
\end{itemize}
-The present (2018) version of this development is a major revision of the original (2016)
-version. Although the overall organization and content has remained essentially the same,
-the present version revises the axioms used to define a category, and as a consequence
+The 2018 version of this development was a major revision of the original (2016)
+version. Although the overall organization and content remained essentially the same,
+the 2018 version revised the axioms used to define a category, and as a consequence
many proofs required changes. The purpose of the revision was to obtain a more organized
set of basic facts which, when annotated for use in automatic proof, would yield behavior more
understandable than that of the original version. In particular, as I gained experience with
the Isabelle simplifier, I was able to understand better how to avoid some of the vexing
problems of looping simplifications that sometimes cropped up when using the original rules.
The new version ``feels'' about as powerful as the original version, or perhaps slightly more so.
However, the new version uses elimination rules in place of some things that were previously
done by simplification rules, which means that from time to time it becomes necessary
to provide guidance to the prover as to where the elimination rules should be invoked.
-Another difference between the present version of this document and the original is the
+Another difference between the 2018 version of this document and the original is the
introduction of some notational syntax, which I intentionally avoided in the original.
An important reason for not introducing syntax in the original version was that at the time
I did not have much experience with the notational features of Isabelle, and I was afraid
of introducing hard-to-remove syntax that would make the development more difficult to read
and write, rather than easier. (I tended to find, for example, that the proliferation of
special syntax introduced in \cite{Katovsky-AFP10} made the presentation seem less readily
-accessible than if the syntax had been omitted.) In the present revision, I have introduced
+accessible than if the syntax had been omitted.) In the 2018 revision, I introduced
syntax for composition of arrows in a category, and for the notion of ``an arrow inhabiting
a hom-set.'' The notation for composition eases readability by reducing the number of
required parentheses, and the notation for asserting that an arrow inhabits a particular
hom-set gives these assertions a more familiar appearance; making it easier to understand
them at a glance.
+The present (2020) version revises the 2018 version by incorporating the generic
+``concrete category'' construction originally introduced in \cite{Bicategory-AFP},
+and using it systematically as a uniform replacement for various constructions that were
+previously done in an {\em ad hoc} manner. These include the construction of
+``functor categories'' of categories of functors and natural transformations,
+``set categories'' of sets and functions, and various kinds of free categories.
+The awkward ``abstracted category'' construction, which had no interesting mathematical
+content but was present in the original version as a solution to a modularity problem that
+I no longer deem to be a significant issue, has been removed.
+The cumbersome ``horizontal composite'' locale, which was unnecessary given that in this
+formalization horizontal composite is given simply by function composition,
+has been replaced by a single lemma that does the same job.
+Finally, a lemma in the original version that incorrectly advertised itself as being
+the ``interchange law'' for natural transformations, has been changed to be the
+correct general statement.
+
% include generated text of all theories
\input{session}
\bibliographystyle{abbrv}
\bibliography{root}
\end{document}
diff --git a/thys/MonoidalCategory/FreeMonoidalCategory.thy b/thys/MonoidalCategory/FreeMonoidalCategory.thy
--- a/thys/MonoidalCategory/FreeMonoidalCategory.thy
+++ b/thys/MonoidalCategory/FreeMonoidalCategory.thy
@@ -1,3477 +1,3477 @@
(* Title: FreeMonoidalCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter "The Free Monoidal Category"
text_raw\<open>
\label{fmc-chap}
\<close>
theory FreeMonoidalCategory
imports Category3.Subcategory MonoidalFunctor
begin
text \<open>
In this theory, we use the monoidal language of a category @{term C} defined in
@{theory MonoidalCategory.MonoidalCategory} to give a construction of the free monoidal category
\<open>\<F>C\<close> generated by @{term C}.
The arrows of \<open>\<F>C\<close> are the equivalence classes of formal arrows obtained
by declaring two formal arrows to be equivalent if they are parallel and have the
same diagonalization.
Composition, tensor, and the components of the associator and unitors are all
defined in terms of the corresponding syntactic constructs.
After defining \<open>\<F>C\<close> and showing that it does indeed have the structure of
a monoidal category, we prove the freeness: every functor from @{term C} to a
monoidal category @{term D} extends uniquely to a strict monoidal functor from
\<open>\<F>C\<close> to @{term D}.
We then consider the full subcategory \<open>\<F>\<^sub>SC\<close> of \<open>\<F>C\<close> whose objects
are the equivalence classes of diagonal identity terms
({\em i.e.}~equivalence classes of lists of identity arrows of @{term C}),
and we show that this category is monoidally equivalent to \<open>\<F>C\<close>.
In addition, we show that \<open>\<F>\<^sub>SC\<close> is the free strict monoidal category,
as any functor from \<open>C\<close> to a strict monoidal category @{term D} extends uniquely
to a strict monoidal functor from \<open>\<F>\<^sub>SC\<close> to @{term D}.
\<close>
section "Syntactic Construction"
locale free_monoidal_category =
monoidal_language C
for C :: "'c comp"
begin
no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
text \<open>
Two terms of the monoidal language of @{term C} are defined to be equivalent if
they are parallel formal arrows with the same diagonalization.
\<close>
abbreviation equiv
where "equiv t u \<equiv> Par t u \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
text \<open>
Arrows of \<open>\<F>C\<close> will be the equivalence classes of formal arrows
determined by the relation @{term equiv}. We define here the property of being an
equivalence class of the relation @{term equiv}. Later we show that this property
coincides with that of being an arrow of the category that we will construct.
\<close>
type_synonym 'a arr = "'a term set"
definition ARR where "ARR f \<equiv> f \<noteq> {} \<and> (\<forall>t. t \<in> f \<longrightarrow> f = Collect (equiv t))"
lemma not_ARR_empty:
shows "\<not>ARR {}"
using ARR_def by simp
lemma ARR_eqI:
assumes "ARR f" and "ARR g" and "f \<inter> g \<noteq> {}"
shows "f = g"
using assms ARR_def by fastforce
text \<open>
We will need to choose a representative of each equivalence class as a normal form.
The requirements we have of these representatives are: (1) the normal form of an
arrow @{term t} is equivalent to @{term t}; (2) equivalent arrows have identical
normal forms; (3) a normal form is a canonical term if and only if its diagonalization
is an identity. It follows from these properties and coherence that a term and its
normal form have the same evaluation in any monoidal category. We choose here as a
normal form for an arrow @{term t} the particular term @{term "Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"}.
However, the only specific properties of this definition we actually use are the
three we have just stated.
\<close>
definition norm ("\<^bold>\<parallel>_\<^bold>\<parallel>")
where "\<^bold>\<parallel>t\<^bold>\<parallel> = Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"
text \<open>
If @{term t} is a formal arrow, then @{term t} is equivalent to its normal form.
\<close>
lemma equiv_norm_Arr:
assumes "Arr t"
shows "equiv \<^bold>\<parallel>t\<^bold>\<parallel> t"
proof -
have "Par t (Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>)"
using assms Diagonalize_in_Hom red_in_Hom Inv_in_Hom Arr_implies_Ide_Dom
Arr_implies_Ide_Cod Ide_implies_Arr Can_red
by auto
moreover have "\<^bold>\<lfloor>(Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
Diagonalize_in_Hom Diagonalize_Inv [of "Cod t\<^bold>\<down>"] Diag_Diagonalize
CompDiag_Diag_Dom [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"] CompDiag_Cod_Diag [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"]
by (simp add: Diagonalize_red [of "Cod t"] Can_red(1))
ultimately show ?thesis using norm_def by simp
qed
text \<open>
Equivalent arrows have identical normal forms.
\<close>
lemma norm_respects_equiv:
assumes "equiv t u"
shows "\<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
using assms norm_def by simp
text \<open>
The normal form of an arrow is canonical if and only if its diagonalization
is an identity term.
\<close>
lemma Can_norm_iff_Ide_Diagonalize:
assumes "Arr t"
shows "Can \<^bold>\<parallel>t\<^bold>\<parallel> \<longleftrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms norm_def Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red
Inv_preserves_Can Diagonalize_preserves_Can red_in_Hom Diagonalize_in_Hom
Ide_Diagonalize_Can
by fastforce
text \<open>
We now establish various additional properties of normal forms that are consequences
of the three already proved. The definition \<open>norm_def\<close> is not used subsequently.
\<close>
lemma norm_preserves_Can:
assumes "Can t"
shows "Can \<^bold>\<parallel>t\<^bold>\<parallel>"
using assms Can_implies_Arr Can_norm_iff_Ide_Diagonalize Ide_Diagonalize_Can by simp
lemma Par_Arr_norm:
assumes "Arr t"
shows "Par \<^bold>\<parallel>t\<^bold>\<parallel> t"
using assms equiv_norm_Arr by auto
lemma Diagonalize_norm [simp]:
assumes "Arr t"
shows " \<^bold>\<lfloor>\<^bold>\<parallel>t\<^bold>\<parallel>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms equiv_norm_Arr by auto
lemma unique_norm:
assumes "ARR f"
shows "\<exists>!t. \<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = t"
proof
have 1: "(SOME t. t \<in> f) \<in> f"
using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] by auto
show "\<And>t. \<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = t \<Longrightarrow> t = \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
using assms ARR_def 1 by auto
show "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
using assms ARR_def 1 norm_respects_equiv by blast
qed
lemma Dom_norm:
assumes "Arr t"
shows "Dom \<^bold>\<parallel>t\<^bold>\<parallel> = Dom t"
using assms Par_Arr_norm by metis
lemma Cod_norm:
assumes "Arr t"
shows "Cod \<^bold>\<parallel>t\<^bold>\<parallel> = Cod t"
using assms Par_Arr_norm by metis
lemma norm_in_Hom:
assumes "Arr t"
shows "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> Hom (Dom t) (Cod t)"
using assms Par_Arr_norm [of t] by simp
text \<open>
As all the elements of an equivalence class have the same normal form, we can
use the normal form of an arbitrarily chosen element as a canonical representative.
\<close>
definition rep where "rep f \<equiv> \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
lemma rep_in_ARR:
assumes "ARR f"
shows "rep f \<in> f"
using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] equiv_norm_Arr rep_def ARR_def
by fastforce
lemma Arr_rep_ARR:
assumes "ARR f"
shows "Arr (rep f)"
using assms ARR_def rep_in_ARR by auto
text \<open>
We next define a function \<open>mkarr\<close> that maps formal arrows to their equivalence classes.
For terms that are not formal arrows, the function yields the empty set.
\<close>
definition mkarr where "mkarr t = Collect (equiv t)"
lemma mkarr_extensionality:
assumes "\<not>Arr t"
shows "mkarr t = {}"
using assms mkarr_def by simp
lemma ARR_mkarr:
assumes "Arr t"
shows "ARR (mkarr t)"
using assms ARR_def mkarr_def by auto
lemma mkarr_memb_ARR:
assumes "ARR f" and "t \<in> f"
shows "mkarr t = f"
using assms ARR_def mkarr_def by simp
lemma mkarr_rep_ARR [simp]:
assumes "ARR f"
shows "mkarr (rep f) = f"
using assms rep_in_ARR mkarr_memb_ARR by auto
lemma Arr_in_mkarr:
assumes "Arr t"
shows "t \<in> mkarr t"
using assms mkarr_def by simp
text \<open>
Two terms are related by @{term equiv} iff they are both formal arrows
and have identical normal forms.
\<close>
lemma equiv_iff_eq_norm:
shows "equiv t u \<longleftrightarrow> Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
proof
show "equiv t u \<Longrightarrow> Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
using mkarr_def Arr_in_mkarr ARR_mkarr unique_norm by blast
show "Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel> \<Longrightarrow> equiv t u"
using Par_Arr_norm Diagonalize_norm by metis
qed
lemma norm_norm [simp]:
assumes "Arr t"
shows "\<^bold>\<parallel>\<^bold>\<parallel>t\<^bold>\<parallel>\<^bold>\<parallel> = \<^bold>\<parallel>t\<^bold>\<parallel>"
proof -
have "t \<in> mkarr t"
using assms Arr_in_mkarr by blast
moreover have "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> mkarr t"
using assms equiv_norm_Arr mkarr_def by simp
ultimately show ?thesis using assms ARR_mkarr unique_norm by auto
qed
lemma norm_in_ARR:
assumes "ARR f" and "t \<in> f"
shows "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> f"
using assms ARR_def equiv_iff_eq_norm norm_norm Par_Arr_norm by fastforce
lemma norm_rep_ARR [simp]:
assumes "ARR f"
shows "\<^bold>\<parallel>rep f\<^bold>\<parallel> = rep f"
using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] rep_def norm_norm by fastforce
lemma norm_memb_eq_rep_ARR:
assumes "ARR f" and "t \<in> f"
shows "norm t = rep f"
using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] unique_norm rep_def by metis
lemma rep_mkarr:
assumes "Arr f"
shows "rep (mkarr f) = \<^bold>\<parallel>f\<^bold>\<parallel>"
using assms ARR_mkarr Arr_in_mkarr norm_memb_eq_rep_ARR by fastforce
text \<open>
To prove that two terms determine the same equivalence class,
it suffices to show that they are parallel formal arrows with
identical diagonalizations.
\<close>
lemma mkarr_eqI [intro]:
assumes "Par f g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
shows "mkarr f = mkarr g"
using assms by (metis ARR_mkarr equiv_iff_eq_norm rep_mkarr mkarr_rep_ARR)
text \<open>
We use canonical representatives to lift the formal domain and codomain functions
from terms to equivalence classes.
\<close>
abbreviation DOM where "DOM f \<equiv> Dom (rep f)"
abbreviation COD where "COD f \<equiv> Cod (rep f)"
lemma DOM_mkarr:
assumes "Arr t"
shows "DOM (mkarr t) = Dom t"
using assms rep_mkarr by (metis Par_Arr_norm)
lemma COD_mkarr:
assumes "Arr t"
shows "COD (mkarr t) = Cod t"
using assms rep_mkarr by (metis Par_Arr_norm)
text \<open>
A composition operation can now be defined on equivalence classes
using the syntactic constructor \<open>Comp\<close>.
\<close>
definition comp (infixr "\<cdot>" 55)
where "comp f g \<equiv> (if ARR f \<and> ARR g \<and> DOM f = COD g
then mkarr ((rep f) \<^bold>\<cdot> (rep g)) else {})"
text \<open>
We commence the task of showing that the composition \<open>comp\<close> so defined
determines a category.
\<close>
interpretation partial_magma comp
apply unfold_locales
using comp_def not_ARR_empty by metis
notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
text \<open>
The empty set serves as the null for the composition.
\<close>
lemma null_char:
shows "null = {}"
proof -
let ?P = "\<lambda>n. \<forall>f. f \<cdot> n = n \<and> n \<cdot> f = n"
have "?P {}" using comp_def not_ARR_empty by simp
moreover have "\<exists>!n. ?P n" using ex_un_null by metis
ultimately show ?thesis using null_def theI_unique [of ?P "{}"]
by (metis comp_null(2))
qed
lemma ARR_comp:
assumes "ARR f" and "ARR g" and "DOM f = COD g"
shows "ARR (f \<cdot> g)"
using assms comp_def Arr_rep_ARR ARR_mkarr(1) by simp
lemma DOM_comp [simp]:
assumes "ARR f" and "ARR g" and "DOM f = COD g"
shows "DOM (f \<cdot> g) = DOM g"
using assms comp_def ARR_comp Arr_rep_ARR DOM_mkarr by simp
lemma COD_comp [simp]:
assumes "ARR f" and "ARR g" and "DOM f = COD g"
shows "COD (f \<cdot> g) = COD f"
using assms comp_def ARR_comp Arr_rep_ARR COD_mkarr by simp
lemma comp_assoc:
assumes "g \<cdot> f \<noteq> null" and "h \<cdot> g \<noteq> null"
shows "h \<cdot> (g \<cdot> f) = (h \<cdot> g) \<cdot> f"
proof -
have 1: "ARR f \<and> ARR g \<and> ARR h \<and> DOM h = COD g \<and> DOM g = COD f"
using assms comp_def not_ARR_empty null_char by metis
hence 2: "Arr (rep f) \<and> Arr (rep g) \<and> Arr (rep h) \<and>
Dom (rep h) = Cod (rep g) \<and> Dom (rep g) = Cod (rep f)"
using Arr_rep_ARR by simp
have 3: "h \<cdot> g \<cdot> f = mkarr (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f)))"
using 1 comp_def ARR_comp COD_comp by simp
also have "... = mkarr (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
proof -
have "equiv (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))) (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
proof -
have "Par (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))) (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
using 1 2 3 DOM_mkarr ARR_comp COD_comp mkarr_extensionality not_ARR_empty
by (metis Arr.simps(4) Cod.simps(4) Dom.simps(4) snd_map_prod)
(* Here metis claims it is not using snd_map_prod, but removing it fails. *)
moreover have "\<^bold>\<lfloor>rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))\<^bold>\<rfloor> = \<^bold>\<lfloor>rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
using 1 2 Arr_rep_ARR rep_mkarr rep_in_ARR assms(1) ARR_comp mkarr_extensionality
comp_def equiv_iff_eq_norm norm_memb_eq_rep_ARR null_char
by auto
ultimately show ?thesis using equiv_iff_eq_norm by blast
qed
thus ?thesis
using mkarr_def by force
qed
also have "... = mkarr ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
proof -
have "Par (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
using 2 by simp
moreover have "\<^bold>\<lfloor>rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>(rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
using 2 Diag_Diagonalize by (simp add: CompDiag_assoc)
ultimately show ?thesis
using equiv_iff_eq_norm by (simp add: mkarr_def)
qed
also have "... = mkarr (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f)"
proof -
have "equiv (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
proof -
have "Par (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
using 1 2 Arr_rep_ARR DOM_comp ARR_comp COD_comp comp_def by auto
moreover have "\<^bold>\<lfloor>rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>(rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
using assms(2) 1 2 ARR_comp Arr_rep_ARR mkarr_extensionality rep_mkarr rep_in_ARR
equiv_iff_eq_norm norm_memb_eq_rep_ARR comp_def null_char
by simp
ultimately show ?thesis using equiv_iff_eq_norm by blast
qed
thus ?thesis
using mkarr_def by auto
qed
also have "... = (h \<cdot> g) \<cdot> f"
using 1 comp_def ARR_comp DOM_comp by simp
finally show ?thesis by blast
qed
lemma Comp_in_comp_ARR:
assumes "ARR f" and "ARR g" and "DOM f = COD g"
and "t \<in> f" and "u \<in> g"
shows "t \<^bold>\<cdot> u \<in> f \<cdot> g"
proof -
have "equiv (t \<^bold>\<cdot> u) (rep f \<^bold>\<cdot> rep g)"
proof -
have 1: "Par (t \<^bold>\<cdot> u) (rep f \<^bold>\<cdot> rep g)"
using assms ARR_def Arr_rep_ARR COD_mkarr DOM_mkarr mkarr_memb_ARR
mkarr_extensionality
by (metis (no_types, lifting) Arr.simps(4) Cod.simps(4) Dom.simps(4) snd_map_prod)
(* Here metis claims it is not using snd_map_prod, but removing it fails. *)
moreover have "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> rep g\<^bold>\<rfloor>"
using assms 1 rep_in_ARR equiv_iff_eq_norm norm_memb_eq_rep_ARR
by (metis (no_types, lifting) Arr.simps(4) Diagonalize.simps(4))
ultimately show ?thesis by simp
qed
thus ?thesis
using assms comp_def mkarr_def by simp
qed
text \<open>
Ultimately, we will show that that the identities of the category are those
equivalence classes, all of whose members diagonalize to formal identity arrows,
having the further property that their canonical representative is a formal
endo-arrow.
\<close>
definition IDE where "IDE f \<equiv> ARR f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>) \<and> DOM f = COD f"
lemma IDE_implies_ARR:
assumes "IDE f"
shows "ARR f"
using assms IDE_def ARR_def by auto
lemma IDE_mkarr_Ide:
assumes "Ide a"
shows "IDE (mkarr a)"
proof -
have "DOM (mkarr a) = COD (mkarr a)"
using assms mkarr_def equiv_iff_eq_norm Par_Arr_norm COD_mkarr DOM_mkarr Ide_in_Hom
by (metis Ide_implies_Can Inv_Ide Ide_implies_Arr Inv_preserves_Can(2))
moreover have "ARR (mkarr a) \<and> (\<forall>t. t \<in> mkarr a \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
proof -
have "ARR (mkarr a)" using assms ARR_mkarr Ide_implies_Arr by simp
moreover have "\<forall>t. t \<in> mkarr a \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms mkarr_def Diagonalize_preserves_Ide by fastforce
ultimately show ?thesis by blast
qed
ultimately show ?thesis using IDE_def by blast
qed
lemma IDE_implies_ide:
assumes "IDE a"
shows "ide a"
proof (unfold ide_def)
have "a \<cdot> a \<noteq> null"
proof -
have "rep a \<^bold>\<cdot> rep a \<in> a \<cdot> a"
using assms IDE_def comp_def Arr_rep_ARR Arr_in_mkarr by simp
thus ?thesis
using null_char by auto
qed
moreover have "\<And>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f)"
proof
fix f :: "'c arr"
show "a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f"
proof
assume f: "a \<cdot> f \<noteq> null"
hence "ARR f"
using comp_def null_char by auto
have "rep a \<^bold>\<cdot> rep f \<in> a \<cdot> f"
using assms f Comp_in_comp_ARR comp_def rep_in_ARR null_char by metis
moreover have "rep a \<^bold>\<cdot> rep f \<in> f"
proof -
have "rep f \<in> f"
using \<open>ARR f\<close> rep_in_ARR by auto
moreover have "equiv (rep a \<^bold>\<cdot> rep f) (rep f)"
proof -
have 1: "Par (rep a \<^bold>\<cdot> rep f) (rep f)"
using assms f comp_def mkarr_extensionality Arr_rep_ARR IDE_def null_char
by (metis Cod.simps(4) Dom.simps(4))
moreover have "\<^bold>\<lfloor>rep a \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms f 1 comp_def IDE_def CompDiag_Ide_Diag Diag_Diagonalize(1)
Diag_Diagonalize(2) Diag_Diagonalize(3) rep_in_ARR
by auto
ultimately show ?thesis by auto
qed
ultimately show ?thesis
using \<open>ARR f\<close> ARR_def by auto
qed
ultimately show "a \<cdot> f = f"
using mkarr_memb_ARR comp_def by auto
qed
show "f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f"
proof
assume f: "f \<cdot> a \<noteq> null"
hence "ARR f"
using comp_def null_char by auto
have "rep f \<^bold>\<cdot> rep a \<in> f \<cdot> a"
using assms f Comp_in_comp_ARR comp_def rep_in_ARR null_char by metis
moreover have "rep f \<^bold>\<cdot> rep a \<in> f"
proof -
have "rep f \<in> f"
using \<open>ARR f\<close> rep_in_ARR by auto
moreover have "equiv (rep f \<^bold>\<cdot> rep a) (rep f)"
proof -
have 1: "Par (rep f \<^bold>\<cdot> rep a) (rep f)"
using assms f comp_def mkarr_extensionality Arr_rep_ARR IDE_def null_char
by (metis Cod.simps(4) Dom.simps(4))
moreover have "\<^bold>\<lfloor>rep f \<^bold>\<cdot> rep a\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms f 1 comp_def IDE_def CompDiag_Diag_Ide
Diag_Diagonalize(1) Diag_Diagonalize(2) Diag_Diagonalize(3)
rep_in_ARR
by force
ultimately show ?thesis by auto
qed
ultimately show ?thesis
using \<open>ARR f\<close> ARR_def by auto
qed
ultimately show "f \<cdot> a = f"
using mkarr_memb_ARR comp_def by auto
qed
qed
ultimately show "a \<cdot> a \<noteq> null \<and>
(\<forall>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f))"
by blast
qed
lemma ARR_iff_has_domain:
shows "ARR f \<longleftrightarrow> domains f \<noteq> {}"
proof
assume f: "domains f \<noteq> {}"
show "ARR f" using f domains_def comp_def null_char by auto
next
assume f: "ARR f"
have "Ide (DOM f)"
using f ARR_def by (simp add: Arr_implies_Ide_Dom Arr_rep_ARR)
hence "IDE (mkarr (DOM f))" using IDE_mkarr_Ide by metis
hence "ide (mkarr (DOM f))" using IDE_implies_ide by simp
moreover have "f \<cdot> mkarr (DOM f) = f"
proof -
have 1: "rep f \<^bold>\<cdot> DOM f \<in> f \<cdot> mkarr (DOM f)"
using f Comp_in_comp_ARR
using IDE_implies_ARR Ide_in_Hom rep_in_ARR \<open>IDE (mkarr (DOM f))\<close>
\<open>Ide (DOM f)\<close> Arr_in_mkarr COD_mkarr
by fastforce
moreover have "rep f \<^bold>\<cdot> DOM f \<in> f"
proof -
have 2: "rep f \<in> f" using f rep_in_ARR by simp
moreover have "equiv (rep f \<^bold>\<cdot> DOM f) (rep f)"
using f 1 2 mkarr_memb_ARR mkarr_extensionality \<open>ide (mkarr (DOM f))\<close>
emptyE equiv_iff_eq_norm norm_memb_eq_rep_ARR null_char ide_def
by metis
ultimately show ?thesis
using f ARR_eqI 1 \<open>ide (mkarr (DOM f))\<close> null_char ide_def by auto
qed
ultimately show ?thesis
using f ARR_eqI \<open>ide (mkarr (DOM f))\<close> null_char ide_def by auto
qed
ultimately show "domains f \<noteq> {}"
using f domains_def not_ARR_empty null_char by auto
qed
lemma ARR_iff_has_codomain:
shows "ARR f \<longleftrightarrow> codomains f \<noteq> {}"
proof
assume f: "codomains f \<noteq> {}"
show "ARR f" using f codomains_def comp_def null_char by auto
next
assume f: "ARR f"
have "Ide (COD f)"
using f ARR_def by (simp add: Arr_rep_ARR Arr_implies_Ide_Cod)
hence "IDE (mkarr (COD f))" using IDE_mkarr_Ide by metis
hence "ide (mkarr (COD f))" using IDE_implies_ide by simp
moreover have "mkarr (COD f) \<cdot> f = f"
proof -
have 1: "COD f \<^bold>\<cdot> rep f \<in> mkarr (COD f) \<cdot> f"
using f Comp_in_comp_ARR
using IDE_implies_ARR Ide_in_Hom rep_in_ARR \<open>IDE (mkarr (COD f))\<close>
\<open>Ide (COD f)\<close> Arr_in_mkarr DOM_mkarr
by fastforce
moreover have "COD f \<^bold>\<cdot> rep f \<in> f"
using 1 null_char norm_rep_ARR norm_memb_eq_rep_ARR mkarr_memb_ARR
\<open>ide (mkarr (COD f))\<close> emptyE equiv_iff_eq_norm mkarr_extensionality ide_def
by metis
ultimately show ?thesis
using f ARR_eqI \<open>ide (mkarr (COD f))\<close> null_char ide_def by auto
qed
ultimately show "codomains f \<noteq> {}"
using codomains_def f not_ARR_empty null_char by auto
qed
lemma arr_iff_ARR:
shows "arr f \<longleftrightarrow> ARR f"
using arr_def ARR_iff_has_domain ARR_iff_has_codomain by simp
text \<open>
The arrows of the category are the equivalence classes of formal arrows.
\<close>
lemma arr_char:
shows "arr f \<longleftrightarrow> f \<noteq> {} \<and> (\<forall>t. t \<in> f \<longrightarrow> f = mkarr t)"
using arr_iff_ARR ARR_def mkarr_def by simp
lemma seq_char:
shows "seq g f \<longleftrightarrow> g \<cdot> f \<noteq> null"
proof
show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
using comp_def null_char Comp_in_comp_ARR rep_in_ARR ARR_mkarr
Arr_rep_ARR arr_iff_ARR
by auto
show "seq g f \<Longrightarrow> g \<cdot> f \<noteq> null"
by auto
qed
lemma seq_char':
shows "seq g f \<longleftrightarrow> ARR f \<and> ARR g \<and> DOM g = COD f"
proof
show "ARR f \<and> ARR g \<and> DOM g = COD f \<Longrightarrow> seq g f"
using comp_def null_char Comp_in_comp_ARR rep_in_ARR ARR_mkarr
Arr_rep_ARR arr_iff_ARR
by auto
have "\<not> (ARR f \<and> ARR g \<and> DOM g = COD f) \<Longrightarrow> g \<cdot> f = null"
using comp_def null_char by auto
thus "seq g f \<Longrightarrow> ARR f \<and> ARR g \<and> DOM g = COD f"
using ext by fastforce
qed
text \<open>
Finally, we can show that the composition \<open>comp\<close> determines a category.
\<close>
interpretation category comp
proof
show "\<And>f. domains f \<noteq> {} \<longleftrightarrow> codomains f \<noteq> {}"
using ARR_iff_has_domain ARR_iff_has_codomain by simp
show 1: "\<And>f g. g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
using comp_def ARR_comp null_char arr_iff_ARR by metis
fix f g h
show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
using seq_char' by auto
show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
using seq_char' by auto
show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
using seq_char' ARR_comp arr_iff_ARR by auto
show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
using seq_char comp_assoc by auto
qed
lemma mkarr_rep [simp]:
assumes "arr f"
shows "mkarr (rep f) = f"
using assms arr_iff_ARR by simp
lemma arr_mkarr [simp]:
assumes "Arr t"
shows "arr (mkarr t)"
using assms by (simp add: ARR_mkarr arr_iff_ARR)
lemma mkarr_memb:
assumes "t \<in> f" and "arr f"
shows "Arr t" and "mkarr t = f"
using assms arr_char mkarr_extensionality by auto
lemma rep_in_arr [simp]:
assumes "arr f"
shows "rep f \<in> f"
using assms by (simp add: rep_in_ARR arr_iff_ARR)
lemma Arr_rep [simp]:
assumes "arr f"
shows "Arr (rep f)"
using assms mkarr_memb rep_in_arr by blast
lemma rep_in_Hom:
assumes "arr f"
shows "rep f \<in> Hom (DOM f) (COD f)"
using assms by simp
lemma norm_memb_eq_rep:
assumes "arr f" and "t \<in> f"
shows "\<^bold>\<parallel>t\<^bold>\<parallel> = rep f"
using assms arr_iff_ARR norm_memb_eq_rep_ARR by auto
lemma norm_rep:
assumes "arr f"
shows "\<^bold>\<parallel>rep f\<^bold>\<parallel> = rep f"
using assms norm_memb_eq_rep by simp
text \<open>
Composition, domain, and codomain on arrows reduce to the corresponding
syntactic operations on their representative terms.
\<close>
lemma comp_mkarr [simp]:
assumes "Arr t" and "Arr u" and "Dom t = Cod u"
shows "mkarr t \<cdot> mkarr u = mkarr (t \<^bold>\<cdot> u)"
using assms
by (metis (no_types, lifting) ARR_mkarr ARR_comp ARR_def Arr_in_mkarr COD_mkarr
Comp_in_comp_ARR DOM_mkarr mkarr_def)
lemma dom_char:
shows "dom f = (if arr f then mkarr (DOM f) else null)"
proof -
have "\<not>arr f \<Longrightarrow> ?thesis"
using dom_def by (simp add: arr_def)
moreover have "arr f \<Longrightarrow> ?thesis"
proof -
assume f: "arr f"
have "dom f = mkarr (DOM f)"
proof (intro dom_eqI)
have 1: "Ide (DOM f)"
using f arr_char by (metis Arr_rep Arr_implies_Ide_Dom)
hence 2: "IDE (mkarr (DOM f))"
using IDE_mkarr_Ide by metis
thus "ide (mkarr (DOM f))" using IDE_implies_ide by simp
moreover show "seq f (mkarr (DOM f))"
proof -
have "f \<cdot> mkarr (DOM f) \<noteq> null"
using f 1 2 ARR_def DOM_mkarr IDE_implies_ARR Ide_in_Hom ARR_comp IDE_def
ARR_iff_has_codomain ARR_iff_has_domain null_char arr_def
by (metis (mono_tags, lifting) mem_Collect_eq)
thus ?thesis using seq_char by simp
qed
qed
thus ?thesis using f by simp
qed
ultimately show ?thesis by blast
qed
lemma dom_simp:
assumes "arr f"
shows "dom f = mkarr (DOM f)"
using assms dom_char by simp
lemma cod_char:
shows "cod f = (if arr f then mkarr (COD f) else null)"
proof -
have "\<not>arr f \<Longrightarrow> ?thesis"
using cod_def by (simp add: arr_def)
moreover have "arr f \<Longrightarrow> ?thesis"
proof -
assume f: "arr f"
have "cod f = mkarr (COD f)"
proof (intro cod_eqI)
have 1: "Ide (COD f)"
using f arr_char by (metis Arr_rep Arr_implies_Ide_Cod)
hence 2: "IDE (mkarr (COD f))"
using IDE_mkarr_Ide by metis
thus "ide (mkarr (COD f))" using IDE_implies_ide by simp
moreover show "seq (mkarr (COD f)) f"
proof -
have "mkarr (COD f) \<cdot> f \<noteq> null"
using f 1 2 ARR_def DOM_mkarr IDE_implies_ARR Ide_in_Hom ARR_comp IDE_def
ARR_iff_has_codomain ARR_iff_has_domain null_char arr_def
by (metis (mono_tags, lifting) mem_Collect_eq)
thus ?thesis using seq_char by simp
qed
qed
thus ?thesis using f by simp
qed
ultimately show ?thesis by blast
qed
lemma cod_simp:
assumes "arr f"
shows "cod f = mkarr (COD f)"
using assms cod_char by simp
lemma Dom_memb:
assumes "arr f" and "t \<in> f"
shows "Dom t = DOM f"
using assms DOM_mkarr mkarr_extensionality arr_char by fastforce
lemma Cod_memb:
assumes "arr f" and "t \<in> f"
shows "Cod t = COD f"
using assms COD_mkarr mkarr_extensionality arr_char by fastforce
lemma dom_mkarr [simp]:
assumes "Arr t"
shows "dom (mkarr t) = mkarr (Dom t)"
using assms dom_char DOM_mkarr arr_mkarr by auto
lemma cod_mkarr [simp]:
assumes "Arr t"
shows "cod (mkarr t) = mkarr (Cod t)"
using assms cod_char COD_mkarr arr_mkarr by auto
lemma mkarr_in_hom:
assumes "Arr t"
shows "\<guillemotleft>mkarr t : mkarr (Dom t) \<rightarrow> mkarr (Cod t)\<guillemotright>"
using assms arr_mkarr dom_mkarr cod_mkarr by auto
lemma DOM_in_dom [intro]:
assumes "arr f"
shows "DOM f \<in> dom f"
using assms dom_char
by (metis Arr_in_mkarr mkarr_extensionality ideD(1) ide_dom not_arr_null null_char)
lemma COD_in_cod [intro]:
assumes "arr f"
shows "COD f \<in> cod f"
using assms cod_char
by (metis Arr_in_mkarr mkarr_extensionality ideD(1) ide_cod not_arr_null null_char)
lemma DOM_dom:
assumes "arr f"
shows "DOM (dom f) = DOM f"
using assms Arr_rep Arr_implies_Ide_Dom Ide_implies_Arr dom_char rep_mkarr Par_Arr_norm
Ide_in_Hom
by simp
lemma DOM_cod:
assumes "arr f"
shows "DOM (cod f) = COD f"
using assms Arr_rep Arr_implies_Ide_Cod Ide_implies_Arr cod_char rep_mkarr Par_Arr_norm
Ide_in_Hom
by simp
lemma memb_equiv:
assumes "arr f" and "t \<in> f" and "u \<in> f"
shows "Par t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
proof -
show "Par t u"
using assms Cod_memb Dom_memb mkarr_memb(1) by metis
show "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using assms arr_iff_ARR ARR_def by auto
qed
text \<open>
Two arrows can be proved equal by showing that they are parallel and
have representatives with identical diagonalizations.
\<close>
lemma arr_eqI:
assumes "par f g" and "t \<in> f" and "u \<in> g" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "f = g"
proof -
have "Arr t \<and> Arr u" using assms mkarr_memb(1) by blast
moreover have "Dom t = Dom u \<and> Cod t = Cod u"
using assms Dom_memb Cod_memb comp_def arr_char comp_arr_dom comp_cod_arr
by (metis (full_types))
ultimately have "Par t u" by simp
thus ?thesis
using assms arr_char by (metis rep_mkarr rep_in_arr equiv_iff_eq_norm)
qed
lemma comp_char:
shows "f \<cdot> g = (if seq f g then mkarr (rep f \<^bold>\<cdot> rep g) else null)"
using comp_def seq_char arr_char by meson
text \<open>
The mapping that takes identity terms to their equivalence classes is injective.
\<close>
lemma mkarr_inj_on_Ide:
assumes "Ide t" and "Ide u" and "mkarr t = mkarr u"
shows "t = u"
using assms
by (metis (mono_tags, lifting) COD_mkarr Ide_in_Hom mem_Collect_eq)
lemma Comp_in_comp [intro]:
assumes "arr f" and "g \<in> hom (dom g) (dom f)" and "t \<in> f" and "u \<in> g"
shows "t \<^bold>\<cdot> u \<in> f \<cdot> g"
proof -
have "ARR f" using assms arr_iff_ARR by simp
moreover have "ARR g" using assms arr_iff_ARR by auto
moreover have "DOM f = COD g"
using assms dom_char cod_char mkarr_inj_on_Ide Arr_implies_Ide_Cod Arr_implies_Ide_Dom
by force
ultimately show ?thesis using assms Comp_in_comp_ARR by simp
qed
text \<open>
An arrow is defined to be ``canonical'' if some (equivalently, all) its representatives
diagonalize to an identity term.
\<close>
definition can
where "can f \<equiv> arr f \<and> (\<exists>t. t \<in> f \<and> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
lemma can_def_alt:
shows "can f \<longleftrightarrow> arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
proof
assume "arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
thus "can f" using can_def arr_char by fastforce
next
assume f: "can f"
show "arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
proof -
obtain t where t: "t \<in> f \<and> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>" using f can_def by auto
have "ARR f" using f can_def arr_char ARR_def mkarr_def by simp
hence "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = \<^bold>\<parallel>t\<^bold>\<parallel>" using t unique_norm by auto
hence "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using t by (metis \<open>ARR f\<close> equiv_iff_eq_norm arr_iff_ARR mkarr_memb(1))
hence "\<forall>u. u \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using t by metis
thus ?thesis using f can_def by blast
qed
qed
lemma can_implies_arr:
assumes "can f"
shows "arr f"
using assms can_def by auto
text \<open>
The identities of the category are precisely the canonical endo-arrows.
\<close>
lemma ide_char:
shows "ide f \<longleftrightarrow> can f \<and> dom f = cod f"
proof
assume f: "ide f"
show "can f \<and> dom f = cod f"
using f can_def arr_char dom_char cod_char IDE_def Arr_implies_Ide_Cod can_def_alt
Arr_rep IDE_mkarr_Ide
by (metis ideD(1) ideD(3))
next
assume f: "can f \<and> dom f = cod f"
show "ide f"
proof -
have "f = dom f"
proof (intro arr_eqI)
show "par f (dom f)" using f can_def by simp
show "rep f \<in> f" using f can_def by simp
show "DOM f \<in> dom f" using f can_def by auto
show "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>DOM f\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>DOM f\<^bold>\<rfloor> \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
using f can_def Diagonalize_in_Hom by simp
moreover have "Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" using f can_def_alt rep_in_arr by simp
ultimately show ?thesis
using f can_def Ide_in_Hom by simp
qed
qed
thus ?thesis using f can_implies_arr ide_dom [of f] by auto
qed
qed
lemma ide_iff_IDE:
shows "ide a \<longleftrightarrow> IDE a"
using ide_char IDE_def can_def_alt arr_iff_ARR dom_char cod_char mkarr_inj_on_Ide
Arr_implies_Ide_Cod Arr_implies_Ide_Dom Arr_rep
by auto
lemma ide_mkarr_Ide:
assumes "Ide a"
shows "ide (mkarr a)"
using assms IDE_mkarr_Ide ide_iff_IDE by simp
lemma rep_dom:
assumes "arr f"
shows "rep (dom f) = \<^bold>\<parallel>DOM f\<^bold>\<parallel>"
using assms dom_simp rep_mkarr Arr_rep Arr_implies_Ide_Dom by simp
lemma rep_cod:
assumes "arr f"
shows "rep (cod f) = \<^bold>\<parallel>COD f\<^bold>\<parallel>"
using assms cod_simp rep_mkarr Arr_rep Arr_implies_Ide_Cod by simp
lemma rep_preserves_seq:
assumes "seq g f"
shows "Seq (rep g) (rep f)"
using assms Arr_rep dom_char cod_char mkarr_inj_on_Ide Arr_implies_Ide_Dom
Arr_implies_Ide_Cod
by auto
lemma rep_comp:
assumes "seq g f"
shows "rep (g \<cdot> f) = \<^bold>\<parallel>rep g \<^bold>\<cdot> rep f\<^bold>\<parallel>"
proof -
have "rep (g \<cdot> f) = rep (mkarr (rep g \<^bold>\<cdot> rep f))"
using assms comp_char by metis
also have "... = \<^bold>\<parallel>rep g \<^bold>\<cdot> rep f\<^bold>\<parallel>"
using assms rep_preserves_seq rep_mkarr by simp
finally show ?thesis by blast
qed
text \<open>
The equivalence classes of canonical terms are canonical arrows.
\<close>
lemma can_mkarr_Can:
assumes "Can t"
shows "can (mkarr t)"
using assms Arr_in_mkarr Can_implies_Arr Ide_Diagonalize_Can arr_mkarr can_def by blast
lemma ide_implies_can:
assumes "ide a"
shows "can a"
using assms ide_char by blast
lemma Can_rep_can:
assumes "can f"
shows "Can (rep f)"
proof -
have "Can \<^bold>\<parallel>rep f\<^bold>\<parallel>"
using assms can_def_alt Can_norm_iff_Ide_Diagonalize by auto
moreover have "rep f = \<^bold>\<parallel>rep f\<^bold>\<parallel>"
using assms can_implies_arr norm_rep by simp
ultimately show ?thesis by simp
qed
text \<open>
Parallel canonical arrows are identical.
\<close>
lemma can_coherence:
assumes "par f g" and "can f" and "can g"
shows "f = g"
proof -
have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>DOM f\<^bold>\<rfloor>"
using assms Ide_Diagonalize_Can Can_rep_can Diagonalize_in_Hom Ide_in_Hom by force
also have "... = \<^bold>\<lfloor>DOM g\<^bold>\<rfloor>"
using assms dom_char equiv_iff_eq_norm
by (metis DOM_in_dom mkarr_memb(1) rep_mkarr arr_dom_iff_arr)
also have "... = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
using assms Ide_Diagonalize_Can Can_rep_can Diagonalize_in_Hom Ide_in_Hom by force
finally show ?thesis by blast
qed
hence "rep f = rep g"
using assms rep_in_arr norm_memb_eq_rep equiv_iff_eq_norm
by (metis (no_types, lifting) arr_eqI)
thus ?thesis
using assms arr_eqI [of f g] rep_in_arr [of f] rep_in_arr [of g] by metis
qed
text \<open>
Canonical arrows are invertible, and their inverses can be obtained syntactically.
\<close>
lemma inverse_arrows_can:
assumes "can f"
shows "inverse_arrows f (mkarr (Inv (DOM f\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> COD f\<^bold>\<down>))"
proof
let ?t = "(Inv (DOM f\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> COD f\<^bold>\<down>)"
have 1: "rep f \<in> f \<and> Arr (rep f) \<and> Can (rep f) \<and> Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms can_def_alt rep_in_arr rep_in_arr(1) Can_rep_can by simp
hence 2: "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
using Diagonalize_in_Hom [of "rep f"] Ide_in_Hom by auto
have 3: "Can ?t"
using assms 1 2 Can_red Ide_implies_Can Diagonalize_in_Hom Inv_preserves_Can
Arr_implies_Ide_Cod Arr_implies_Ide_Dom Diag_Diagonalize
by simp
have 4: "DOM f = Cod ?t"
using assms can_def Can_red
by (simp add: Arr_implies_Ide_Dom Inv_preserves_Can(3))
have 5: "COD f = Dom ?t"
using assms can_def Can_red Arr_rep Arr_implies_Ide_Cod by simp
have 6: "antipar f (mkarr ?t)"
using assms 3 4 5 dom_char cod_char can_def cod_mkarr dom_mkarr Can_implies_Arr
by simp
show "ide (f \<cdot> mkarr ?t)"
proof -
have 7: "par (f \<cdot> mkarr ?t) (dom (f \<cdot> mkarr ?t))"
using assms 6 by auto
moreover have "can (f \<cdot> mkarr ?t)"
proof -
have 8: "Comp (rep f) ?t \<in> (f \<cdot> mkarr ?t)"
using assms 1 3 4 6 can_implies_arr Arr_in_mkarr COD_mkarr Comp_in_comp_ARR
Can_implies_Arr arr_iff_ARR seq_char'
by meson
moreover have "Can (rep f \<^bold>\<cdot> ?t)"
using 1 3 7 8 mkarr_memb(1) by (metis Arr.simps(4) Can.simps(4))
ultimately show ?thesis
using can_mkarr_Can 7 mkarr_memb(2) by metis
qed
moreover have "can (dom (f \<cdot> mkarr ?t))"
using 7 ide_implies_can by force
ultimately have "f \<cdot> mkarr ?t = dom (f \<cdot> mkarr ?t)"
using can_coherence by meson
thus ?thesis
using 7 ide_dom by metis
qed
show "ide (mkarr ?t \<cdot> f)"
proof -
have 7: "par (mkarr ?t \<cdot> f) (cod (mkarr ?t \<cdot> f))"
using assms 6 by auto
moreover have "can (mkarr ?t \<cdot> f)"
proof -
have 8: "Comp ?t (rep f) \<in> mkarr ?t \<cdot> f"
using assms 1 3 6 7 Arr_in_mkarr Comp_in_comp_ARR Can_implies_Arr arr_char
comp_def
by meson
moreover have "Can (?t \<^bold>\<cdot> rep f)"
using 1 3 7 8 mkarr_memb(1) by (metis Arr.simps(4) Can.simps(4))
ultimately show ?thesis
using can_mkarr_Can 7 mkarr_memb(2) by metis
qed
moreover have "can (cod (mkarr ?t \<cdot> f))"
using 7 ide_implies_can by force
ultimately have "mkarr ?t \<cdot> f = cod (mkarr ?t \<cdot> f)"
using can_coherence by meson
thus ?thesis
using 7 can_implies_arr ide_cod by metis
qed
qed
lemma inv_mkarr [simp]:
assumes "Can t"
shows "inv (mkarr t) = mkarr (Inv t)"
proof -
have t: "Can t \<and> Arr t \<and> Can (Inv t) \<and> Arr (Inv t) \<and> Ide (Dom t) \<and> Ide (Cod t)"
using assms Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod
Inv_preserves_Can
by simp
have "inverse_arrows (mkarr t) (mkarr (Inv t))"
proof
show "ide (mkarr t \<cdot> mkarr (Inv t))"
proof -
have "mkarr (Cod t) = mkarr (Comp t (Inv t))"
using t Inv_in_Hom Ide_in_Hom Diagonalize_Inv Diag_Diagonalize Diagonalize_preserves_Can
by (intro mkarr_eqI, auto)
also have "... = mkarr t \<cdot> mkarr (Inv t)"
using t comp_mkarr Inv_in_Hom by simp
finally have "mkarr (Cod t) = mkarr t \<cdot> mkarr (Inv t)"
by blast
thus ?thesis using t ide_mkarr_Ide [of "Cod t"] by simp
qed
show "ide (mkarr (Inv t) \<cdot> mkarr t)"
proof -
have "mkarr (Dom t) = mkarr (Inv t \<^bold>\<cdot> t)"
using t Inv_in_Hom Ide_in_Hom Diagonalize_Inv Diag_Diagonalize Diagonalize_preserves_Can
by (intro mkarr_eqI, auto)
also have "... = mkarr (Inv t) \<cdot> mkarr t"
using t comp_mkarr Inv_in_Hom by simp
finally have "mkarr (Dom t) = mkarr (Inv t) \<cdot> mkarr t"
by blast
thus ?thesis using t ide_mkarr_Ide [of "Dom t"] by simp
qed
qed
thus ?thesis using inverse_unique by auto
qed
lemma iso_can:
assumes "can f"
shows "iso f"
using assms inverse_arrows_can by auto
text \<open>
The following function produces the unique canonical arrow between two given objects,
if such an arrow exists.
\<close>
definition mkcan
where "mkcan a b = mkarr (Inv (COD b\<^bold>\<down>) \<^bold>\<cdot> (DOM a\<^bold>\<down>))"
lemma can_mkcan:
assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
shows "can (mkcan a b)" and "\<guillemotleft>mkcan a b : a \<rightarrow> b\<guillemotright>"
proof -
show "can (mkcan a b)"
using assms mkcan_def Arr_rep Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red
Inv_preserves_Can can_mkarr_Can
by simp
show "\<guillemotleft>mkcan a b : a \<rightarrow> b\<guillemotright>"
using assms mkcan_def Arr_rep Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red Inv_in_Hom
dom_char [of a] cod_char [of b] mkarr_rep mkarr_in_hom can_implies_arr
by auto
qed
lemma dom_mkcan:
assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
shows "dom (mkcan a b) = a"
using assms can_mkcan by blast
lemma cod_mkcan:
assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
shows "cod (mkcan a b) = b"
using assms can_mkcan by blast
lemma can_coherence':
assumes "can f"
shows "mkcan (dom f) (cod f) = f"
proof -
have "Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms Ide_Diagonalize_Can Can_rep_can by simp
hence "Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using Ide_in_Hom by simp
hence "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
using assms can_implies_arr Arr_rep Diagonalize_in_Hom by simp
moreover have "DOM f = DOM (dom f)"
using assms can_implies_arr dom_char rep_mkarr Arr_implies_Ide_Dom Ide_implies_Arr
Par_Arr_norm [of "DOM f"] Ide_in_Hom
by auto
moreover have "COD f = COD (cod f)"
using assms can_implies_arr cod_char rep_mkarr Arr_implies_Ide_Cod Ide_implies_Arr
Par_Arr_norm [of "COD f"] Ide_in_Hom
by auto
ultimately have "can (mkcan (dom f) (cod f)) \<and> par f (mkcan (dom f) (cod f))"
using assms can_implies_arr can_mkcan dom_mkcan cod_mkcan by simp
thus ?thesis using assms can_coherence by blast
qed
lemma Ide_Diagonalize_rep_ide:
assumes "ide a"
shows "Ide \<^bold>\<lfloor>rep a\<^bold>\<rfloor>"
using assms ide_implies_can can_def_alt rep_in_arr by simp
lemma Diagonalize_DOM:
assumes "arr f"
shows "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms Diag_Diagonalize by simp
lemma Diagonalize_COD:
assumes "arr f"
shows "\<^bold>\<lfloor>COD f\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms Diag_Diagonalize by simp
lemma Diagonalize_rep_preserves_seq:
assumes "seq g f"
shows "Seq \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms Diagonalize_DOM Diagonalize_COD Diag_implies_Arr Diag_Diagonalize(1)
rep_preserves_seq
by force
lemma Dom_Diagonalize_rep:
assumes "arr f"
shows "Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep (dom f)\<^bold>\<rfloor>"
using assms Diagonalize_rep_preserves_seq [of f "dom f"] Ide_Diagonalize_rep_ide Ide_in_Hom
by simp
lemma Cod_Diagonalize_rep:
assumes "arr f"
shows "Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep (cod f)\<^bold>\<rfloor>"
using assms Diagonalize_rep_preserves_seq [of "cod f" f] Ide_Diagonalize_rep_ide Ide_in_Hom
by simp
lemma mkarr_Diagonalize_rep:
assumes "arr f" and "Diag (DOM f)" and "Diag (COD f)"
shows "mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = f"
proof -
have "mkarr (rep f) = mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms rep_in_Hom Diagonalize_in_Hom Diag_Diagonalize Diagonalize_Diag
by (intro mkarr_eqI, simp_all)
thus ?thesis using assms mkarr_rep by auto
qed
text \<open>
We define tensor product of arrows via the constructor @{term Tensor} on terms.
\<close>
definition tensor\<^sub>F\<^sub>M\<^sub>C (infixr "\<otimes>" 53)
where "f \<otimes> g \<equiv> (if arr f \<and> arr g then mkarr (rep f \<^bold>\<otimes> rep g) else null)"
lemma arr_tensor [simp]:
assumes "arr f" and "arr g"
shows "arr (f \<otimes> g)"
using assms tensor\<^sub>F\<^sub>M\<^sub>C_def arr_mkarr by simp
lemma rep_tensor:
assumes "arr f" and "arr g"
shows "rep (f \<otimes> g) = \<^bold>\<parallel>rep f \<^bold>\<otimes> rep g\<^bold>\<parallel>"
using assms tensor\<^sub>F\<^sub>M\<^sub>C_def rep_mkarr by simp
lemma Par_memb_rep:
assumes "arr f" and "t \<in> f"
shows "Par t (rep f)"
using assms mkarr_memb apply simp
using rep_in_Hom Dom_memb Cod_memb by metis
lemma Tensor_in_tensor [intro]:
assumes "arr f" and "arr g" and "t \<in> f" and "u \<in> g"
shows "t \<^bold>\<otimes> u \<in> f \<otimes> g"
proof -
have "equiv (t \<^bold>\<otimes> u) (rep f \<^bold>\<otimes> rep g)"
proof -
have 1: "Par (t \<^bold>\<otimes> u) (rep f \<^bold>\<otimes> rep g)"
proof -
have "Par t (rep f) \<and> Par u (rep g)" using assms Par_memb_rep by blast
thus ?thesis by simp
qed
moreover have "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<otimes> rep g\<^bold>\<rfloor>"
using assms 1 equiv_iff_eq_norm rep_mkarr norm_norm mkarr_memb(2)
by (metis Arr.simps(3) Diagonalize.simps(3))
ultimately show ?thesis by simp
qed
thus ?thesis
using assms tensor\<^sub>F\<^sub>M\<^sub>C_def mkarr_def by simp
qed
lemma DOM_tensor [simp]:
assumes "arr f" and "arr g"
shows "DOM (f \<otimes> g) = DOM f \<^bold>\<otimes> DOM g"
by (metis (no_types, lifting) DOM_mkarr Dom.simps(3) mkarr_extensionality arr_char
arr_tensor assms(1) assms(2) tensor\<^sub>F\<^sub>M\<^sub>C_def)
lemma COD_tensor [simp]:
assumes "arr f" and "arr g"
shows "COD (f \<otimes> g) = COD f \<^bold>\<otimes> COD g"
by (metis (no_types, lifting) COD_mkarr Cod.simps(3) mkarr_extensionality arr_char
arr_tensor assms(1) assms(2) tensor\<^sub>F\<^sub>M\<^sub>C_def)
lemma tensor_in_hom [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
shows "\<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
proof -
have f: "arr f \<and> dom f = a \<and> cod f = b" using assms(1) by auto
have g: "arr g \<and> dom g = c \<and> cod g = d" using assms(2) by auto
have "dom (f \<otimes> g) = dom f \<otimes> dom g"
using f g arr_tensor dom_char Tensor_in_tensor [of "dom f" "dom g" "DOM f" "DOM g"]
DOM_in_dom mkarr_memb(2) DOM_tensor arr_dom_iff_arr
by metis
moreover have "cod (f \<otimes> g) = cod f \<otimes> cod g"
using f g arr_tensor cod_char Tensor_in_tensor [of "cod f" "cod g" "COD f" "COD g"]
COD_in_cod mkarr_memb(2) COD_tensor arr_cod_iff_arr
by metis
ultimately show ?thesis using assms arr_tensor by blast
qed
lemma dom_tensor [simp]:
assumes "arr f" and "arr g"
shows "dom (f \<otimes> g) = dom f \<otimes> dom g"
using assms tensor_in_hom [of f] by blast
lemma cod_tensor [simp]:
assumes "arr f" and "arr g"
shows "cod (f \<otimes> g) = cod f \<otimes> cod g"
using assms tensor_in_hom [of f] by blast
lemma tensor_mkarr [simp]:
assumes "Arr t" and "Arr u"
shows "mkarr t \<otimes> mkarr u = mkarr (t \<^bold>\<otimes> u)"
using assms by (meson Tensor_in_tensor arr_char Arr_in_mkarr arr_mkarr arr_tensor)
lemma tensor_preserves_ide:
assumes "ide a" and "ide b"
shows "ide (a \<otimes> b)"
proof -
have "can (a \<otimes> b)"
using assms tensor\<^sub>F\<^sub>M\<^sub>C_def Can_rep_can ide_implies_can can_mkarr_Can by simp
moreover have "dom (a \<otimes> b) = cod (a \<otimes> b)"
using assms tensor_in_hom by simp
ultimately show ?thesis using ide_char by metis
qed
lemma tensor_preserves_can:
assumes "can f" and "can g"
shows "can (f \<otimes> g)"
using assms can_implies_arr Can_rep_can tensor\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can by simp
lemma comp_preserves_can:
assumes "can f" and "can g" and "dom f = cod g"
shows "can (f \<cdot> g)"
proof -
have 1: "ARR f \<and> ARR g \<and> DOM f = COD g"
using assms can_implies_arr arr_iff_ARR Arr_implies_Ide_Cod Arr_implies_Ide_Dom
mkarr_inj_on_Ide cod_char dom_char
by simp
hence "Can (rep f \<^bold>\<cdot> rep g)"
using assms can_implies_arr Can_rep_can by force
thus ?thesis
using assms 1 can_implies_arr comp_char can_mkarr_Can seq_char' by simp
qed
text \<open>
The remaining structure required of a monoidal category is also defined syntactically.
\<close>
definition unity\<^sub>F\<^sub>M\<^sub>C :: "'c arr" ("\<I>")
where "\<I> = mkarr \<^bold>\<I>"
definition lunit\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr" ("\<l>[_]")
where "\<l>[a] = mkarr \<^bold>\<l>\<^bold>[rep a\<^bold>]"
definition runit\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr" ("\<r>[_]")
where "\<r>[a] = mkarr \<^bold>\<r>\<^bold>[rep a\<^bold>]"
definition assoc\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr \<Rightarrow> 'c arr \<Rightarrow> 'c arr" ("\<a>[_, _, _]")
where "\<a>[a, b, c] = mkarr \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>]"
lemma can_lunit:
assumes "ide a"
shows "can \<l>[a]"
using assms lunit\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
by (simp add: Can_rep_can ide_implies_can)
lemma lunit_in_hom:
assumes "ide a"
shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
proof -
have "dom \<l>[a] = \<I> \<otimes> a"
using assms lunit\<^sub>F\<^sub>M\<^sub>C_def unity\<^sub>F\<^sub>M\<^sub>C_def Ide_implies_Arr dom_mkarr dom_char tensor_mkarr
Arr_rep
by (metis Arr.simps(2) Arr.simps(5) Arr_implies_Ide_Dom Dom.simps(5)
ideD(1) ideD(2))
moreover have "cod \<l>[a] = a"
using assms lunit\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) cod_mkarr cod_char ideD(3) by auto
ultimately show ?thesis
using assms arr_cod_iff_arr by (intro in_homI, fastforce)
qed
lemma arr_lunit [simp]:
assumes "ide a"
shows "arr \<l>[a]"
using assms can_lunit can_implies_arr by simp
lemma dom_lunit [simp]:
assumes "ide a"
shows "dom \<l>[a] = \<I> \<otimes> a"
using assms lunit_in_hom by auto
lemma cod_lunit [simp]:
assumes "ide a"
shows "cod \<l>[a] = a"
using assms lunit_in_hom by auto
lemma can_runit:
assumes "ide a"
shows "can \<r>[a]"
using assms runit\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
by (simp add: Can_rep_can ide_implies_can)
lemma runit_in_hom [simp]:
assumes "ide a"
shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
proof -
have "dom \<r>[a] = a \<otimes> \<I>"
using assms Arr_rep Arr.simps(2) Arr.simps(7) Arr_implies_Ide_Dom Dom.simps(7)
Ide_implies_Arr dom_mkarr dom_char ideD(1) ideD(2) runit\<^sub>F\<^sub>M\<^sub>C_def tensor_mkarr
unity\<^sub>F\<^sub>M\<^sub>C_def
by metis
moreover have "cod \<r>[a] = a"
using assms runit\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) cod_mkarr cod_char ideD(3) by auto
ultimately show ?thesis
using assms arr_cod_iff_arr by (intro in_homI, fastforce)
qed
lemma arr_runit [simp]:
assumes "ide a"
shows "arr \<r>[a]"
using assms can_runit can_implies_arr by simp
lemma dom_runit [simp]:
assumes "ide a"
shows "dom \<r>[a] = a \<otimes> \<I>"
using assms runit_in_hom by blast
lemma cod_runit [simp]:
assumes "ide a"
shows "cod \<r>[a] = a"
using assms runit_in_hom by blast
lemma can_assoc:
assumes "ide a" and "ide b" and "ide c"
shows "can \<a>[a, b, c]"
using assms assoc\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
by (simp add: Can_rep_can ide_implies_can)
lemma assoc_in_hom:
assumes "ide a" and "ide b" and "ide c"
shows "\<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>"
proof -
have "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
proof -
have "dom \<a>[a, b, c] = mkarr (Dom \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>])"
using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) by simp
also have "... = mkarr ((DOM a \<^bold>\<otimes> DOM b) \<^bold>\<otimes> DOM c)"
by simp
also have "... = (a \<otimes> b) \<otimes> c"
by (metis mkarr_extensionality arr_tensor assms dom_char
ideD(1) ideD(2) not_arr_null null_char tensor_mkarr)
finally show ?thesis by blast
qed
moreover have "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
proof -
have "cod \<a>[a, b, c] = mkarr (Cod \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>])"
using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) by simp
also have "... = mkarr (COD a \<^bold>\<otimes> COD b \<^bold>\<otimes> COD c)"
by simp
also have "... = a \<otimes> b \<otimes> c"
by (metis mkarr_extensionality arr_tensor assms(1) assms(2) assms(3) cod_char
ideD(1) ideD(3) not_arr_null null_char tensor_mkarr)
finally show ?thesis by blast
qed
moreover have "arr \<a>[a, b, c]"
using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) arr_mkarr by simp
ultimately show ?thesis by auto
qed
lemma arr_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "arr \<a>[a, b, c]"
using assms can_assoc can_implies_arr by simp
lemma dom_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
using assms assoc_in_hom by blast
lemma cod_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
using assms assoc_in_hom by blast
lemma ide_unity [simp]:
shows "ide \<I>"
using unity\<^sub>F\<^sub>M\<^sub>C_def Arr.simps(2) Dom.simps(2) arr_mkarr dom_mkarr ide_dom
by metis
lemma Unity_in_unity [simp]:
shows "\<^bold>\<I> \<in> \<I>"
using unity\<^sub>F\<^sub>M\<^sub>C_def Arr_in_mkarr by simp
lemma rep_unity [simp]:
shows "rep \<I> = \<^bold>\<parallel>\<^bold>\<I>\<^bold>\<parallel>"
using unity\<^sub>F\<^sub>M\<^sub>C_def rep_mkarr by simp
lemma Lunit_in_lunit [intro]:
assumes "arr f" and "t \<in> f"
shows "\<^bold>\<l>\<^bold>[t\<^bold>] \<in> \<l>[f]"
proof -
have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms
by (metis mkarr_memb(1) mkarr_memb(2) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm
norm_rep)
thus ?thesis
by (simp add: mkarr_def lunit\<^sub>F\<^sub>M\<^sub>C_def)
qed
lemma Runit_in_runit [intro]:
assumes "arr f" and "t \<in> f"
shows "\<^bold>\<r>\<^bold>[t\<^bold>] \<in> \<r>[f]"
proof -
have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms
by (metis mkarr_memb(1) mkarr_memb(2) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm
norm_rep)
thus ?thesis
by (simp add: mkarr_def runit\<^sub>F\<^sub>M\<^sub>C_def)
qed
lemma Assoc_in_assoc [intro]:
assumes "arr f" and "arr g" and "arr h"
and "t \<in> f" and "u \<in> g" and "v \<in> h"
shows "\<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<in> \<a>[f, g, h]"
proof -
have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using assms
by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
norm_rep)
moreover have "Arr u \<and> Arr (rep g) \<and> Dom u = DOM g \<and> Cod u = COD g \<and>
\<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
using assms
by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
norm_rep)
moreover have "Arr v \<and> Arr (rep h) \<and> Dom v = DOM h \<and> Cod v = COD h \<and>
\<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>rep h\<^bold>\<rfloor>"
using assms
by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
norm_rep)
ultimately show ?thesis
using assoc\<^sub>F\<^sub>M\<^sub>C_def mkarr_def by simp
qed
text \<open>
At last, we can show that we've constructed a monoidal category.
\<close>
interpretation EMC: elementary_monoidal_category
comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C
proof
show "ide \<I>" using ide_unity by auto
show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" by auto
show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" by auto
show "\<And>a. ide a \<Longrightarrow> iso \<l>[a]" using can_lunit iso_can by auto
show "\<And>a. ide a \<Longrightarrow> iso \<r>[a]" using can_runit iso_can by auto
show "\<And>a b c. \<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>" by auto
show "\<And>a b c. \<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> iso \<a>[a, b, c]" using can_assoc iso_can by auto
show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes> b)" using tensor_preserves_ide by auto
fix f a b g c d
show "\<lbrakk> \<guillemotleft>f : a \<rightarrow> b\<guillemotright>; \<guillemotleft>g : c \<rightarrow> d\<guillemotright> \<rbrakk> \<Longrightarrow> \<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
using tensor_in_hom by auto
next
text \<open>Naturality of left unitor.\<close>
fix f
assume f: "arr f"
show "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
proof (intro arr_eqI)
show "par (\<l>[cod f] \<cdot> (\<I> \<otimes> f)) (f \<cdot> \<l>[dom f])"
using f by simp
show "\<^bold>\<l>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (\<^bold>\<I> \<^bold>\<otimes> rep f) \<in> \<l>[cod f] \<cdot> (\<I> \<otimes> f)"
using f by fastforce
show "rep f \<^bold>\<cdot> \<^bold>\<l>\<^bold>[DOM f\<^bold>] \<in> f \<cdot> \<l>[dom f]"
using f by fastforce
show "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (\<^bold>\<I> \<^bold>\<otimes> rep f)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> \<^bold>\<l>\<^bold>[DOM f\<^bold>]\<^bold>\<rfloor>"
using f by (simp add: Diag_Diagonalize(1) Diagonalize_DOM Diagonalize_COD)
qed
text \<open>Naturality of right unitor.\<close>
show "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
proof (intro arr_eqI)
show "par (\<r>[cod f] \<cdot> (f \<otimes> \<I>)) (f \<cdot> \<r>[dom f])"
using f by simp
show "\<^bold>\<r>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (rep f \<^bold>\<otimes> \<^bold>\<I>) \<in> \<r>[cod f] \<cdot> (f \<otimes> \<I>)"
using f by fastforce
show "rep f \<^bold>\<cdot> \<^bold>\<r>\<^bold>[DOM f\<^bold>] \<in> f \<cdot> \<r>[dom f]"
using f by fastforce
show "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (rep f \<^bold>\<otimes> \<^bold>\<I>)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> \<^bold>\<r>\<^bold>[DOM f\<^bold>]\<^bold>\<rfloor>"
using f by (simp add: Diag_Diagonalize(1) Diagonalize_DOM Diagonalize_COD)
qed
next
text \<open>Naturality of associator.\<close>
fix f0 :: "'c arr" and f1 f2
assume f0: "arr f0" and f1: "arr f1" and f2: "arr f2"
show "\<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)
= (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
proof (intro arr_eqI)
show 1: "par (\<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2))
((f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2])"
using f0 f1 f2 by force
show "\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)
\<in> \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
using f0 f1 f2 by fastforce
show "(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]
\<in> (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
using f0 f1 f2 by fastforce
show "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
= \<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
= \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
proof -
have b0: "\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
using f0 Cod_Diagonalize_rep by simp
have b1: "\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
using f1 Cod_Diagonalize_rep by simp
have b2: "\<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
using f2 Cod_Diagonalize_rep by simp
have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
= (\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>
(\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>)"
using f0 f1 f2 using Diag_Diagonalize(1) TensorDiag_assoc by auto
also have "... = \<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
proof -
have "Seq \<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<and> Seq \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<and>
Seq \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
using f0 f1 f2 rep_in_Hom Diagonalize_in_Hom Dom_Diagonalize_rep Cod_Diagonalize_rep
by auto
thus ?thesis
using f0 f1 f2 b0 b1 b2 TensorDiag_in_Hom TensorDiag_preserves_Diag
Diag_Diagonalize Arr_implies_Ide_Dom Arr_implies_Ide_Cod
CompDiag_TensorDiag
by simp
qed
also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
using f0 b0 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"] Diag_Diagonalize
by simp
moreover have "\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
using f1 b1 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"] Diag_Diagonalize
by simp
moreover have "\<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
using f2 b2 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"] Diag_Diagonalize
by simp
ultimately show ?thesis by argo
qed
finally show ?thesis by blast
qed
also have "... = \<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>"
proof -
have a0: "\<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
using f0 Dom_Diagonalize_rep by simp
have a1: "\<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
using f1 Dom_Diagonalize_rep by simp
have a2: "\<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
using f2 Dom_Diagonalize_rep by simp
have "\<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>
= (\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>
(\<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>)"
using f0 f1 f2 using Diag_Diagonalize(1) TensorDiag_assoc by auto
also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
\<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>"
proof -
have "Seq \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<and> Seq \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<and>
Seq \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>"
using f0 f1 f2 rep_in_Hom Diagonalize_in_Hom Dom_Diagonalize_rep Cod_Diagonalize_rep
by auto
thus ?thesis
using f0 f1 f2 a0 a1 a2 TensorDiag_in_Hom TensorDiag_preserves_Diag
Diag_Diagonalize Arr_implies_Ide_Dom Arr_implies_Ide_Cod
CompDiag_TensorDiag
by force
qed
also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
using f0 a0 CompDiag_Diag_Dom [of "Diagonalize (rep f0)"] Diag_Diagonalize
by simp
moreover have "\<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
using f1 a1 CompDiag_Diag_Dom [of "Diagonalize (rep f1)"] Diag_Diagonalize
by simp
moreover have "\<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
using f2 a2 CompDiag_Diag_Dom [of "Diagonalize (rep f2)"] Diag_Diagonalize
by simp
ultimately show ?thesis by argo
qed
finally show ?thesis by argo
qed
finally show ?thesis by blast
qed
qed
next
text \<open>Tensor preserves composition (interchange).\<close>
fix f g f' g'
show "\<lbrakk> seq g f; seq g' f' \<rbrakk> \<Longrightarrow> (g \<otimes> g') \<cdot> (f \<otimes> f') = g \<cdot> f \<otimes> g' \<cdot> f'"
proof -
assume gf: "seq g f"
assume gf': "seq g' f'"
show ?thesis
proof (intro arr_eqI)
show "par ((g \<otimes> g') \<cdot> (f \<otimes> f')) (g \<cdot> f \<otimes> g' \<cdot> f')"
using gf gf' by fastforce
show "(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f') \<in> (g \<otimes> g') \<cdot> (f \<otimes> f')"
using gf gf' by force
show "rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f' \<in> g \<cdot> f \<otimes> g' \<cdot> f'"
using gf gf'
by (meson Comp_in_comp_ARR Tensor_in_tensor rep_in_arr seqE seq_char')
show "\<^bold>\<lfloor>(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f')\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f'\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f')\<^bold>\<rfloor>
= (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep g'\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f'\<^bold>\<rfloor>)"
by auto
also have "... = \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep g'\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f'\<^bold>\<rfloor>"
using gf gf' Arr_rep Diagonalize_rep_preserves_seq
CompDiag_TensorDiag [of "\<^bold>\<lfloor>rep g\<^bold>\<rfloor>" " \<^bold>\<lfloor>rep g'\<^bold>\<rfloor>" "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>" "\<^bold>\<lfloor>rep f'\<^bold>\<rfloor>"]
Diag_Diagonalize Diagonalize_DOM Diagonalize_COD
by force
also have "... = \<^bold>\<lfloor>rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f'\<^bold>\<rfloor>"
by auto
finally show ?thesis by blast
qed
qed
qed
next
text \<open>The triangle.\<close>
fix a b
assume a: "ide a"
assume b: "ide b"
show "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
proof -
have "par ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b]) (\<r>[a] \<otimes> b)"
using a b by simp
moreover have "can ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b])"
using a b ide_implies_can comp_preserves_can tensor_preserves_can can_assoc can_lunit
by simp
moreover have "can (\<r>[a] \<otimes> b)"
using a b ide_implies_can can_runit tensor_preserves_can by simp
ultimately show ?thesis using can_coherence by blast
qed
next
text \<open>The pentagon.\<close>
fix a b c d
assume a: "ide a"
assume b: "ide b"
assume c: "ide c"
assume d: "ide d"
show "(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)
= \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
proof -
let ?LHS = "(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)"
let ?RHS = "\<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
have "par ?LHS ?RHS"
using a b c d can_assoc tensor_preserves_ide by auto
moreover have "can ?LHS"
using a b c d ide_implies_can comp_preserves_can tensor_preserves_can can_assoc
tensor_preserves_ide
by simp
moreover have "can ?RHS"
using a b c d comp_preserves_can tensor_preserves_can can_assoc tensor_in_hom
tensor_preserves_ide
by simp
ultimately show ?thesis using can_coherence by blast
qed
qed
lemma is_elementary_monoidal_category:
shows "elementary_monoidal_category
comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C"
..
abbreviation T\<^sub>F\<^sub>M\<^sub>C where "T\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.T\<^sub>E\<^sub>M\<^sub>C"
abbreviation \<alpha>\<^sub>F\<^sub>M\<^sub>C where "\<alpha>\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.\<alpha>"
abbreviation \<iota>\<^sub>F\<^sub>M\<^sub>C where "\<iota>\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.\<iota>"
interpretation MC: monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C
using EMC.induces_monoidal_category by auto
lemma induces_monoidal_category:
shows "monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C"
..
end
sublocale free_monoidal_category \<subseteq>
elementary_monoidal_category
comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C
using is_elementary_monoidal_category by auto
sublocale free_monoidal_category \<subseteq> monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C
using induces_monoidal_category by auto
section "Proof of Freeness"
text \<open>
Now we proceed on to establish the freeness of \<open>\<F>C\<close>: each functor
from @{term C} to a monoidal category @{term D} extends uniquely
to a strict monoidal functor from \<open>\<F>C\<close> to D.
\<close>
context free_monoidal_category
begin
lemma rep_lunit:
assumes "ide a"
shows "rep \<l>[a] = \<^bold>\<parallel>\<^bold>\<l>\<^bold>[rep a\<^bold>]\<^bold>\<parallel>"
using assms Lunit_in_lunit [of a "rep a"] rep_in_arr norm_memb_eq_rep [of "\<l>[a]"]
by simp
lemma rep_runit:
assumes "ide a"
shows "rep \<r>[a] = \<^bold>\<parallel>\<^bold>\<r>\<^bold>[rep a\<^bold>]\<^bold>\<parallel>"
using assms Runit_in_runit [of a "rep a"] rep_in_arr norm_memb_eq_rep [of "\<r>[a]"]
by simp
lemma rep_assoc:
assumes "ide a" and "ide b" and "ide c"
shows "rep \<a>[a, b, c] = \<^bold>\<parallel>\<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>]\<^bold>\<parallel>"
using assms Assoc_in_assoc [of a b c "rep a" "rep b" "rep c"] rep_in_arr
norm_memb_eq_rep [of "\<a>[a, b, c]"]
by simp
lemma mkarr_Unity:
shows "mkarr \<^bold>\<I> = \<I>"
using unity\<^sub>F\<^sub>M\<^sub>C_def by simp
text \<open>
The unitors and associator were given syntactic definitions in terms of
corresponding terms, but these were only for the special case of identity
arguments (\emph{i.e.}~the components of the natural transformations).
We need to show that @{term mkarr} gives the correct result for \emph{all}
terms.
\<close>
lemma mkarr_Lunit:
assumes "Arr t"
shows "mkarr \<^bold>\<l>\<^bold>[t\<^bold>] = \<ll> (mkarr t)"
proof -
have "mkarr \<^bold>\<l>\<^bold>[t\<^bold>] = mkarr (t \<^bold>\<cdot> \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>])"
using assms Arr_implies_Ide_Dom Ide_in_Hom Diagonalize_preserves_Ide
Diag_Diagonalize Par_Arr_norm
by (intro mkarr_eqI) simp_all
also have "... = mkarr t \<cdot> mkarr \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>]"
using assms Arr_implies_Ide_Dom Par_Arr_norm Ide_in_Hom by simp
also have "... = mkarr t \<cdot> \<l>[dom (mkarr t)]"
proof -
have "arr \<l>[mkarr (Dom t)]"
using assms Arr_implies_Ide_Dom ide_mkarr_Ide by simp
moreover have "\<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>] \<in> \<l>[mkarr (Dom t)]"
using assms Arr_implies_Ide_Dom Lunit_in_lunit rep_mkarr
rep_in_arr [of "mkarr (Dom t)"]
by simp
ultimately show ?thesis
using assms mkarr_memb(2) by simp
qed
also have "... = \<ll> (mkarr t)"
using assms Arr_implies_Ide_Dom ide_mkarr_Ide lunit_agreement by simp
finally show ?thesis by blast
qed
lemma mkarr_Lunit':
assumes "Arr t"
shows "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<ll>' (mkarr t)"
proof -
have "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = mkarr (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> t)"
using assms Arr_implies_Ide_Cod Ide_in_Hom Diagonalize_preserves_Ide
Diag_Diagonalize Par_Arr_norm
by (intro mkarr_eqI) simp_all
also have "... = mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<cdot> mkarr t"
using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
also have "... = mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t"
proof -
have "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] = mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>])"
using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom
Ide_implies_Can norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
by (intro mkarr_eqI, simp_all)
thus ?thesis by argo
qed
also have "... = \<ll>' (cod (mkarr t)) \<cdot> mkarr t"
proof -
have "mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t = lunit' (cod (mkarr t)) \<cdot> mkarr t"
using assms Arr_implies_Ide_Cod rep_mkarr Par_Arr_norm inv_mkarr
norm_preserves_Can Ide_implies_Can lunit_agreement \<ll>'_ide_simp
Can_implies_Arr arr_mkarr cod_mkarr ide_cod lunit\<^sub>F\<^sub>M\<^sub>C_def
by (metis (no_types, lifting) Can.simps(5))
also have "... = \<ll>' (cod (mkarr t)) \<cdot> mkarr t"
using assms \<ll>'_ide_simp arr_mkarr ide_cod by presburger
finally show ?thesis by blast
qed
also have "... = \<ll>' (mkarr t)"
using assms \<ll>'.is_natural_2 [of "mkarr t"] by simp
finally show ?thesis by blast
qed
lemma mkarr_Runit:
assumes "Arr t"
shows "mkarr \<^bold>\<r>\<^bold>[t\<^bold>] = \<rho> (mkarr t)"
proof -
have "mkarr \<^bold>\<r>\<^bold>[t\<^bold>] = mkarr (t \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>])"
proof -
have "\<not> Diag (Dom t \<^bold>\<otimes> \<^bold>\<I>)" by (cases "Dom t") simp_all
thus ?thesis
using assms Par_Arr_norm Arr_implies_Ide_Dom Ide_in_Hom Diag_Diagonalize
Diagonalize_preserves_Ide
by (intro mkarr_eqI) simp_all
qed
also have "... = mkarr t \<cdot> mkarr \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>]"
using assms Arr_implies_Ide_Dom Par_Arr_norm Ide_in_Hom by simp
also have "... = mkarr t \<cdot> \<r>[dom (mkarr t)]"
proof -
have "arr \<r>[mkarr (Dom t)]"
using assms Arr_implies_Ide_Dom ide_mkarr_Ide by simp
moreover have "\<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>] \<in> \<r>[mkarr (Dom t)]"
using assms Arr_implies_Ide_Dom Runit_in_runit rep_mkarr
rep_in_arr [of "mkarr (Dom t)"]
by simp
moreover have "mkarr (Dom t) = mkarr \<^bold>\<parallel>Dom t\<^bold>\<parallel>"
using assms mkarr_rep rep_mkarr arr_mkarr Ide_implies_Arr Arr_implies_Ide_Dom
by metis
ultimately show ?thesis
using assms mkarr_memb(2) by simp
qed
also have "... = \<rho> (mkarr t)"
using assms Arr_implies_Ide_Dom ide_mkarr_Ide runit_agreement by simp
finally show ?thesis by blast
qed
lemma mkarr_Runit':
assumes "Arr t"
shows "mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<rho>' (mkarr t)"
proof -
have "mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = mkarr (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> t)"
proof -
have "\<not> Diag (Cod t \<^bold>\<otimes> \<^bold>\<I>)" by (cases "Cod t") simp_all
thus ?thesis
using assms Par_Arr_norm Arr_implies_Ide_Cod Ide_in_Hom
Diagonalize_preserves_Ide Diag_Diagonalize
by (intro mkarr_eqI) simp_all
qed
also have "... = mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<cdot> mkarr t"
using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
also have "... = mkarr (Inv \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t"
proof -
have "mkarr (Runit' (norm (Cod t))) = mkarr (Inv (Runit (norm (Cod t))))"
using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom
Ide_implies_Can norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
by (intro mkarr_eqI) simp_all
thus ?thesis by argo
qed
also have "... = \<rho>' (cod (mkarr t)) \<cdot> mkarr t"
proof -
have "mkarr (Inv \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t = runit' (cod (mkarr t)) \<cdot> mkarr t"
using assms Arr_implies_Ide_Cod rep_mkarr inv_mkarr norm_preserves_Can
Ide_implies_Can runit_agreement Can_implies_Arr arr_mkarr cod_mkarr
ide_cod runit\<^sub>F\<^sub>M\<^sub>C_def
by (metis (no_types, lifting) Can.simps(7))
also have "... = \<rho>' (cod (mkarr t)) \<cdot> mkarr t"
proof -
have "runit' (cod (mkarr t)) = \<rho>' (cod (mkarr t))"
using assms \<rho>'_ide_simp arr_mkarr ide_cod by blast
thus ?thesis by argo
qed
finally show ?thesis by blast
qed
also have "... = \<rho>' (mkarr t)"
using assms \<rho>'.is_natural_2 [of "mkarr t"] by simp
finally show ?thesis by blast
qed
lemma mkarr_Assoc:
assumes "Arr t" and "Arr u" and "Arr v"
shows "mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<alpha> (mkarr t, mkarr u, mkarr v)"
proof -
have "mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = mkarr ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>, \<^bold>\<parallel>Dom u\<^bold>\<parallel>, \<^bold>\<parallel>Dom v\<^bold>\<parallel>\<^bold>])"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Ide_in_Hom
Diag_Diagonalize Diagonalize_preserves_Ide TensorDiag_preserves_Ide
TensorDiag_preserves_Diag TensorDiag_assoc Par_Arr_norm
by (intro mkarr_eqI, simp_all)
also have "... = \<alpha> (mkarr t, mkarr u, mkarr v)"
using assms Arr_implies_Ide_Dom rep_mkarr Ide_in_Hom assoc\<^sub>F\<^sub>M\<^sub>C_def
Par_Arr_norm [of "Dom t"] Par_Arr_norm [of "Dom u"] Par_Arr_norm [of "Dom v"]
\<alpha>_simp
by simp
finally show ?thesis by blast
qed
lemma mkarr_Assoc':
assumes "Arr t" and "Arr u" and "Arr v"
shows "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<alpha>' (mkarr t, mkarr u, mkarr v)"
proof -
have "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = mkarr (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> (t \<^bold>\<otimes> u \<^bold>\<otimes> v))"
using assms Par_Arr_norm Arr_implies_Ide_Cod Ide_in_Hom Diag_Diagonalize
TensorDiag_preserves_Diag CompDiag_Cod_Diag [of "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
by (intro mkarr_eqI, simp_all)
also have "... = mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
also have "... = mkarr (Inv \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
proof -
have "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] =
mkarr (Inv \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>])"
using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom Ide_implies_Can
norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
by (intro mkarr_eqI, simp_all)
thus ?thesis by argo
qed
also have "... = inv (mkarr \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
using assms Arr_implies_Ide_Cod Ide_implies_Can norm_preserves_Can by simp
also have "... = \<alpha>' (mkarr t, mkarr u, mkarr v)"
proof -
have "mkarr (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv \<^bold>\<parallel>Cod t\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod u\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> (Cod t \<^bold>\<otimes> Cod u \<^bold>\<otimes> Cod v))
= mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv \<^bold>\<parallel>Cod t\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod u\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]"
using assms Arr_implies_Ide_Cod Inv_in_Hom norm_preserves_Can Diagonalize_Inv
Ide_implies_Can Diag_Diagonalize Ide_in_Hom Diagonalize_preserves_Ide
Par_Arr_norm TensorDiag_preserves_Diag
CompDiag_Cod_Diag [of "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod v\<^bold>\<rfloor>"]
by (intro mkarr_eqI) simp_all
thus ?thesis
using assms Arr_implies_Ide_Cod rep_mkarr assoc\<^sub>F\<^sub>M\<^sub>C_def \<alpha>'.map_simp by simp
qed
finally show ?thesis by blast
qed
text \<open>
Next, we define the ``inclusion of generators'' functor from @{term C} to \<open>\<F>C\<close>.
\<close>
definition inclusion_of_generators
where "inclusion_of_generators \<equiv> \<lambda>f. if C.arr f then mkarr \<^bold>\<langle>f\<^bold>\<rangle> else null"
lemma inclusion_is_functor:
shows "functor C comp inclusion_of_generators"
unfolding inclusion_of_generators_def
apply unfold_locales
apply auto[4]
by (elim C.seqE, simp, intro mkarr_eqI, auto)
end
text \<open>
We now show that, given a functor @{term V} from @{term C} to a
a monoidal category @{term D}, the evaluation map that takes formal arrows
of the monoidal language of @{term C} to arrows of @{term D}
induces a strict monoidal functor from \<open>\<F>C\<close> to @{term D}.
\<close>
locale evaluation_functor =
C: category C +
D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
evaluation_map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
\<F>C: free_monoidal_category C
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and V :: "'c \<Rightarrow> 'd"
begin
notation eval ("\<lbrace>_\<rbrace>")
definition map
where "map f \<equiv> if \<F>C.arr f then \<lbrace>\<F>C.rep f\<rbrace> else D.null"
text \<open>
It follows from the coherence theorem that a formal arrow and its normal
form always have the same evaluation.
\<close>
lemma eval_norm:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<parallel>t\<^bold>\<parallel>\<rbrace> = \<lbrace>t\<rbrace>"
using assms \<F>C.Par_Arr_norm \<F>C.Diagonalize_norm coherence canonical_factorization
by simp
interpretation "functor" \<F>C.comp D map
proof
fix f
show "\<not>\<F>C.arr f \<Longrightarrow> map f = D.null" using map_def by simp
assume f: "\<F>C.arr f"
show "D.arr (map f)" using f map_def \<F>C.arr_char by simp
show "D.dom (map f) = map (\<F>C.dom f)"
using f map_def eval_norm \<F>C.rep_dom Arr_implies_Ide_Dom by auto
show "D.cod (map f) = map (\<F>C.cod f)"
using f map_def eval_norm \<F>C.rep_cod Arr_implies_Ide_Cod by auto
next
fix f g
assume fg: "\<F>C.seq g f"
show "map (\<F>C.comp g f) = D (map g) (map f)"
using fg map_def \<F>C.rep_comp \<F>C.rep_preserves_seq eval_norm by auto
qed
lemma is_functor:
shows "functor \<F>C.comp D map" ..
interpretation FF: product_functor \<F>C.comp \<F>C.comp D D map map ..
interpretation FoT: composite_functor \<F>C.CC.comp \<F>C.comp D \<F>C.T\<^sub>F\<^sub>M\<^sub>C map ..
interpretation ToFF: composite_functor \<F>C.CC.comp D.CC.comp D FF.map T\<^sub>D ..
interpretation strict_monoidal_functor
\<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
proof
show "map \<F>C.\<iota> = \<iota>\<^sub>D"
using \<F>C.\<iota>_def \<F>C.lunit_agreement map_def \<F>C.rep_lunit \<F>C.Arr_rep [of \<I>]
eval_norm \<F>C.lunit_agreement D.unitor_coincidence D.comp_cod_arr D.\<iota>_in_hom
by auto
show "\<And>f g. \<lbrakk> \<F>C.arr f; \<F>C.arr g \<rbrakk> \<Longrightarrow>
map (\<F>C.tensor f g) = D.tensor (map f) (map g)"
using map_def \<F>C.rep_tensor \<F>C.Arr_rep eval_norm by simp
show "\<And>a b c. \<lbrakk> \<F>C.ide a; \<F>C.ide b; \<F>C.ide c \<rbrakk> \<Longrightarrow>
map (\<F>C.assoc a b c) = D.assoc (map a) (map b) (map c)"
using map_def \<F>C.assoc\<^sub>F\<^sub>M\<^sub>C_def \<F>C.rep_mkarr eval_norm by auto
qed
lemma is_strict_monoidal_functor:
shows "strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map"
..
end
sublocale evaluation_functor \<subseteq> strict_monoidal_functor
\<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
using is_strict_monoidal_functor by auto
text \<open>
The final step in proving freeness is to show that the evaluation functor
is the \emph{unique} strict monoidal extension of the functor @{term V}
to \<open>\<F>C\<close>. This is done by induction, exploiting the syntactic construction
of \<open>\<F>C\<close>.
\<close>
text \<open>
To ease the statement and proof of the result, we define a locale that
expresses that @{term F} is a strict monoidal extension to monoidal
category @{term C}, of a functor @{term "V"} from @{term "C\<^sub>0"} to a
monoidal category @{term D}, along a functor @{term I} from
@{term "C\<^sub>0"} to @{term C}.
\<close>
locale strict_monoidal_extension =
C\<^sub>0: category C\<^sub>0 +
C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
I: "functor" C\<^sub>0 C I +
V: "functor" C\<^sub>0 D V +
strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F
for C\<^sub>0 :: "'c\<^sub>0 comp"
and C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
and \<iota>\<^sub>C :: "'c"
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and I :: "'c\<^sub>0 \<Rightarrow> 'c"
and V :: "'c\<^sub>0 \<Rightarrow> 'd"
and F :: "'c \<Rightarrow> 'd" +
assumes is_extension: "\<forall>f. C\<^sub>0.arr f \<longrightarrow> F (I f) = V f"
sublocale evaluation_functor \<subseteq>
strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
\<F>C.inclusion_of_generators V map
proof -
interpret inclusion: "functor" C \<F>C.comp \<F>C.inclusion_of_generators
using \<F>C.inclusion_is_functor by auto
show "strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
\<F>C.inclusion_of_generators V map"
apply unfold_locales
using map_def \<F>C.rep_mkarr eval_norm \<F>C.inclusion_of_generators_def by simp
qed
text \<open>
A special case of interest is a strict monoidal extension to \<open>\<F>C\<close>,
of a functor @{term V} from a category @{term C} to a monoidal category @{term D},
along the inclusion of generators from @{term C} to \<open>\<F>C\<close>.
The evaluation functor induced by @{term V} is such an extension.
\<close>
locale strict_monoidal_extension_to_free_monoidal_category =
C: category C +
monoidal_language C +
\<F>C: free_monoidal_category C +
strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
\<F>C.inclusion_of_generators V F
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and V :: "'c \<Rightarrow> 'd"
and F :: "'c free_monoidal_category.arr \<Rightarrow> 'd"
begin
lemma strictly_preserves_everything:
shows "C.arr f \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<langle>f\<^bold>\<rangle>) = V f"
and "F (\<F>C.mkarr \<^bold>\<I>) = \<I>\<^sub>D"
and "\<lbrakk> Arr t; Arr u \<rbrakk> \<Longrightarrow> F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
and "\<lbrakk> Arr t; Arr u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^bold>[t\<^bold>]) = D.\<ll> (F (\<F>C.mkarr t))"
and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<ll>'.map (F (\<F>C.mkarr t))"
and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^bold>[t\<^bold>]) = D.\<rho> (F (\<F>C.mkarr t))"
and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<rho>'.map (F (\<F>C.mkarr t))"
and "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]) = \<alpha>\<^sub>D (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
and "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>])
= D.\<alpha>' (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
proof -
show "C.arr f \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<langle>f\<^bold>\<rangle>) = V f"
using is_extension \<F>C.inclusion_of_generators_def by simp
show "F (\<F>C.mkarr \<^bold>\<I>) = \<I>\<^sub>D"
using \<F>C.mkarr_Unity \<F>C.\<iota>_def strictly_preserves_unity \<F>C.\<I>_agreement by auto
show tensor_case:
"\<And>t u.\<lbrakk> Arr t; Arr u \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
proof -
fix t u
assume t: "Arr t" and u: "Arr u"
have "F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.tensor (\<F>C.mkarr t) (\<F>C.mkarr u))"
using t u \<F>C.tensor_mkarr \<F>C.arr_mkarr by simp
also have "... = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
using t u \<F>C.arr_mkarr strictly_preserves_tensor by blast
finally show "F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
by fast
qed
show "\<lbrakk> Arr t; Arr u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
proof -
fix t u
assume t: "Arr t" and u: "Arr u" and tu: "Dom t = Cod u"
show "F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
proof -
have "F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t \<cdot> \<F>C.mkarr u)"
using t u tu \<F>C.comp_mkarr by simp
also have "... = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
using t u tu \<F>C.arr_mkarr by fastforce
finally show ?thesis by blast
qed
qed
show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^bold>[t\<^bold>]) = D.\<ll> (F (\<F>C.mkarr t))"
using \<F>C.mkarr_Lunit Arr_implies_Ide_Dom \<F>C.ide_mkarr_Ide strictly_preserves_lunit
by simp
show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^bold>[t\<^bold>]) = D.\<rho> (F (\<F>C.mkarr t))"
using \<F>C.mkarr_Runit Arr_implies_Ide_Dom \<F>C.ide_mkarr_Ide strictly_preserves_runit
by simp
show "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>])
= \<alpha>\<^sub>D (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
using \<F>C.mkarr_Assoc strictly_preserves_assoc \<F>C.ide_mkarr_Ide tensor_case
by simp
show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<ll>'.map (F (\<F>C.mkarr t))"
proof -
assume t: "Arr t"
have "F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = F (\<F>C.lunit' (\<F>C.mkarr (Cod t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
using t \<F>C.mkarr_Lunit' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<ll>'.map_simp
\<F>C.comp_cod_arr
by simp
also have "... = D.lunit' (D.cod (F (\<F>C.mkarr t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
using t Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide strictly_preserves_lunit
preserves_inv
by simp
also have "... = D.\<ll>'.map (F (\<F>C.mkarr t))"
using t D.\<ll>'.map_simp D.comp_cod_arr by simp
finally show ?thesis by blast
qed
show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<rho>'.map (F (\<F>C.mkarr t))"
proof -
assume t: "Arr t"
have "F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = F (\<F>C.runit' (\<F>C.mkarr (Cod t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
using t \<F>C.mkarr_Runit' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<rho>'.map_simp
\<F>C.comp_cod_arr
by simp
also have "... = D.runit' (D.cod (F (\<F>C.mkarr t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
using t Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide strictly_preserves_runit
preserves_inv
by simp
also have "... = D.\<rho>'.map (F (\<F>C.mkarr t))"
using t D.\<rho>'.map_simp D.comp_cod_arr by simp
finally show ?thesis by blast
qed
show "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>])
= D.\<alpha>'.map (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
proof -
assume t: "Arr t" and u: "Arr u" and v: "Arr v"
have "F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]) =
F (\<F>C.assoc' (\<F>C.mkarr (Cod t)) (\<F>C.mkarr (Cod u)) (\<F>C.mkarr (Cod v))) \<cdot>\<^sub>D
(F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u) \<otimes>\<^sub>D F (\<F>C.mkarr v))"
using t u v \<F>C.mkarr_Assoc' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<alpha>'.map_simp
tensor_case \<F>C.iso_assoc
by simp
also have "... = D.assoc' (D.cod (F (\<F>C.mkarr t))) (D.cod (F (\<F>C.mkarr u)))
(D.cod (F (\<F>C.mkarr v))) \<cdot>\<^sub>D
(F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u) \<otimes>\<^sub>D F (\<F>C.mkarr v))"
using t u v \<F>C.ide_mkarr_Ide Arr_implies_Ide_Cod preserves_inv \<F>C.iso_assoc
strictly_preserves_assoc
[of "\<F>C.mkarr (Cod t)" "\<F>C.mkarr (Cod u)" "\<F>C.mkarr (Cod v)"]
by simp
also have "... = D.\<alpha>'.map (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
using t u v D.\<alpha>'.map_simp by simp
finally show ?thesis by blast
qed
qed
end
sublocale evaluation_functor \<subseteq> strict_monoidal_extension_to_free_monoidal_category
C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V map
..
context free_monoidal_category
begin
text \<open>
The evaluation functor induced by @{term V} is the unique strict monoidal
extension of @{term V} to \<open>\<F>C\<close>.
\<close>
theorem is_free:
assumes "strict_monoidal_extension_to_free_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F"
shows "F = evaluation_functor.map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V"
proof -
interpret F: strict_monoidal_extension_to_free_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F
using assms by auto
interpret E: evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V ..
have Ide_case: "\<And>a. Ide a \<Longrightarrow> F (mkarr a) = E.map (mkarr a)"
proof -
fix a
show "Ide a \<Longrightarrow> F (mkarr a) = E.map (mkarr a)"
using E.strictly_preserves_everything F.strictly_preserves_everything Ide_implies_Arr
by (induct a, auto)
qed
show ?thesis
proof
fix f
have "\<not>arr f \<Longrightarrow> F f = E.map f"
using E.is_extensional F.is_extensional by simp
moreover have "arr f \<Longrightarrow> F f = E.map f"
proof -
assume f: "arr f"
have "Arr (rep f) \<and> f = mkarr (rep f)" using f mkarr_rep by simp
moreover have "\<And>t. Arr t \<Longrightarrow> F (mkarr t) = E.map (mkarr t)"
proof -
fix t
show "Arr t \<Longrightarrow> F (mkarr t) = E.map (mkarr t)"
using Ide_case E.strictly_preserves_everything F.strictly_preserves_everything
Arr_implies_Ide_Dom Arr_implies_Ide_Cod
by (induct t, auto)
qed
ultimately show "F f = E.map f" by metis
qed
ultimately show "F f = E.map f" by blast
qed
qed
end
section "Strict Subcategory"
context free_monoidal_category
begin
text \<open>
In this section we show that \<open>\<F>C\<close> is monoidally equivalent to its full subcategory
\<open>\<F>\<^sub>SC\<close> whose objects are the equivalence classes of diagonal identity terms,
and that this subcategory is the free strict monoidal category generated by @{term C}.
\<close>
- interpretation \<F>\<^sub>SC: full_subcategory comp "\<lambda>f. ide f \<and> Diag (DOM f)"
+ interpretation \<F>\<^sub>SC: full_subcategory comp \<open>\<lambda>f. ide f \<and> Diag (DOM f)\<close>
by (unfold_locales) auto
text \<open>
The mapping defined on equivalence classes by diagonalizing their representatives
is a functor from the free monoidal category to the subcategory @{term "\<F>\<^sub>SC"}.
\<close>
definition D
where "D \<equiv> \<lambda>f. if arr f then mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> else \<F>\<^sub>SC.null"
text \<open>
The arrows of \<open>\<F>\<^sub>SC\<close> are those equivalence classes whose canonical representative
term has diagonal formal domain and codomain.
\<close>
lemma strict_arr_char:
shows "\<F>\<^sub>SC.arr f \<longleftrightarrow> arr f \<and> Diag (DOM f) \<and> Diag (COD f)"
proof
show "arr f \<and> Diag (DOM f) \<and> Diag (COD f) \<Longrightarrow> \<F>\<^sub>SC.arr f"
using \<F>\<^sub>SC.arr_char DOM_dom DOM_cod by simp
show "\<F>\<^sub>SC.arr f \<Longrightarrow> arr f \<and> Diag (DOM f) \<and> Diag (COD f)"
using \<F>\<^sub>SC.arr_char Arr_rep Arr_implies_Ide_Cod Ide_implies_Arr DOM_dom DOM_cod
by force
qed
text \<open>
Alternatively, the arrows of \<open>\<F>\<^sub>SC\<close> are those equivalence classes
that are preserved by diagonalization of representatives.
\<close>
lemma strict_arr_char':
shows "\<F>\<^sub>SC.arr f \<longleftrightarrow> arr f \<and> D f = f"
proof
fix f
assume f: "\<F>\<^sub>SC.arr f"
show "arr f \<and> D f = f"
proof
show "arr f" using f \<F>\<^sub>SC.arr_char by blast
show "D f = f"
using f strict_arr_char mkarr_Diagonalize_rep D_def by simp
qed
next
assume f: "arr f \<and> D f = f"
show "\<F>\<^sub>SC.arr f"
proof -
have "arr f" using f by simp
moreover have "Diag (DOM f)"
proof -
have "DOM f = DOM (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)" using f D_def by auto
also have "... = Dom \<^bold>\<parallel>\<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<parallel>"
using f Arr_rep Diagonalize_in_Hom rep_mkarr by simp
also have "... = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using f Arr_rep Diagonalize_in_Hom Par_Arr_norm [of "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>"] by force
finally have "DOM f = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" by blast
thus ?thesis using f Arr_rep Diag_Diagonalize Dom_preserves_Diag by metis
qed
moreover have "Diag (COD f)"
proof -
have "COD f = COD (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)" using f D_def by auto
also have "... = Cod \<^bold>\<parallel>\<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<parallel>"
using f Arr_rep Diagonalize_in_Hom rep_mkarr by simp
also have "... = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using f Arr_rep Diagonalize_in_Hom Par_Arr_norm [of "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>"] by force
finally have "COD f = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" by blast
thus ?thesis using f Arr_rep Diag_Diagonalize Cod_preserves_Diag by metis
qed
ultimately show ?thesis using strict_arr_char by auto
qed
qed
interpretation D: "functor" comp \<F>\<^sub>SC.comp D
proof -
have 1: "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.arr (D f)"
unfolding strict_arr_char D_def
using arr_mkarr Diagonalize_in_Hom Arr_rep rep_mkarr Par_Arr_norm
Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diag_Diagonalize
by force
show "functor comp \<F>\<^sub>SC.comp D"
proof
show "\<And>f. \<not> arr f \<Longrightarrow> D f = \<F>\<^sub>SC.null" using D_def by simp
show "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.arr (D f)" by fact
show "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.dom (D f) = D (dom f)"
using D_def Diagonalize_in_Hom \<F>\<^sub>SC.dom_char \<F>\<^sub>SC.arr_char
rep_mkarr rep_dom Arr_implies_Ide_Dom Arr_implies_Ide_Cod
Diagonalize_preserves_Ide ide_mkarr_Ide Diag_Diagonalize Dom_norm
by simp
show 2: "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.cod (D f) = D (cod f)"
using D_def Diagonalize_in_Hom \<F>\<^sub>SC.cod_char \<F>\<^sub>SC.arr_char
rep_mkarr rep_cod Arr_implies_Ide_Dom Arr_implies_Ide_Cod
Diagonalize_preserves_Ide ide_mkarr_Ide Diag_Diagonalize Dom_norm
by simp
fix f g
assume fg: "seq g f"
hence fg': "arr f \<and> arr g \<and> dom g = cod f" by blast
show "D (g \<cdot> f) = \<F>\<^sub>SC.comp (D g) (D f)"
proof -
have seq: "\<F>\<^sub>SC.seq (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
proof -
have 3: "\<F>\<^sub>SC.arr (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) \<and> \<F>\<^sub>SC.arr (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
using fg' 1 arr_char D_def by force
moreover have "\<F>\<^sub>SC.dom (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) = \<F>\<^sub>SC.cod (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
using fg' 2 3 \<F>\<^sub>SC.dom_char rep_in_Hom mkarr_in_hom D_def
Dom_Diagonalize_rep Diag_implies_Arr Diag_Diagonalize(1) \<F>\<^sub>SC.arr_char
by force
ultimately show ?thesis using \<F>\<^sub>SC.seqI by auto
qed
have "mkarr \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor> = \<F>\<^sub>SC.comp (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
proof -
have Seq: "Seq \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using fg rep_preserves_seq Diagonalize_in_Hom by force
hence 4: "\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>DOM f\<^bold>\<rfloor> \<^bold>\<lfloor>COD g\<^bold>\<rfloor>"
using fg' Seq Diagonalize_in_Hom by auto
have "\<F>\<^sub>SC.comp (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>) = mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<cdot> mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using seq \<F>\<^sub>SC.comp_char \<F>\<^sub>SC.seq_char by meson
also have "... = mkarr (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
using Seq comp_mkarr by fastforce
also have "... = mkarr \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>"
proof (intro mkarr_eqI)
show "Par (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>) \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>"
using fg 4 rep_in_Hom rep_preserves_seq rep_in_Hom Diagonalize_in_Hom
Par_Arr_norm
apply (elim seqE, auto)
by (simp_all add: rep_comp)
show "\<^bold>\<lfloor>\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>\<^bold>\<rfloor>"
using fg rep_preserves_seq norm_in_Hom Diag_Diagonalize Diagonalize_Diag
apply auto
by (simp add: rep_comp)
qed
finally show ?thesis by blast
qed
thus ?thesis using fg D_def by auto
qed
qed
qed
lemma diagonalize_is_functor:
shows "functor comp \<F>\<^sub>SC.comp D" ..
lemma diagonalize_strict_arr:
assumes "\<F>\<^sub>SC.arr f"
shows "D f = f"
using assms arr_char D_def strict_arr_char Arr_rep Arr_implies_Ide_Dom Ide_implies_Arr
mkarr_Diagonalize_rep [of f]
by auto
lemma diagonalize_is_idempotent:
shows "D o D = D"
unfolding D_def
using D.is_extensional \<F>\<^sub>SC.null_char Arr_rep Diagonalize_in_Hom mkarr_Diagonalize_rep
strict_arr_char rep_mkarr
by fastforce
lemma diagonalize_tensor:
assumes "arr f" and "arr g"
shows "D (f \<otimes> g) = D (D f \<otimes> D g)"
unfolding D_def
using assms strict_arr_char rep_in_Hom Diagonalize_in_Hom tensor_mkarr rep_tensor
Diagonalize_in_Hom rep_mkarr Diagonalize_norm Diagonalize_Tensor
by force
lemma ide_diagonalize_can:
assumes "can f"
shows "ide (D f)"
using assms D_def Can_rep_can Ide_Diagonalize_Can ide_mkarr_Ide can_implies_arr
by simp
text \<open>
We next show that the diagonalization functor and the inclusion of the full subcategory
\<open>\<F>\<^sub>SC\<close> underlie an equivalence of categories. The arrows @{term "mkarr (DOM a\<^bold>\<down>)"},
determined by reductions of canonical representatives, are the components of a
natural isomorphism.
\<close>
- interpretation S: full_inclusion_functor comp "\<lambda>f. ide f \<and> Diag (DOM f)" ..
+ interpretation S: full_inclusion_functor comp \<open>\<lambda>f. ide f \<and> Diag (DOM f)\<close> ..
interpretation DoS: composite_functor \<F>\<^sub>SC.comp comp \<F>\<^sub>SC.comp \<F>\<^sub>SC.map D
..
interpretation SoD: composite_functor comp \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map ..
interpretation \<nu>: transformation_by_components
- comp comp map SoD.map "\<lambda>a. mkarr (DOM a\<^bold>\<down>)"
+ comp comp map SoD.map \<open>\<lambda>a. mkarr (DOM a\<^bold>\<down>)\<close>
proof
fix a
assume a: "ide a"
show "\<guillemotleft>mkarr (DOM a\<^bold>\<down>) : map a \<rightarrow> SoD.map a\<guillemotright>"
proof -
have "\<guillemotleft>mkarr (DOM a\<^bold>\<down>) : a \<rightarrow> mkarr \<^bold>\<lfloor>DOM a\<^bold>\<rfloor>\<guillemotright>"
using a Arr_implies_Ide_Dom red_in_Hom dom_char [of a] by auto
moreover have "map a = a"
using a map_simp by simp
moreover have "SoD.map a = mkarr \<^bold>\<lfloor>DOM a\<^bold>\<rfloor>"
using a D.preserves_ide \<F>\<^sub>SC.ideD \<F>\<^sub>SC.map_simp D_def Ide_Diagonalize_rep_ide
Ide_in_Hom Diagonalize_in_Hom
by force
ultimately show ?thesis by simp
qed
next
fix f
assume f: "arr f"
show "mkarr (DOM (cod f)\<^bold>\<down>) \<cdot> map f = SoD.map f \<cdot> mkarr (DOM (dom f)\<^bold>\<down>)"
proof -
have "SoD.map f \<cdot> mkarr (DOM (dom f)\<^bold>\<down>) = mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<cdot> mkarr (DOM f\<^bold>\<down>)"
using f DOM_dom D.preserves_arr \<F>\<^sub>SC.map_simp D_def by simp
also have "... = mkarr (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>)"
using f Diagonalize_in_Hom red_in_Hom comp_mkarr Arr_implies_Ide_Dom
by simp
also have "... = mkarr (COD f\<^bold>\<down> \<^bold>\<cdot> rep f)"
proof (intro mkarr_eqI)
show "Par (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>) (COD f\<^bold>\<down> \<^bold>\<cdot> rep f)"
using f Diagonalize_in_Hom red_in_Hom Arr_implies_Ide_Dom Arr_implies_Ide_Cod
by simp
show "\<^bold>\<lfloor>\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<down> \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>DOM f\<^bold>\<down>\<^bold>\<rfloor>"
using f by simp
also have "... = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using f Arr_implies_Ide_Dom Can_red Ide_Diagonalize_Can [of "DOM f\<^bold>\<down>"]
Diag_Diagonalize CompDiag_Diag_Ide
by force
also have "... = \<^bold>\<lfloor>COD f\<^bold>\<down>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
using f Arr_implies_Ide_Cod Can_red Ide_Diagonalize_Can [of "COD f\<^bold>\<down>"]
Diag_Diagonalize CompDiag_Diag_Ide
by force
also have "... = \<^bold>\<lfloor>COD f\<^bold>\<down> \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
by simp
finally show ?thesis by blast
qed
qed
also have "... = mkarr (COD f\<^bold>\<down>) \<cdot> mkarr (rep f)"
using f comp_mkarr rep_in_Hom red_in_Hom Arr_implies_Ide_Cod by blast
also have "... = mkarr (DOM (cod f)\<^bold>\<down>) \<cdot> map f"
using f DOM_cod by simp
finally show ?thesis by blast
qed
qed
interpretation \<nu>: natural_isomorphism comp comp map SoD.map \<nu>.map
apply unfold_locales
using \<nu>.map_simp_ide rep_in_Hom Arr_implies_Ide_Dom Can_red can_mkarr_Can iso_can
by simp
text \<open>
The restriction of the diagonalization functor to the subcategory \<open>\<F>\<^sub>SC\<close>
is the identity.
\<close>
lemma DoS_eq_\<F>\<^sub>SC:
shows "DoS.map = \<F>\<^sub>SC.map"
proof
fix f
have "\<not> \<F>\<^sub>SC.arr f \<Longrightarrow> DoS.map f = \<F>\<^sub>SC.map f"
using DoS.is_extensional \<F>\<^sub>SC.map_def by simp
moreover have "\<F>\<^sub>SC.arr f \<Longrightarrow> DoS.map f = \<F>\<^sub>SC.map f"
using \<F>\<^sub>SC.map_simp strict_arr_char Diagonalize_Diag D_def mkarr_Diagonalize_rep
by simp
ultimately show "DoS.map f = \<F>\<^sub>SC.map f" by blast
qed
interpretation \<mu>: transformation_by_components
- \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map "\<lambda>a. a"
+ \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<open>\<lambda>a. a\<close>
using \<F>\<^sub>SC.ideD \<F>\<^sub>SC.map_simp DoS_eq_\<F>\<^sub>SC \<F>\<^sub>SC.map_simp \<F>\<^sub>SC.comp_cod_arr \<F>\<^sub>SC.comp_arr_dom
by (unfold_locales, intro \<F>\<^sub>SC.in_homI, auto)
interpretation \<mu>: natural_isomorphism \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>.map
apply unfold_locales using \<mu>.map_simp_ide \<F>\<^sub>SC.ide_is_iso by simp
interpretation equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu>.map \<mu>.map ..
text \<open>
We defined the natural isomorphisms @{term \<mu>} and @{term \<nu>} by giving their
components (\emph{i.e.}~their values at objects). However, it is helpful
in exporting these facts to have simple characterizations of their values
for all arrows.
\<close>
definition \<mu>
where "\<mu> \<equiv> \<lambda>f. if \<F>\<^sub>SC.arr f then f else \<F>\<^sub>SC.null"
definition \<nu>
where "\<nu> \<equiv> \<lambda>f. if arr f then mkarr (COD f\<^bold>\<down>) \<cdot> f else null"
lemma \<mu>_char:
shows "\<mu>.map = \<mu>"
proof (intro NaturalTransformation.eqI)
show "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>.map" ..
have "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp \<F>\<^sub>SC.map \<F>\<^sub>SC.map \<F>\<^sub>SC.map"
using DoS.natural_transformation_axioms DoS_eq_\<F>\<^sub>SC by simp
moreover have "\<F>\<^sub>SC.map = \<mu>" unfolding \<mu>_def using \<F>\<^sub>SC.map_def by blast
ultimately show "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>"
using \<F>\<^sub>SC.natural_transformation_axioms DoS_eq_\<F>\<^sub>SC by simp
show "\<And>a. \<F>\<^sub>SC.ide a \<Longrightarrow> \<mu>.map a = \<mu> a"
using \<mu>.map_simp_ide \<F>\<^sub>SC.ideD \<mu>_def by simp
qed
lemma \<nu>_char:
shows "\<nu>.map = \<nu>"
unfolding \<nu>.map_def \<nu>_def using map_simp DOM_cod by fastforce
lemma is_equivalent_to_strict_subcategory:
shows "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu> \<mu>"
proof -
have "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu>.map \<mu>.map" ..
thus "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu> \<mu>"
using \<nu>_char \<mu>_char by simp
qed
text \<open>
The inclusion of generators functor from @{term C} to \<open>\<F>C\<close>
corestricts to a functor from @{term C} to \<open>\<F>\<^sub>SC\<close>.
\<close>
interpretation I: "functor" C comp inclusion_of_generators
using inclusion_is_functor by auto
interpretation DoI: composite_functor C comp \<F>\<^sub>SC.comp inclusion_of_generators D ..
lemma DoI_eq_I:
shows "DoI.map = inclusion_of_generators"
proof
fix f
have "\<not> C.arr f \<Longrightarrow> DoI.map f = inclusion_of_generators f"
using DoI.is_extensional I.is_extensional \<F>\<^sub>SC.null_char by blast
moreover have "C.arr f \<Longrightarrow> DoI.map f = inclusion_of_generators f"
proof -
assume f: "C.arr f"
have "DoI.map f = D (inclusion_of_generators f)" using f by simp
also have "... = inclusion_of_generators f"
proof -
have "\<F>\<^sub>SC.arr (inclusion_of_generators f)"
using f arr_mkarr rep_mkarr Par_Arr_norm [of "\<^bold>\<langle>f\<^bold>\<rangle>"] strict_arr_char
inclusion_of_generators_def
by simp
thus ?thesis using f strict_arr_char' by blast
qed
finally show "DoI.map f = inclusion_of_generators f" by blast
qed
ultimately show "DoI.map f = inclusion_of_generators f" by blast
qed
end
text \<open>
Next, we show that the subcategory \<open>\<F>\<^sub>SC\<close> inherits monoidal structure from
the ambient category \<open>\<F>C\<close>, and that this monoidal structure is strict.
\<close>
locale free_strict_monoidal_category =
monoidal_language C +
\<F>C: free_monoidal_category C +
full_subcategory \<F>C.comp "\<lambda>f. \<F>C.ide f \<and> Diag (\<F>C.DOM f)"
for C :: "'c comp"
begin
interpretation D: "functor" \<F>C.comp comp \<F>C.D
using \<F>C.diagonalize_is_functor by auto
notation comp (infixr "\<cdot>\<^sub>S" 55)
definition tensor\<^sub>S (infixr "\<otimes>\<^sub>S" 53)
where "f \<otimes>\<^sub>S g \<equiv> \<F>C.D (\<F>C.tensor f g)"
definition assoc\<^sub>S ("\<a>\<^sub>S[_, _, _]")
where "assoc\<^sub>S a b c \<equiv> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c"
lemma tensor_char:
assumes "arr f" and "arr g"
shows "f \<otimes>\<^sub>S g = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>)"
unfolding \<F>C.D_def tensor\<^sub>S_def
using assms arr_char \<F>C.rep_tensor by simp
lemma tensor_in_hom [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
shows "\<guillemotleft>f \<otimes>\<^sub>S g : a \<otimes>\<^sub>S c \<rightarrow> b \<otimes>\<^sub>S d\<guillemotright>"
unfolding tensor\<^sub>S_def
using assms D.preserves_hom D.preserves_arr arr_char in_hom_char by simp
lemma arr_tensor [simp]:
assumes "arr f" and "arr g"
shows "arr (f \<otimes>\<^sub>S g)"
using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast
lemma dom_tensor [simp]:
assumes "arr f" and "arr g"
shows "dom (f \<otimes>\<^sub>S g) = dom f \<otimes>\<^sub>S dom g"
using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast
lemma cod_tensor [simp]:
assumes "arr f" and "arr g"
shows "cod (f \<otimes>\<^sub>S g) = cod f \<otimes>\<^sub>S cod g"
using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast
lemma tensor_preserves_ide:
assumes "ide a" and "ide b"
shows "ide (a \<otimes>\<^sub>S b)"
using assms tensor\<^sub>S_def D.preserves_ide \<F>C.tensor_preserves_ide ide_char
by fastforce
lemma tensor_tensor:
assumes "arr f" and "arr g" and "arr h"
shows "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
and "f \<otimes>\<^sub>S g \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
proof -
show "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
proof -
have "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep (f \<otimes>\<^sub>S g)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
using assms Diag_Diagonalize TensorDiag_preserves_Diag Diag_implies_Arr
\<F>C.COD_mkarr \<F>C.DOM_mkarr \<F>C.strict_arr_char tensor_char
by simp
also have
"... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep (\<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>))\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
\<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
using assms arr_char tensor_char by simp
also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
using assms \<F>C.rep_mkarr TensorDiag_in_Hom Diag_Diagonalize
TensorDiag_preserves_Diag arr_char
by force
also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
using assms Diag_Diagonalize TensorDiag_preserves_Diag TensorDiag_assoc arr_char
by force
finally show ?thesis by blast
qed
show "f \<otimes>\<^sub>S g \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
proof -
have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>\<^bold>\<rfloor>)"
using assms Diag_Diagonalize TensorDiag_preserves_Diag arr_char by force
also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
(\<^bold>\<lfloor>\<F>C.rep (\<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>))\<^bold>\<rfloor>))"
using assms \<F>C.rep_mkarr TensorDiag_in_Hom Diag_Diagonalize arr_char by force
also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep (g \<otimes>\<^sub>S h)\<^bold>\<rfloor>)"
using assms tensor_char by simp
also have "... = f \<otimes>\<^sub>S g \<otimes>\<^sub>S h"
using assms Diag_Diagonalize TensorDiag_preserves_Diag Diag_implies_Arr
\<F>C.COD_mkarr \<F>C.DOM_mkarr \<F>C.strict_arr_char tensor_char
by simp
finally show ?thesis by blast
qed
qed
lemma tensor_assoc:
assumes "arr f" and "arr g" and "arr h"
shows "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = f \<otimes>\<^sub>S g \<otimes>\<^sub>S h"
using assms tensor_tensor by presburger
lemma arr_unity:
shows "arr \<I>"
using \<F>C.rep_unity \<F>C.Par_Arr_norm \<F>C.\<I>_agreement \<F>C.strict_arr_char by force
lemma tensor_unity_arr:
assumes "arr f"
shows "\<I> \<otimes>\<^sub>S f = f"
using assms arr_unity tensor_char \<F>C.strict_arr_char \<F>C.mkarr_Diagonalize_rep
by simp
lemma tensor_arr_unity:
assumes "arr f"
shows "f \<otimes>\<^sub>S \<I> = f"
using assms arr_unity tensor_char \<F>C.strict_arr_char \<F>C.mkarr_Diagonalize_rep
by simp
lemma assoc_char:
assumes "ide a" and "ide b" and "ide c"
shows "\<a>\<^sub>S[a, b, c] = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep c\<^bold>\<rfloor>)"
using assms tensor_tensor(2) assoc\<^sub>S_def ideD(1) by simp
lemma assoc_in_hom:
assumes "ide a" and "ide b" and "ide c"
shows "\<guillemotleft>\<a>\<^sub>S[a, b, c] : (a \<otimes>\<^sub>S b) \<otimes>\<^sub>S c \<rightarrow> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c\<guillemotright>"
using assms tensor_preserves_ide ideD tensor_assoc assoc\<^sub>S_def
by (metis (no_types, lifting) ide_in_hom)
text \<open>The category \<open>\<F>\<^sub>SC\<close> is a monoidal category.\<close>
- interpretation EMC: elementary_monoidal_category comp tensor\<^sub>S \<I> "\<lambda>a. a" "\<lambda>a. a" assoc\<^sub>S
+ interpretation EMC: elementary_monoidal_category comp tensor\<^sub>S \<I> \<open>\<lambda>a. a\<close> \<open>\<lambda>a. a\<close> assoc\<^sub>S
proof
show "ide \<I>"
using ide_char arr_char \<F>C.rep_mkarr \<F>C.Dom_norm \<F>C.Cod_norm \<F>C.\<I>_agreement
by auto
show "\<And>a. ide a \<Longrightarrow> iso a"
using ide_char arr_char iso_char by auto
show "\<And>f a b g c d. \<lbrakk> in_hom a b f; in_hom c d g \<rbrakk> \<Longrightarrow> in_hom (a \<otimes>\<^sub>S c) (b \<otimes>\<^sub>S d) (f \<otimes>\<^sub>S g)"
using tensor_in_hom by blast
show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes>\<^sub>S b)"
using tensor_preserves_ide by blast
show "\<And>a b c. \<lbrakk> ide a; ide b; ide c\<rbrakk> \<Longrightarrow> iso \<a>\<^sub>S[a, b, c]"
using tensor_preserves_ide ide_is_iso assoc\<^sub>S_def by presburger
show "\<And>a b c. \<lbrakk> ide a; ide b; ide c\<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>\<^sub>S[a, b, c] : (a \<otimes>\<^sub>S b) \<otimes>\<^sub>S c \<rightarrow> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c\<guillemotright>"
using assoc_in_hom by blast
show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (a \<otimes>\<^sub>S b) \<cdot>\<^sub>S \<a>\<^sub>S[a, \<I>, b] = a \<otimes>\<^sub>S b"
using ide_def tensor_unity_arr assoc\<^sub>S_def ideD(1) tensor_preserves_ide comp_ide_self
by simp
show "\<And>f. arr f \<Longrightarrow> cod f \<cdot>\<^sub>S (\<I> \<otimes>\<^sub>S f) = f \<cdot>\<^sub>S dom f"
using tensor_unity_arr comp_arr_dom comp_cod_arr by presburger
show "\<And>f. arr f \<Longrightarrow> cod f \<cdot>\<^sub>S (f \<otimes>\<^sub>S \<I>) = f \<cdot>\<^sub>S dom f"
using tensor_arr_unity comp_arr_dom comp_cod_arr by presburger
next
fix a
assume a: "ide a"
show "\<guillemotleft>a : \<I> \<otimes>\<^sub>S a \<rightarrow> a\<guillemotright>"
using a tensor_unity_arr ide_in_hom [of a] by fast
show "\<guillemotleft>a : a \<otimes>\<^sub>S \<I> \<rightarrow> a\<guillemotright>"
using a tensor_arr_unity ide_in_hom [of a] by fast
next
fix f g f' g'
assume fg: "seq g f"
assume fg': "seq g' f'"
show "(g \<otimes>\<^sub>S g') \<cdot>\<^sub>S (f \<otimes>\<^sub>S f') = g \<cdot>\<^sub>S f \<otimes>\<^sub>S g' \<cdot>\<^sub>S f'"
proof -
have A: "\<F>C.seq g f" and B: "\<F>C.seq g' f'"
using fg fg' seq_char by auto
have "(g \<otimes>\<^sub>S g') \<cdot>\<^sub>S (f \<otimes>\<^sub>S f') = \<F>C.D ((g \<otimes> g') \<cdot> (f \<otimes> f'))"
using A B tensor\<^sub>S_def by fastforce
also have "... = \<F>C.D (g \<cdot> f \<otimes> g' \<cdot> f')"
using A B \<F>C.interchange \<F>C.T_simp \<F>C.seqE by metis
also have "... = \<F>C.D (g \<cdot> f) \<otimes>\<^sub>S \<F>C.D (g' \<cdot> f')"
using A B tensor\<^sub>S_def \<F>C.T_simp \<F>C.seqE \<F>C.diagonalize_tensor arr_char
by (metis (no_types, lifting) D.preserves_reflects_arr)
also have "... = \<F>C.D g \<cdot>\<^sub>S \<F>C.D f \<otimes>\<^sub>S \<F>C.D g' \<cdot>\<^sub>S \<F>C.D f'"
using A B by simp
also have "... = g \<cdot>\<^sub>S f \<otimes>\<^sub>S g' \<cdot>\<^sub>S f'"
using fg fg' \<F>C.diagonalize_strict_arr by (elim seqE, simp)
finally show ?thesis by blast
qed
next
fix f0 f1 f2
assume f0: "arr f0" and f1: "arr f1" and f2: "arr f2"
show "\<a>\<^sub>S[cod f0, cod f1, cod f2] \<cdot>\<^sub>S ((f0 \<otimes>\<^sub>S f1) \<otimes>\<^sub>S f2)
= (f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2) \<cdot>\<^sub>S \<a>\<^sub>S[dom f0, dom f1, dom f2]"
using f0 f1 f2 assoc\<^sub>S_def tensor_assoc dom_tensor cod_tensor arr_tensor
comp_cod_arr [of "f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2" "cod f0 \<otimes>\<^sub>S cod f1 \<otimes>\<^sub>S cod f2"]
comp_arr_dom [of "f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2" "dom f0 \<otimes>\<^sub>S dom f1 \<otimes>\<^sub>S dom f2"]
by presburger
next
fix a b c d
assume a: "ide a" and b: "ide b" and c: "ide c" and d: "ide d"
show "(a \<otimes>\<^sub>S \<a>\<^sub>S[b, c, d]) \<cdot>\<^sub>S \<a>\<^sub>S[a, b \<otimes>\<^sub>S c, d] \<cdot>\<^sub>S (\<a>\<^sub>S[a, b, c] \<otimes>\<^sub>S d)
= \<a>\<^sub>S[a, b, c \<otimes>\<^sub>S d] \<cdot>\<^sub>S \<a>\<^sub>S[a \<otimes>\<^sub>S b, c, d]"
unfolding assoc\<^sub>S_def
using a b c d tensor_assoc tensor_preserves_ide ideD tensor_in_hom
comp_arr_dom [of "a \<otimes>\<^sub>S b \<otimes>\<^sub>S c \<otimes>\<^sub>S d"]
by simp
qed
lemma is_elementary_monoidal_category:
shows "elementary_monoidal_category comp tensor\<^sub>S \<I> (\<lambda>a. a) (\<lambda>a. a) assoc\<^sub>S" ..
abbreviation T\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.T\<^sub>E\<^sub>M\<^sub>C"
abbreviation \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "\<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.\<alpha>"
abbreviation \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "\<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.\<iota>"
lemma is_monoidal_category:
shows "monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C"
using EMC.induces_monoidal_category by auto
end
sublocale free_strict_monoidal_category \<subseteq>
elementary_monoidal_category comp tensor\<^sub>S \<I> "\<lambda>a. a" "\<lambda>a. a" assoc\<^sub>S
using is_elementary_monoidal_category by auto
sublocale free_strict_monoidal_category \<subseteq> monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
using is_monoidal_category by auto
sublocale free_strict_monoidal_category \<subseteq>
strict_monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
using tensor_preserves_ide assoc_agreement lunit_agreement runit_agreement
apply unfold_locales
unfolding assoc\<^sub>S_def
apply presburger
apply meson
by meson
context free_strict_monoidal_category
begin
text \<open>
The inclusion of generators functor from @{term C} to \<open>\<F>\<^sub>SC\<close> is the composition
of the inclusion of generators from @{term C} to \<open>\<F>C\<close> and the diagonalization
functor, which projects \<open>\<F>C\<close> to \<open>\<F>\<^sub>SC\<close>. As the diagonalization functor
is the identity map on the image of @{term C}, the composite functor amounts to the
corestriction to \<open>\<F>\<^sub>SC\<close> of the inclusion of generators of \<open>\<F>C\<close>.
\<close>
interpretation D: "functor" \<F>C.comp comp \<F>C.D
using \<F>C.diagonalize_is_functor by auto
interpretation I: composite_functor C \<F>C.comp comp \<F>C.inclusion_of_generators \<F>C.D
proof -
interpret "functor" C \<F>C.comp \<F>C.inclusion_of_generators
using \<F>C.inclusion_is_functor by blast
show "composite_functor C \<F>C.comp comp \<F>C.inclusion_of_generators \<F>C.D" ..
qed
definition inclusion_of_generators
where "inclusion_of_generators \<equiv> \<F>C.inclusion_of_generators"
lemma inclusion_is_functor:
shows "functor C comp inclusion_of_generators"
using \<F>C.DoI_eq_I I.functor_axioms inclusion_of_generators_def
by auto
text \<open>
The diagonalization functor is strict monoidal.
\<close>
interpretation D: strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
\<F>C.D
proof
show "\<F>C.D \<F>C.\<iota> = \<iota>"
proof -
have "\<F>C.D \<F>C.\<iota> = \<F>C.mkarr \<^bold>\<lfloor>\<F>C.rep \<F>C.\<iota>\<^bold>\<rfloor>"
unfolding \<F>C.D_def using \<F>C.\<iota>_in_hom by auto
also have "... = \<F>C.mkarr \<^bold>\<lfloor>\<^bold>\<l>\<^bold>[\<^bold>\<parallel>\<^bold>\<I>\<^bold>\<parallel>\<^bold>]\<^bold>\<rfloor>"
using \<F>C.\<iota>_def \<F>C.rep_unity \<F>C.rep_lunit \<F>C.Par_Arr_norm \<F>C.Diagonalize_norm
by auto
also have "... = \<iota>"
using \<F>C.unity\<^sub>F\<^sub>M\<^sub>C_def \<F>C.\<I>_agreement \<iota>_def by simp
finally show ?thesis by blast
qed
show "\<And>f g. \<lbrakk> \<F>C.arr f; \<F>C.arr g \<rbrakk> \<Longrightarrow>
\<F>C.D (\<F>C.tensor f g) = tensor (\<F>C.D f) (\<F>C.D g)"
proof -
fix f g
assume f: "\<F>C.arr f" and g: "\<F>C.arr g"
have fg: "arr (\<F>C.D f) \<and> arr (\<F>C.D g)"
using f g D.preserves_arr by blast
have "\<F>C.D (\<F>C.tensor f g) = f \<otimes>\<^sub>S g"
using tensor\<^sub>S_def by simp
also have "f \<otimes>\<^sub>S g = \<F>C.D (f \<otimes> g)"
using f g tensor\<^sub>S_def by simp
also have "... = \<F>C.D f \<otimes>\<^sub>S \<F>C.D g"
using f g fg tensor\<^sub>S_def \<F>C.T_simp \<F>C.diagonalize_tensor arr_char
by (metis (no_types, lifting))
also have "... = tensor (\<F>C.D f) (\<F>C.D g)"
using fg T_simp by simp
finally show "\<F>C.D (\<F>C.tensor f g) = tensor (\<F>C.D f) (\<F>C.D g)"
by blast
qed
show "\<And>a b c. \<lbrakk> \<F>C.ide a; \<F>C.ide b; \<F>C.ide c \<rbrakk> \<Longrightarrow>
\<F>C.D (\<F>C.assoc a b c) = assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c)"
proof -
fix a b c
assume a: "\<F>C.ide a" and b: "\<F>C.ide b" and c: "\<F>C.ide c"
have abc: "ide (\<F>C.D a) \<and> ide (\<F>C.D b) \<and> ide (\<F>C.D c)"
using a b c D.preserves_ide by blast
have abc': "\<F>C.ide (\<F>C.D a) \<and> \<F>C.ide (\<F>C.D b) \<and> \<F>C.ide (\<F>C.D c)"
using a b c D.preserves_ide ide_char by simp
have 1: "\<And>f g. \<F>C.arr f \<Longrightarrow> \<F>C.arr g \<Longrightarrow> f \<otimes>\<^sub>S g = \<F>C.D (f \<otimes> g)"
using tensor\<^sub>S_def by simp
have 2: "\<And>f. ide f \<Longrightarrow> \<F>C.ide f" using ide_char by blast
have "assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c) = \<F>C.D a \<otimes>\<^sub>S \<F>C.D b \<otimes>\<^sub>S \<F>C.D c"
using abc \<alpha>_ide_simp assoc\<^sub>S_def by simp
also have "... = \<F>C.D a \<otimes>\<^sub>S \<F>C.D (\<F>C.D b \<otimes> \<F>C.D c)"
using abc' 1 by auto
also have "... = \<F>C.D a \<otimes>\<^sub>S \<F>C.D (b \<otimes> c)"
using b c \<F>C.diagonalize_tensor by force
also have "... = \<F>C.D (\<F>C.D a \<otimes> \<F>C.D (b \<otimes> c))"
using 1 b c abc D.preserves_ide \<F>C.tensor_preserves_ide ide_char
by simp
also have "... = \<F>C.D (a \<otimes> b \<otimes> c)"
using a b c \<F>C.diagonalize_tensor by force
also have "... = \<F>C.D \<a>[a, b, c]"
proof -
have "\<F>C.can \<a>[a, b, c]" using a b c \<F>C.can_assoc by simp
hence "\<F>C.ide (\<F>C.D \<a>[a, b, c])"
using a b c \<F>C.ide_diagonalize_can by simp
moreover have "\<F>C.cod (\<F>C.D \<a>[a, b, c]) = \<F>C.D (a \<otimes> b \<otimes> c)"
using a b c \<F>C.assoc_in_hom D.preserves_hom
by (metis (no_types, lifting) cod_char in_homE)
ultimately show ?thesis by simp
qed
also have "... = \<F>C.D (\<F>C.assoc a b c)"
using a b c by simp
finally show "\<F>C.D (\<F>C.assoc a b c) = assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c)"
by blast
qed
qed
lemma diagonalize_is_strict_monoidal_functor:
shows "strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
\<F>C.D"
..
interpretation \<phi>: natural_isomorphism
\<F>C.CC.comp comp D.T\<^sub>DoFF.map D.FoT\<^sub>C.map D.\<phi>
using D.structure_is_natural_isomorphism by simp
text \<open>
The diagonalization functor is part of a monoidal equivalence between the
free monoidal category and the subcategory @{term "\<F>\<^sub>SC"}.
\<close>
interpretation E: equivalence_of_categories comp \<F>C.comp \<F>C.D map \<F>C.\<nu> \<F>C.\<mu>
using \<F>C.is_equivalent_to_strict_subcategory by auto
interpretation D: monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
\<F>C.D D.\<phi>
using D.monoidal_functor_axioms by metis
interpretation equivalence_of_monoidal_categories comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
\<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
\<F>C.D D.\<phi> \<I>
map \<F>C.\<nu> \<F>C.\<mu>
..
text \<open>
The category @{term "\<F>C"} is monoidally equivalent to its subcategory @{term "\<F>\<^sub>SC"}.
\<close>
theorem monoidally_equivalent_to_free_monoidal_category:
shows "equivalence_of_monoidal_categories comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
\<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
\<F>C.D D.\<phi>
map \<F>C.\<nu> \<F>C.\<mu>"
..
end
text \<open>
We next show that the evaluation functor induced on the free monoidal category
generated by @{term C} by a functor @{term V} from @{term C} to a strict monoidal
category @{term D} restricts to a strict monoidal functor on the subcategory @{term "\<F>\<^sub>SC"}.
\<close>
locale strict_evaluation_functor =
D: strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
evaluation_map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
\<F>C: free_monoidal_category C +
E: evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
\<F>\<^sub>SC: free_strict_monoidal_category C
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and V :: "'c \<Rightarrow> 'd"
begin
notation \<F>C.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation \<F>\<^sub>SC.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
(* TODO: This is just the restriction of the evaluation functor to a subcategory.
It would be useful to define a restriction_of_functor locale that does this in general
and gives the lemma that it yields a functor. *)
definition map
where "map \<equiv> \<lambda>f. if \<F>\<^sub>SC.arr f then E.map f else D.null"
interpretation "functor" \<F>\<^sub>SC.comp D map
unfolding map_def
apply unfold_locales
apply simp
using \<F>\<^sub>SC.arr_char E.preserves_arr
apply simp
using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.dom_char E.preserves_dom
apply simp
using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.cod_char E.preserves_cod
apply simp
using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.dom_char \<F>\<^sub>SC.cod_char \<F>\<^sub>SC.comp_char E.preserves_comp
by (elim \<F>\<^sub>SC.seqE, auto)
lemma is_functor:
shows "functor \<F>\<^sub>SC.comp D map" ..
text \<open>
Every canonical arrow is an equivalence class of canonical terms.
The evaluations in \<open>D\<close> of all such terms are identities,
due to the strictness of \<open>D\<close>.
\<close>
lemma ide_eval_Can:
shows "Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>"
proof (induct t)
show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow> D.ide \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>" by simp
show "Can \<^bold>\<I> \<Longrightarrow> D.ide \<lbrace>\<^bold>\<I>\<rbrace>" by simp
show "\<And>t1 t2. \<lbrakk> Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>; Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>; Can (t1 \<^bold>\<otimes> t2) \<rbrakk> \<Longrightarrow>
D.ide \<lbrace>t1 \<^bold>\<otimes> t2\<rbrace>"
by simp
show "\<And>t1 t2. \<lbrakk> Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>; Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>; Can (t1 \<^bold>\<cdot> t2) \<rbrakk> \<Longrightarrow>
D.ide \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
proof -
fix t1 t2
assume t1: "Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>"
and t2: "Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>"
and t12: "Can (t1 \<^bold>\<cdot> t2)"
show "D.ide \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
using t1 t2 t12 Can_implies_Arr eval_in_hom [of t1] eval_in_hom [of t2] D.comp_ide_arr
by fastforce
qed
show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
using D.strict_lunit by simp
show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
using D.strict_lunit by simp
show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
using D.strict_runit by simp
show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
using D.strict_runit by simp
fix t1 t2 t3
assume t1: "Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>"
and t2: "Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>"
and t3: "Can t3 \<Longrightarrow> D.ide \<lbrace>t3\<rbrace>"
show "Can \<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]\<rbrace>"
proof -
assume "Can \<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]"
hence t123: "D.ide \<lbrace>t1\<rbrace> \<and> D.ide \<lbrace>t2\<rbrace> \<and> D.ide \<lbrace>t3\<rbrace>"
using t1 t2 t3 by simp
have "\<lbrace>\<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]\<rbrace> = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
using t123 D.strict_assoc D.assoc_in_hom [of "\<lbrace>t1\<rbrace>" "\<lbrace>t2\<rbrace>" "\<lbrace>t3\<rbrace>"] apply simp
by (elim D.in_homE, simp)
thus ?thesis using t123 by simp
qed
show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace>"
proof -
assume "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]"
hence t123: "Can t1 \<and> Can t2 \<and> Can t3 \<and> D.ide \<lbrace>t1\<rbrace> \<and> D.ide \<lbrace>t2\<rbrace> \<and> D.ide \<lbrace>t3\<rbrace>"
using t1 t2 t3 by simp
have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace>
= D.inv \<a>\<^sub>D[D.cod \<lbrace>t1\<rbrace>, D.cod \<lbrace>t2\<rbrace>, D.cod \<lbrace>t3\<rbrace>] \<cdot>\<^sub>D (\<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>)"
using t123 eval_Assoc' [of t1 t2 t3] Can_implies_Arr by simp
also have "... = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
proof -
have "D.dom \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>] = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
proof -
have "D.dom \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>] = D.cod \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>]"
using t123 D.strict_assoc by simp
also have "... = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
using t123 by simp
finally show ?thesis by blast
qed
thus ?thesis
using t123 D.strict_assoc D.comp_arr_dom by auto
qed
finally have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace> = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>" by blast
thus ?thesis using t123 by auto
qed
qed
lemma ide_eval_can:
assumes "\<F>C.can f"
shows "D.ide (E.map f)"
proof -
have "f = \<F>C.mkarr (\<F>C.rep f)"
using assms \<F>C.can_implies_arr \<F>C.mkarr_rep by blast
moreover have 1: "Can (\<F>C.rep f)"
using assms \<F>C.Can_rep_can by simp
moreover have "D.ide \<lbrace>\<F>C.rep f\<rbrace>"
using assms ide_eval_Can by (simp add: 1)
ultimately show ?thesis using assms \<F>C.can_implies_arr E.map_def by force
qed
text \<open>
Diagonalization transports formal arrows naturally along reductions,
which are canonical terms and therefore evaluate to identities of \<open>D\<close>.
It follows that the evaluation in \<open>D\<close> of a formal arrow is equal to the
evaluation of its diagonalization.
\<close>
lemma map_diagonalize:
assumes f: "\<F>C.arr f"
shows "E.map (\<F>C.D f) = E.map f"
proof -
interpret EQ: equivalence_of_categories
\<F>\<^sub>SC.comp \<F>C.comp \<F>C.D \<F>\<^sub>SC.map \<F>C.\<nu> \<F>C.\<mu>
using \<F>C.is_equivalent_to_strict_subcategory by auto
have 1: "\<F>C.seq (\<F>\<^sub>SC.map (\<F>C.D f)) (\<F>C.\<nu> (\<F>C.dom f))"
proof
show "\<guillemotleft>\<F>C.\<nu> (\<F>C.dom f) : \<F>C.dom f \<rightarrow> \<F>C.D (\<F>C.dom f)\<guillemotright>"
using f \<F>\<^sub>SC.map_simp EQ.F.preserves_arr
by (intro \<F>C.in_homI, simp_all)
show "\<guillemotleft>\<F>\<^sub>SC.map (\<F>C.D f) : \<F>C.D (\<F>C.dom f) \<rightarrow> \<F>C.cod (\<F>C.D f)\<guillemotright>"
using f \<F>\<^sub>SC.map_simp \<F>C.arr_iff_in_hom EQ.F.preserves_hom \<F>\<^sub>SC.arr_char
\<F>\<^sub>SC.in_hom_char [of "\<F>C.D f" "\<F>C.D (\<F>C.dom f)" "\<F>C.D (\<F>C.cod f)"]
by (intro \<F>C.in_homI, auto)
qed
have "E.map (\<F>C.\<nu> (\<F>C.cod f)) \<cdot>\<^sub>D E.map f =
E.map (\<F>C.D f) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
proof -
have "E.map (\<F>C.\<nu> (\<F>C.cod f)) \<cdot>\<^sub>D E.map f = E.map (\<F>C.\<nu> (\<F>C.cod f) \<cdot> f)"
using f by simp
also have "... = E.map (\<F>C.D f \<cdot> \<F>C.\<nu> (\<F>C.dom f))"
using f EQ.\<eta>.naturality \<F>\<^sub>SC.map_simp EQ.F.preserves_arr by simp
also have "... = E.map (\<F>\<^sub>SC.map (\<F>C.D f)) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
using f 1 E.preserves_comp_2 EQ.F.preserves_arr \<F>\<^sub>SC.map_simp
by (metis (no_types, lifting))
also have "... = E.map (\<F>C.D f) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
using f EQ.F.preserves_arr \<F>\<^sub>SC.map_simp by simp
finally show ?thesis by blast
qed
moreover have "\<And>a. \<F>C.ide a \<Longrightarrow> D.ide (E.map (\<F>C.\<nu> a))"
using \<F>C.\<nu>_def \<F>C.Arr_rep Arr_implies_Ide_Cod Can_red \<F>C.can_mkarr_Can
ide_eval_can
by (metis (no_types, lifting) EQ.\<eta>.preserves_reflects_arr \<F>C.seqE
\<F>C.comp_preserves_can \<F>C.ideD(1) \<F>C.ide_implies_can)
moreover have "D.cod (E.map f) = D.dom (E.map (\<F>C.\<nu> (\<F>C.cod f)))"
using f E.preserves_hom EQ.\<eta>.preserves_hom by simp
moreover have "D.dom (E.map (\<F>C.D f)) = D.cod (E.map (\<F>C.\<nu> (\<F>C.dom f)))"
using f 1 E.preserves_seq EQ.F.preserves_arr \<F>\<^sub>SC.map_simp by auto
ultimately show ?thesis
using f D.comp_arr_dom D.ideD D.arr_dom_iff_arr E.is_natural_2
by (metis E.preserves_cod \<F>C.ide_cod \<F>C.ide_dom)
qed
lemma strictly_preserves_tensor:
assumes "\<F>\<^sub>SC.arr f" and "\<F>\<^sub>SC.arr g"
shows "map (\<F>\<^sub>SC.tensor f g) = map f \<otimes>\<^sub>D map g"
proof -
have 1: "\<F>C.arr (f \<otimes> g)"
using assms \<F>\<^sub>SC.arr_char \<F>C.tensor_in_hom by auto
have 2: "\<F>\<^sub>SC.arr (\<F>\<^sub>SC.tensor f g)"
using assms \<F>\<^sub>SC.tensor_in_hom [of f g] \<F>\<^sub>SC.T_simp by fastforce
have "map (\<F>\<^sub>SC.tensor f g) = E.map (f \<otimes> g)"
proof -
have "map (\<F>\<^sub>SC.tensor f g) = map (f \<otimes>\<^sub>S g)"
using assms \<F>\<^sub>SC.T_simp by simp
also have "... = map (\<F>C.D (f \<otimes> g))"
using assms \<F>C.tensor\<^sub>F\<^sub>M\<^sub>C_def \<F>\<^sub>SC.tensor\<^sub>S_def \<F>\<^sub>SC.arr_char by force
also have "... = E.map (f \<otimes> g)"
proof -
interpret Diag: "functor" \<F>C.comp \<F>\<^sub>SC.comp \<F>C.D
using \<F>C.diagonalize_is_functor by auto
show ?thesis
using assms 1 map_diagonalize [of "f \<otimes> g"] Diag.preserves_arr map_def by simp
qed
finally show ?thesis by blast
qed
thus ?thesis
using assms \<F>\<^sub>SC.arr_char E.strictly_preserves_tensor map_def by simp
qed
lemma is_strict_monoidal_functor:
shows "strict_monoidal_functor \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map"
proof
show "\<And>f g. \<F>\<^sub>SC.arr f \<Longrightarrow> \<F>\<^sub>SC.arr g \<Longrightarrow> map (\<F>\<^sub>SC.tensor f g) = map f \<otimes>\<^sub>D map g"
using strictly_preserves_tensor by fast
show "map \<F>\<^sub>SC.\<iota> = \<iota>\<^sub>D"
using \<F>\<^sub>SC.arr_unity \<F>\<^sub>SC.\<iota>_def map_def E.map_def \<F>C.rep_mkarr E.eval_norm D.strict_unit
by auto
fix a b c
assume a: "\<F>\<^sub>SC.ide a" and b: "\<F>\<^sub>SC.ide b" and c: "\<F>\<^sub>SC.ide c"
show "map (\<F>\<^sub>SC.assoc a b c) = \<a>\<^sub>D[map a, map b, map c]"
proof -
have "map (\<F>\<^sub>SC.assoc a b c) = map a \<otimes>\<^sub>D map b \<otimes>\<^sub>D map c"
using a b c \<F>\<^sub>SC.\<alpha>_def \<F>\<^sub>SC.assoc_agreement \<F>\<^sub>SC.assoc\<^sub>S_def \<F>\<^sub>SC.arr_tensor
\<F>\<^sub>SC.T_simp \<F>\<^sub>SC.ideD(1) \<F>\<^sub>SC.strict_assoc preserves_ide [of "\<F>\<^sub>SC.assoc a b c"]
strictly_preserves_tensor
by force
also have "... = \<a>\<^sub>D[map a, map b, map c]"
using a b c D.strict_assoc D.assoc_in_hom [of "map a" "map b" "map c"] by auto
finally show ?thesis by blast
qed
qed
end
sublocale strict_evaluation_functor \<subseteq>
strict_monoidal_functor \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
using is_strict_monoidal_functor by auto
locale strict_monoidal_extension_to_free_strict_monoidal_category =
C: category C +
monoidal_language C +
\<F>\<^sub>SC: free_strict_monoidal_category C +
strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
\<F>\<^sub>SC.inclusion_of_generators V F
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and V :: "'c \<Rightarrow> 'd"
and F :: "'c free_monoidal_category.arr \<Rightarrow> 'd"
sublocale strict_evaluation_functor \<subseteq>
strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
\<F>\<^sub>SC.inclusion_of_generators V map
proof -
interpret V: "functor" C \<F>\<^sub>SC.comp \<F>\<^sub>SC.inclusion_of_generators
using \<F>\<^sub>SC.inclusion_is_functor by auto
show "strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
\<F>\<^sub>SC.inclusion_of_generators V map"
proof
show "\<forall>f. C.arr f \<longrightarrow> map (\<F>\<^sub>SC.inclusion_of_generators f) = V f"
using V.preserves_arr E.is_extension map_def \<F>\<^sub>SC.inclusion_of_generators_def by simp
qed
qed
context free_strict_monoidal_category
begin
text \<open>
We now have the main result of this section: the evaluation functor on \<open>\<F>\<^sub>SC\<close>
induced by a functor @{term V} from @{term C} to a strict monoidal category @{term D}
is the unique strict monoidal extension of @{term V} to \<open>\<F>\<^sub>SC\<close>.
\<close>
theorem is_free:
assumes "strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D"
and "strict_monoidal_extension_to_free_strict_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F"
shows "F = strict_evaluation_functor.map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V"
proof -
interpret D: strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
using assms(1) by auto
text \<open>
Let @{term F} be a given extension of V to a strict monoidal functor defined on
\<open>\<F>\<^sub>SC\<close>.
\<close>
interpret F: strict_monoidal_extension_to_free_strict_monoidal_category
C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F
using assms(2) by auto
text \<open>
Let @{term E\<^sub>S} be the evaluation functor from \<open>\<F>\<^sub>SC\<close> to @{term D}
induced by @{term V}. Then @{term E\<^sub>S} is also a strict monoidal extension of @{term V}.
\<close>
interpret E\<^sub>S: strict_evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V ..
text \<open>
Let @{term D} be the strict monoidal functor @{term "\<F>C.D"} that projects
\<open>\<F>C\<close> to the subcategory \<open>\<F>\<^sub>SC\<close>.
\<close>
interpret D: "functor" \<F>C.comp comp \<F>C.D
using \<F>C.diagonalize_is_functor by auto
interpret D: strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota>
comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha> \<iota>
\<F>C.D
using diagonalize_is_strict_monoidal_functor by blast
text \<open>
The composite functor \<open>F o D\<close> is also an extension of @{term V}
to a strict monoidal functor on \<open>\<F>C\<close>.
\<close>
interpret FoD: composite_functor \<F>C.comp comp D \<F>C.D F ..
interpret FoD: strict_monoidal_functor
- \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D "F o \<F>C.D"
+ \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<open>F o \<F>C.D\<close>
using D.strict_monoidal_functor_axioms F.strict_monoidal_functor_axioms
strict_monoidal_functors_compose
by fast
interpret FoD: strict_monoidal_extension_to_free_monoidal_category
C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V FoD.map
proof
show "\<forall>f. C.arr f \<longrightarrow> FoD.map (\<F>C.inclusion_of_generators f) = V f"
proof -
have "\<And>f. C.arr f \<Longrightarrow> FoD.map (\<F>C.inclusion_of_generators f) = V f"
proof -
fix f
assume f: "C.arr f"
have "FoD.map (\<F>C.inclusion_of_generators f)
= F (\<F>C.D (\<F>C.inclusion_of_generators f))"
using f by simp
also have "... = F (inclusion_of_generators f)"
using f \<F>C.strict_arr_char' F.I.preserves_arr inclusion_of_generators_def by simp
also have "... = V f"
using f F.is_extension by simp
finally show "FoD.map (\<F>C.inclusion_of_generators f) = V f"
by blast
qed
thus ?thesis by blast
qed
qed
text \<open>
By the freeness of \<open>\<F>C\<close>, we have that \<open>F o D\<close>
is equal to the evaluation functor @{term "E\<^sub>S.E.map"} induced by @{term V}
on \<open>\<F>C\<close>. Moreover, @{term E\<^sub>S.map} coincides with @{term "E\<^sub>S.E.map"} on
\<open>\<F>\<^sub>SC\<close> and \<open>F o D\<close> coincides with @{term F} on
\<open>\<F>\<^sub>SC\<close>. Therefore, @{term F} coincides with @{term E} on their common
domain \<open>\<F>\<^sub>SC\<close>, showing @{term "F = E\<^sub>S.map"}.
\<close>
have "\<And>f. arr f \<Longrightarrow> F f = E\<^sub>S.map f"
using \<F>C.strict_arr_char' \<F>C.is_free [of D] E\<^sub>S.E.evaluation_functor_axioms
FoD.strict_monoidal_extension_to_free_monoidal_category_axioms E\<^sub>S.map_def
by simp
moreover have "\<And>f. \<not>arr f \<Longrightarrow> F f = E\<^sub>S.map f"
using F.is_extensional E\<^sub>S.is_extensional arr_char by auto
ultimately show "F = E\<^sub>S.map" by blast
qed
end
end
diff --git a/thys/MonoidalCategory/MonoidalCategory.thy b/thys/MonoidalCategory/MonoidalCategory.thy
--- a/thys/MonoidalCategory/MonoidalCategory.thy
+++ b/thys/MonoidalCategory/MonoidalCategory.thy
@@ -1,4557 +1,4557 @@
(* Title: MonoidalCategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter "Monoidal Category"
text_raw\<open>
\label{monoidal-category-chap}
\<close>
text \<open>
In this theory, we define the notion ``monoidal category,'' and develop consequences of
the definition. The main result is a proof of MacLane's coherence theorem.
\<close>
theory MonoidalCategory
imports Category3.EquivalenceOfCategories
begin
section "Monoidal Category"
text \<open>
A typical textbook presentation defines a monoidal category to be a category @{term C}
equipped with (among other things) a binary ``tensor product'' functor \<open>\<otimes>: C \<times> C \<rightarrow> C\<close>
and an ``associativity'' natural isomorphism \<open>\<alpha>\<close>, whose components are isomorphisms
\<open>\<alpha> (a, b, c): (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> (b \<otimes> c)\<close> for objects \<open>a\<close>, \<open>b\<close>,
and \<open>c\<close> of \<open>C\<close>. This way of saying things avoids an explicit definition of
the functors that are the domain and codomain of \<open>\<alpha>\<close> and, in particular, what category
serves as the domain of these functors. The domain category is in fact the product
category \<open>C \<times> C \<times> C\<close> and the domain and codomain of \<open>\<alpha>\<close> are the functors
\<open>T o (T \<times> C): C \<times> C \<times> C \<rightarrow> C\<close> and \<open>T o (C \<times> T): C \<times> C \<times> C \<rightarrow> C\<close>.
In a formal development, though, we can't gloss over the fact that
\<open>C \<times> C \<times> C\<close> has to mean either \<open>C \<times> (C \<times> C)\<close> or \<open>(C \<times> C) \<times> C\<close>,
which are not formally identical, and that associativities are somehow involved in the
definitions of the functors \<open>T o (T \<times> C)\<close> and \<open>T o (C \<times> T)\<close>.
Here we define the \<open>binary_endofunctor\<close> locale to codify our choices about what
\<open>C \<times> C \<times> C\<close>, \<open>T o (T \<times> C)\<close>, and \<open>T o (C \<times> T)\<close> actually mean.
In particular, we choose \<open>C \<times> C \<times> C\<close> to be \<open>C \<times> (C \<times> C)\<close> and define the
functors \<open>T o (T \<times> C)\<close>, and \<open>T o (C \<times> T)\<close> accordingly.
\<close>
locale binary_endofunctor =
C: category C +
CC: product_category C C +
CCC: product_category C CC.comp +
binary_functor C C C T
for C :: "'a comp" (infixr "\<cdot>" 55)
and T :: "'a * 'a \<Rightarrow> 'a"
begin
definition ToTC
where "ToTC f \<equiv> if CCC.arr f then T (T (fst f, fst (snd f)), snd (snd f)) else C.null"
lemma functor_ToTC:
shows "functor CCC.comp C ToTC"
using ToTC_def apply unfold_locales
apply auto[4]
proof -
fix f g
assume gf: "CCC.seq g f"
show "ToTC (CCC.comp g f) = ToTC g \<cdot> ToTC f"
using gf unfolding CCC.seq_char CC.seq_char ToTC_def apply auto
apply (elim C.seqE, auto)
by (metis C.seqI CC.comp_simp CC.seqI fst_conv preserves_comp preserves_seq snd_conv)
qed
lemma ToTC_simp [simp]:
assumes "C.arr f" and "C.arr g" and "C.arr h"
shows "ToTC (f, g, h) = T (T (f, g), h)"
using assms ToTC_def CCC.arr_char by simp
definition ToCT
where "ToCT f \<equiv> if CCC.arr f then T (fst f, T (fst (snd f), snd (snd f))) else C.null"
lemma functor_ToCT:
shows "functor CCC.comp C ToCT"
using ToCT_def apply unfold_locales
apply auto[4]
proof -
fix f g
assume gf: "CCC.seq g f"
show "ToCT (CCC.comp g f) = ToCT g \<cdot> ToCT f "
using gf unfolding CCC.seq_char CC.seq_char ToCT_def apply auto
apply (elim C.seqE, auto)
by (metis C.seqI CC.comp_simp CC.seqI fst_conv preserves_comp preserves_seq snd_conv)
qed
lemma ToCT_simp [simp]:
assumes "C.arr f" and "C.arr g" and "C.arr h"
shows "ToCT (f, g, h) = T (f, T (g, h))"
using assms ToCT_def CCC.arr_char by simp
end
text \<open>
Our primary definition for ``monoidal category'' follows the somewhat non-traditional
development in \cite{Etingof15}. There a monoidal category is defined to be a category
\<open>C\<close> equipped with a binary \emph{tensor product} functor \<open>T: C \<times> C \<rightarrow> C\<close>,
an \emph{associativity isomorphism}, which is a natural isomorphism
\<open>\<alpha>: T o (T \<times> C) \<rightarrow> T o (C \<times> T)\<close>, a \emph{unit object} \<open>\<I>\<close> of \<open>C\<close>,
and an isomorphism \<open>\<iota>: T (\<I>, \<I>) \<rightarrow> \<I>\<close>, subject to two axioms:
the \emph{pentagon axiom}, which expresses the commutativity of certain pentagonal diagrams
involving components of \<open>\<alpha>\<close>, and the left and right \emph{unit axioms}, which state
that the endofunctors \<open>T (\<I>, -)\<close> and \<open>T (-, \<I>)\<close> are equivalences of categories.
This definition is formalized in the \<open>monoidal_category\<close> locale.
In more traditional developments, the definition of monoidal category involves additional
left and right \emph{unitor} isomorphisms \<open>\<lambda>\<close> and \<open>\<rho>\<close> and associated axioms
involving their components.
However, as is shown in \cite{Etingof15} and formalized here, the unitors are uniquely
determined by \<open>\<alpha>\<close> and their values \<open>\<lambda>(\<I>)\<close> and \<open>\<rho>(\<I>)\<close> at \<open>\<I>\<close>,
which coincide. Treating \<open>\<lambda>\<close> and \<open>\<rho>\<close> as defined notions results in a more
economical basic definition of monoidal category that requires less data to be given,
and has a similar effect on the definition of ``monoidal functor.''
Moreover, in the context of the formalization of categories that we use here,
the unit object \<open>\<I>\<close> also need not be given separately, as it can be obtained as the
codomain of the isomorphism \<open>\<iota>\<close>.
\<close>
locale monoidal_category =
category C +
CC: product_category C C +
CCC: product_category C CC.comp +
T: binary_endofunctor C T +
\<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha> +
L: equivalence_functor C C "\<lambda>f. T (cod \<iota>, f)" +
R: equivalence_functor C C "\<lambda>f. T (f, cod \<iota>)"
for C :: "'a comp" (infixr "\<cdot>" 55)
and T :: "'a * 'a \<Rightarrow> 'a"
and \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a"
and \<iota> :: 'a +
assumes \<iota>_in_hom': "\<guillemotleft>\<iota> : T (cod \<iota>, cod \<iota>) \<rightarrow> cod \<iota>\<guillemotright>"
and \<iota>_is_iso: "iso \<iota>"
and pentagon: "\<lbrakk> ide a; ide b; ide c; ide d \<rbrakk> \<Longrightarrow>
T (a, \<alpha> (b, c, d)) \<cdot> \<alpha> (a, T (b, c), d) \<cdot> T (\<alpha> (a, b, c), d) =
\<alpha> (a, b, T (c, d)) \<cdot> \<alpha> (T (a, b), c, d)"
begin
text\<open>
We now define helpful notation and abbreviations to improve readability.
We did not define and use the notation \<open>\<otimes>\<close> for the tensor product
in the definition of the locale because to define \<open>\<otimes>\<close> as a binary
operator requires that it be in curried form, whereas for \<open>T\<close>
to be a binary functor requires that it take a pair as its argument.
\<close>
definition unity :: 'a ("\<I>")
where "unity \<equiv> cod \<iota>"
abbreviation L :: "'a \<Rightarrow> 'a"
where "L f \<equiv> T (\<I>, f)"
abbreviation R :: "'a \<Rightarrow> 'a"
where "R f \<equiv> T (f, \<I>)"
abbreviation tensor (infixr "\<otimes>" 53)
where "f \<otimes> g \<equiv> T (f, g)"
abbreviation assoc ("\<a>[_, _, _]")
where "\<a>[a, b, c] \<equiv> \<alpha> (a, b, c)"
text\<open>
In HOL we can just give the definitions of the left and right unitors ``up front''
without any preliminary work. Later we will have to show that these definitions
have the right properties. The next two definitions define the values of the
unitors when applied to identities; that is, their components as natural transformations.
\<close>
definition lunit ("\<l>[_]")
where "lunit a \<equiv> THE f. \<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright> \<and> \<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
definition runit ("\<r>[_]")
where "runit a \<equiv> THE f. \<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright> \<and> f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
text\<open>
The next two definitions extend the unitors to all arrows, not just identities.
Unfortunately, the traditional symbol \<open>\<lambda>\<close> for the left unitor is already
reserved for a higher purpose, so we have to make do with a poor substitute.
\<close>
abbreviation \<ll>
where "\<ll> f \<equiv> if arr f then f \<cdot> \<l>[dom f] else null"
abbreviation \<rho>
where "\<rho> f \<equiv> if arr f then f \<cdot> \<r>[dom f] else null"
text\<open>
We now embark upon a development of the consequences of the monoidal category axioms.
One of our objectives is to be able to show that an interpretation of the
\<open>monoidal_category\<close> locale induces an interpretation of a locale corresponding
to a more traditional definition of monoidal category.
Another is to obtain the facts we need to prove the coherence theorem.
\<close>
lemma \<iota>_in_hom [intro]:
shows "\<guillemotleft>\<iota> : \<I> \<otimes> \<I> \<rightarrow> \<I>\<guillemotright>"
using unity_def \<iota>_in_hom' by force
lemma ide_unity [simp]:
shows "ide \<I>"
using \<iota>_in_hom unity_def by auto
lemma tensor_in_hom [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
shows "\<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
using assms T.preserves_hom CC.arr_char by simp
lemma arr_tensor [simp]:
assumes "arr f" and "arr g"
shows "arr (f \<otimes> g)"
using assms by simp
lemma dom_tensor [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
shows "dom (f \<otimes> g) = a \<otimes> c"
using assms by fastforce
lemma cod_tensor [simp]:
assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
shows "cod (f \<otimes> g) = b \<otimes> d"
using assms by fastforce
lemma tensor_preserves_ide [simp]:
assumes "ide a" and "ide b"
shows "ide (a \<otimes> b)"
using assms T.preserves_ide CC.ide_char by simp
lemma tensor_preserves_iso [simp]:
assumes "iso f" and "iso g"
shows "iso (f \<otimes> g)"
using assms by simp
lemma inv_tensor [simp]:
assumes "iso f" and "iso g"
shows "inv (f \<otimes> g) = inv f \<otimes> inv g"
using assms T.preserves_inv by auto
lemma interchange:
assumes "seq h g" and "seq h' g'"
shows "(h \<otimes> h') \<cdot> (g \<otimes> g') = h \<cdot> g \<otimes> h' \<cdot> g'"
using assms T.preserves_comp [of "(h, h')" "(g, g')"] by simp
lemma \<alpha>_simp:
assumes "arr f" and "arr g" and "arr h"
shows "\<alpha> (f, g, h) = (f \<otimes> g \<otimes> h) \<cdot> \<a>[dom f, dom g, dom h]"
using assms \<alpha>.is_natural_1 [of "(f, g, h)"] by simp
lemma assoc_in_hom [intro]:
assumes "ide a" and "ide b" and "ide c"
shows "\<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>"
using assms CCC.in_homE by auto
lemma arr_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "arr \<a>[a, b, c]"
using assms assoc_in_hom by simp
lemma dom_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
using assms assoc_in_hom by simp
lemma cod_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
using assms assoc_in_hom by simp
lemma assoc_naturality:
assumes "arr f0" and "arr f1" and "arr f2"
shows "\<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) =
(f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
using assms \<alpha>.naturality by auto
lemma iso_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "iso \<a>[a, b, c]"
using assms \<alpha>.preserves_iso by simp
text\<open>
The next result uses the fact that the functor \<open>L\<close> is an equivalence
(and hence faithful) to show the existence of a unique solution to the characteristic
equation used in the definition of a component @{term "\<l>[a]"} of the left unitor.
It follows that @{term "\<l>[a]"}, as given by our definition using definite description,
satisfies this characteristic equation and is therefore uniquely determined by
by \<open>\<otimes>\<close>, @{term \<alpha>}, and \<open>\<iota>\<close>.
\<close>
lemma lunit_char:
assumes "ide a"
shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" and "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
and "\<exists>!f. \<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright> \<and> \<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
proof -
obtain F \<eta> \<epsilon> where L: "equivalence_of_categories C C F (\<lambda>f. \<I> \<otimes> f) \<eta> \<epsilon>"
using L.induces_equivalence unity_def by auto
- interpret L: equivalence_of_categories C C F "\<lambda>f. \<I> \<otimes> f" \<eta> \<epsilon>
+ interpret L: equivalence_of_categories C C F \<open>\<lambda>f. \<I> \<otimes> f\<close> \<eta> \<epsilon>
using L by auto
let ?P = "\<lambda>f. \<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright> \<and> \<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
have "\<guillemotleft>(\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a] : \<I> \<otimes> \<I> \<otimes> a \<rightarrow> \<I> \<otimes> a\<guillemotright>"
proof
show "\<guillemotleft>\<iota> \<otimes> a : (\<I> \<otimes> \<I>) \<otimes> a \<rightarrow> \<I> \<otimes> a\<guillemotright>"
using assms ide_in_hom by (intro tensor_in_hom, auto)
show "\<guillemotleft>inv \<a>[\<I>, \<I>, a] : \<I> \<otimes> \<I> \<otimes> a \<rightarrow> (\<I> \<otimes> \<I>) \<otimes> a\<guillemotright>"
using assms by auto
qed
moreover have "ide (\<I> \<otimes> a)" using assms by simp
ultimately have "\<exists>f. ?P f"
using assms L.is_full by blast
moreover have "\<And>f f'. ?P f \<Longrightarrow> ?P f' \<Longrightarrow> f = f'"
proof -
fix f f'
assume f: "?P f" and f': "?P f'"
have "par f f'" using f f' by force
show "f = f'" using f f' L.is_faithful [of f f'] by force
qed
ultimately show "\<exists>!f. ?P f" by blast
hence 1: "?P \<l>[a]"
unfolding lunit_def using theI' [of ?P] by auto
show "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" using 1 by fast
show "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]" using 1 by fast
qed
lemma \<ll>_ide_simp:
assumes "ide a"
shows "\<ll> a = \<l>[a]"
using assms lunit_char comp_cod_arr ide_in_hom by (metis in_homE)
lemma lunit_in_hom [intro]:
assumes "ide a"
shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
using assms lunit_char(1) by blast
lemma arr_lunit [simp]:
assumes "ide a"
shows "arr \<l>[a]"
using assms lunit_in_hom by auto
lemma dom_lunit [simp]:
assumes "ide a"
shows "dom \<l>[a] = \<I> \<otimes> a"
using assms lunit_in_hom by auto
lemma cod_lunit [simp]:
assumes "ide a"
shows "cod \<l>[a] = a"
using assms lunit_in_hom by auto
text\<open>
As the right-hand side of the characteristic equation for @{term "\<I> \<otimes> \<l>[a]"}
is an isomorphism, and the equivalence functor \<open>L\<close> reflects isomorphisms,
it follows that @{term "\<l>[a]"} is an isomorphism.
\<close>
lemma iso_lunit [simp]:
assumes "ide a"
shows "iso \<l>[a]"
using assms lunit_char(2) \<iota>_is_iso ide_unity isos_compose iso_assoc iso_inv_iso
\<iota>_in_hom L.reflects_iso arr_lunit arr_tensor ideD(1) ide_is_iso lunit_in_hom
tensor_preserves_iso unity_def
by metis
text\<open>
To prove that an arrow @{term f} is equal to @{term "\<l>[a]"} we need only show
that it is parallel to @{term "\<l>[a]"} and that @{term "\<I> \<otimes> f"} satisfies the same
characteristic equation as @{term "\<I> \<otimes> \<l>[a]"} does.
\<close>
lemma lunit_eqI:
assumes "\<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" and "\<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
shows "f = \<l>[a]"
proof -
have "ide a" using assms(1) by auto
thus ?thesis
using assms lunit_char the1_equality by blast
qed
text\<open>
The next facts establish the corresponding results for the components of the
right unitor.
\<close>
lemma runit_char:
assumes "ide a"
shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" and "\<r>[a] \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
and "\<exists>!f. \<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright> \<and> f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
proof -
obtain F \<eta> \<epsilon> where R: "equivalence_of_categories C C F (\<lambda>f. f \<otimes> \<I>) \<eta> \<epsilon>"
using R.induces_equivalence \<iota>_in_hom by auto
- interpret R: equivalence_of_categories C C F "\<lambda>f. f \<otimes> \<I>" \<eta> \<epsilon>
+ interpret R: equivalence_of_categories C C F \<open>\<lambda>f. f \<otimes> \<I>\<close> \<eta> \<epsilon>
using R by auto
let ?P = "\<lambda>f. \<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright> \<and> f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
have "\<guillemotleft>(a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>] : (a \<otimes> \<I>) \<otimes> \<I> \<rightarrow> a \<otimes> \<I>\<guillemotright>"
using assms by fastforce
moreover have "ide (a \<otimes> \<I>)" using assms by simp
ultimately have "\<exists>f. ?P f"
using assms R.is_full [of a "a \<otimes> \<I>" "(a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"] by blast
moreover have "\<And>f f'. ?P f \<Longrightarrow> ?P f' \<Longrightarrow> f = f'"
proof -
fix f f'
assume f: "?P f" and f': "?P f'"
have "par f f'" using f f' by force
show "f = f'" using f f' R.is_faithful [of f f'] by force
qed
ultimately show "\<exists>!f. ?P f" by blast
hence 1: "?P \<r>[a]" unfolding runit_def using theI' [of ?P] by fast
show "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" using 1 by fast
show "\<r>[a] \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]" using 1 by fast
qed
lemma \<rho>_ide_simp:
assumes "ide a"
shows "\<rho> a = \<r>[a]"
using assms runit_char [of a] comp_cod_arr by auto
lemma runit_in_hom [intro]:
assumes "ide a"
shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
using assms runit_char(1) by blast
lemma arr_runit [simp]:
assumes "ide a"
shows "arr \<r>[a]"
using assms runit_in_hom by blast
lemma dom_runit [simp]:
assumes "ide a"
shows "dom \<r>[a] = a \<otimes> \<I>"
using assms runit_in_hom by blast
lemma cod_runit [simp]:
assumes "ide a"
shows "cod \<r>[a] = a"
using assms runit_in_hom by blast
lemma runit_eqI:
assumes "\<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" and "f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
shows "f = \<r>[a]"
proof -
have "ide a" using assms(1) by auto
thus ?thesis
using assms runit_char the1_equality by blast
qed
lemma iso_runit [simp]:
assumes "ide a"
shows "iso \<r>[a]"
using assms \<iota>_is_iso iso_inv_iso isos_compose ide_is_iso R.preserves_reflects_arr
arrI ide_unity iso_assoc runit_char tensor_preserves_iso R.reflects_iso
unity_def
by metis
text\<open>
We can now show that the components of the left and right unitors have the
naturality properties required of a natural transformation.
\<close>
lemma lunit_naturality:
assumes "arr f"
shows "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
proof -
interpret \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> ..
have par: "par (\<l>[cod f] \<cdot> (\<I> \<otimes> f)) (f \<cdot> \<l>[dom f])"
using assms by simp
moreover have "\<I> \<otimes> \<l>[cod f] \<cdot> (\<I> \<otimes> f) = \<I> \<otimes> f \<cdot> \<l>[dom f]"
proof -
have "\<I> \<otimes> \<l>[cod f] \<cdot> (\<I> \<otimes> f) = ((\<iota> \<otimes> cod f) \<cdot> ((\<I> \<otimes> \<I>) \<otimes> f)) \<cdot> inv \<a>[\<I>, \<I>, dom f]"
using assms interchange [of \<I> \<I> "\<I> \<otimes> f" "\<l>[cod f]"] lunit_char(2) \<iota>_in_hom unity_def
\<alpha>'.naturality [of "(\<I>, \<I>, f)"] comp_assoc
by auto
also have "... = ((\<I> \<otimes> f) \<cdot> (\<iota> \<otimes> dom f)) \<cdot> inv \<a>[\<I>, \<I>, dom f]"
using assms interchange comp_arr_dom comp_cod_arr \<iota>_in_hom by auto
also have "... = (\<I> \<otimes> f) \<cdot> (\<I> \<otimes> \<l>[dom f])"
using assms \<iota>_in_hom lunit_char(2) comp_assoc by auto
also have "... = \<I> \<otimes> f \<cdot> \<l>[dom f]"
using assms interchange by simp
finally show ?thesis by blast
qed
ultimately show "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
using L.is_faithful unity_def by metis
qed
lemma runit_naturality:
assumes "arr f"
shows "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
proof -
have "par (\<r>[cod f] \<cdot> (f \<otimes> \<I>)) (f \<cdot> \<r>[dom f])"
using assms by force
moreover have "\<r>[cod f] \<cdot> (f \<otimes> \<I>) \<otimes> \<I> = f \<cdot> \<r>[dom f] \<otimes> \<I>"
proof -
have "\<r>[cod f] \<cdot> (f \<otimes> \<I>) \<otimes> \<I> = (cod f \<otimes> \<iota>) \<cdot> \<a>[cod f, \<I>, \<I>] \<cdot> ((f \<otimes> \<I>) \<otimes> \<I>)"
using assms interchange [of \<I> \<I> "\<I> \<otimes> f" "\<r>[cod f]"] runit_char(2) \<iota>_in_hom unity_def
comp_assoc
by auto
also have "... = (cod f \<otimes> \<iota>) \<cdot> (f \<otimes> \<I> \<otimes> \<I>) \<cdot> \<a>[dom f, \<I>, \<I>]"
using assms \<alpha>.naturality [of "(f, \<I>, \<I>)"] by auto
also have "... = ((cod f \<otimes> \<iota>) \<cdot> (f \<otimes> \<I> \<otimes> \<I>)) \<cdot> \<a>[dom f, \<I>, \<I>]"
using comp_assoc by simp
also have "... = ((f \<otimes> \<I>) \<cdot> (dom f \<otimes> \<iota>)) \<cdot> \<a>[dom f, \<I>, \<I>]"
using assms \<iota>_in_hom interchange comp_arr_dom comp_cod_arr by auto
also have "... = (f \<otimes> \<I>) \<cdot> (\<r>[dom f] \<otimes> \<I>)"
using assms runit_char comp_assoc by auto
also have "... = f \<cdot> \<r>[dom f] \<otimes> \<I>"
using assms interchange by simp
finally show ?thesis by blast
qed
ultimately show "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
using R.is_faithful unity_def by metis
qed
end
text\<open>
The following locale is an extension of @{locale monoidal_category} that has the
unitors and their inverses, as well as the inverse to the associator,
conveniently pre-interpreted.
\<close>
locale extended_monoidal_category =
monoidal_category +
\<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> +
\<ll>: natural_isomorphism C C L map \<ll> +
\<ll>': inverse_transformation C C L map \<ll> +
\<rho>: natural_isomorphism C C R map \<rho> +
\<rho>': inverse_transformation C C R map \<rho>
text\<open>
Next we show that an interpretation of @{locale monoidal_category} extends to an
interpretation of @{locale extended_monoidal_category} and we arrange for the former
locale to inherit from the latter.
\<close>
context monoidal_category
begin
interpretation \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> ..
interpretation \<ll>: natural_transformation C C L map \<ll>
proof -
- interpret \<ll>: transformation_by_components C C L map "\<lambda>a. \<l>[a]"
+ interpret \<ll>: transformation_by_components C C L map \<open>\<lambda>a. \<l>[a]\<close>
using lunit_in_hom lunit_naturality unity_def \<iota>_in_hom' L.is_extensional
by (unfold_locales, auto)
have "\<ll>.map = \<ll>"
using \<ll>.is_natural_1 \<ll>.is_extensional by auto
thus "natural_transformation C C L map \<ll>"
using \<ll>.natural_transformation_axioms by auto
qed
interpretation \<ll>: natural_isomorphism C C L map \<ll>
apply unfold_locales
using iso_lunit \<ll>_ide_simp by simp
interpretation \<rho>: natural_transformation C C R map \<rho>
proof -
- interpret \<rho>: transformation_by_components C C R map "\<lambda>a. \<r>[a]"
+ interpret \<rho>: transformation_by_components C C R map \<open>\<lambda>a. \<r>[a]\<close>
using runit_naturality unity_def \<iota>_in_hom' R.is_extensional
by (unfold_locales, auto)
have "\<rho>.map = \<rho>"
using \<rho>.is_natural_1 \<rho>.is_extensional by auto
thus "natural_transformation C C R map \<rho>"
using \<rho>.natural_transformation_axioms by auto
qed
interpretation \<rho>: natural_isomorphism C C R map \<rho>
apply unfold_locales
using \<rho>_ide_simp by simp
lemma induces_extended_monoidal_category:
shows "extended_monoidal_category C T \<alpha> \<iota>" ..
end
sublocale monoidal_category \<subseteq> extended_monoidal_category
using induces_extended_monoidal_category by auto
context monoidal_category
begin
abbreviation \<alpha>'
where "\<alpha>' \<equiv> \<alpha>'.map"
lemma natural_isomorphism_\<alpha>':
shows "natural_isomorphism CCC.comp C T.ToCT T.ToTC \<alpha>'" ..
abbreviation assoc' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
where "\<a>\<^sup>-\<^sup>1[a, b, c] \<equiv> inv \<a>[a, b, c]"
lemma \<alpha>'_ide_simp:
assumes "ide a" and "ide b" and "ide c"
shows "\<alpha>' (a, b, c) = \<a>\<^sup>-\<^sup>1[a, b, c]"
using assms \<alpha>'.inverts_components inverse_unique by force
lemma \<alpha>'_simp:
assumes "arr f" and "arr g" and "arr h"
shows "\<alpha>' (f, g, h) = ((f \<otimes> g) \<otimes> h) \<cdot> \<a>\<^sup>-\<^sup>1[dom f, dom g, dom h]"
using assms T.ToTC_simp \<alpha>'.is_natural_1 \<alpha>'_ide_simp by force
lemma assoc_inv:
assumes "ide a" and "ide b" and "ide c"
shows "inverse_arrows \<a>[a, b, c] \<a>\<^sup>-\<^sup>1[a, b, c]"
using assms inv_is_inverse by simp
lemma assoc'_in_hom [intro]:
assumes "ide a" and "ide b" and "ide c"
shows "\<guillemotleft>\<a>\<^sup>-\<^sup>1[a, b, c] : a \<otimes> b \<otimes> c \<rightarrow> (a \<otimes> b) \<otimes> c\<guillemotright>"
using assms by auto
lemma arr_assoc' [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "arr \<a>\<^sup>-\<^sup>1[a, b, c]"
using assms by simp
lemma dom_assoc' [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "dom \<a>\<^sup>-\<^sup>1[a, b, c] = a \<otimes> b \<otimes> c"
using assms by simp
lemma cod_assoc' [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "cod \<a>\<^sup>-\<^sup>1[a, b, c] = (a \<otimes> b) \<otimes> c"
using assms by simp
lemma comp_assoc_assoc' [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "\<a>[a, b, c] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, c] = a \<otimes> (b \<otimes> c)"
and "\<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
using assms assoc_inv comp_arr_inv comp_inv_arr by auto
lemma assoc'_naturality:
assumes "arr f0" and "arr f1" and "arr f2"
shows "((f0 \<otimes> f1) \<otimes> f2) \<cdot> \<a>\<^sup>-\<^sup>1[dom f0, dom f1, dom f2] =
\<a>\<^sup>-\<^sup>1[cod f0, cod f1, cod f2] \<cdot> (f0 \<otimes> f1 \<otimes> f2)"
using assms \<alpha>'.naturality by auto
abbreviation \<ll>'
where "\<ll>' \<equiv> \<ll>'.map"
abbreviation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
where "\<l>\<^sup>-\<^sup>1[a] \<equiv> inv \<l>[a]"
lemma \<ll>'_ide_simp:
assumes "ide a"
shows "\<ll>'.map a = \<l>\<^sup>-\<^sup>1[a]"
using assms \<ll>'.inverts_components \<ll>_ide_simp inverse_unique by force
lemma lunit_inv:
assumes "ide a"
shows "inverse_arrows \<l>[a] \<l>\<^sup>-\<^sup>1[a]"
using assms inv_is_inverse by simp
lemma lunit'_in_hom [intro]:
assumes "ide a"
shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[a] : a \<rightarrow> \<I> \<otimes> a\<guillemotright>"
using assms by auto
lemma comp_lunit_lunit' [simp]:
assumes "ide a"
shows "\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a] = a"
and "\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<I> \<otimes> a"
proof -
show "\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a] = a"
using assms comp_arr_inv lunit_inv by fastforce
show "\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<I> \<otimes> a"
using assms comp_arr_inv lunit_inv by fastforce
qed
lemma lunit'_naturality:
assumes "arr f"
shows "(\<I> \<otimes> f) \<cdot> \<l>\<^sup>-\<^sup>1[dom f] = \<l>\<^sup>-\<^sup>1[cod f] \<cdot> f"
using assms \<ll>'.naturality \<ll>'_ide_simp by simp
abbreviation \<rho>'
where "\<rho>' \<equiv> \<rho>'.map"
abbreviation runit' ("\<r>\<^sup>-\<^sup>1[_]")
where "\<r>\<^sup>-\<^sup>1[a] \<equiv> inv \<r>[a]"
lemma \<rho>'_ide_simp:
assumes "ide a"
shows "\<rho>'.map a = \<r>\<^sup>-\<^sup>1[a]"
using assms \<rho>'.inverts_components \<rho>_ide_simp inverse_unique by auto
lemma runit_inv:
assumes "ide a"
shows "inverse_arrows \<r>[a] \<r>\<^sup>-\<^sup>1[a]"
using assms inv_is_inverse by simp
lemma runit'_in_hom [intro]:
assumes "ide a"
shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[a] : a \<rightarrow> a \<otimes> \<I>\<guillemotright>"
using assms by auto
lemma comp_runit_runit' [simp]:
assumes "ide a"
shows "\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a] = a"
and "\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = a \<otimes> \<I>"
proof -
show "\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a] = a"
using assms runit_inv by fastforce
show "\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = a \<otimes> \<I>"
using assms runit_inv by fastforce
qed
lemma runit'_naturality:
assumes "arr f"
shows "(f \<otimes> \<I>) \<cdot> \<r>\<^sup>-\<^sup>1[dom f] = \<r>\<^sup>-\<^sup>1[cod f] \<cdot> f"
using assms \<rho>'.naturality \<rho>'_ide_simp by simp
lemma lunit_commutes_with_L:
assumes "ide a"
shows "\<l>[\<I> \<otimes> a] = \<I> \<otimes> \<l>[a]"
using assms lunit_naturality lunit_in_hom iso_lunit iso_is_section
section_is_mono monoE L.preserves_ide arrI cod_lunit dom_lunit seqI
unity_def
by metis
lemma runit_commutes_with_R:
assumes "ide a"
shows "\<r>[a \<otimes> \<I>] = \<r>[a] \<otimes> \<I>"
using assms runit_naturality runit_in_hom iso_runit iso_is_section
section_is_mono monoE R.preserves_ide arrI cod_runit dom_runit seqI
unity_def
by metis
text\<open>
The components of the left and right unitors are related via a ``triangle''
diagram that also involves the associator.
The proof follows \cite{Etingof15}, Proposition 2.2.3.
\<close>
lemma triangle:
assumes "ide a" and "ide b"
shows "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
proof -
text\<open>
We show that the lower left triangle in the following diagram commutes.
\<close>
text\<open>
$$\xymatrix{
{@{term "((a \<otimes> \<I>) \<otimes> \<I>) \<otimes> b"}}
\ar[rrrr]^{\scriptsize @{term "\<a>[a, \<I>, \<I>] \<otimes> b"}}
\ar[ddd]_{\scriptsize @{term "\<a>[a \<otimes> \<I>, \<I>, b]"}}
\ar[drr]_{\scriptsize @{term "(\<r>[a] \<otimes> \<I>) \<otimes> b"}}
&& &&
{@{term "(a \<otimes> (\<I> \<otimes> \<I>)) \<otimes> b"}}
\ar[dll]^{\scriptsize @{term "(a \<otimes> \<iota>) \<otimes> b"}}
\ar[ddd]^{\scriptsize @{term "\<a>[a, \<I> \<otimes> \<I>, b]"}} \\
&& {@{term "(a \<otimes> \<I>) \<otimes> b"}}
\ar[d]^{\scriptsize @{term "\<a>[a, \<I>, b]"}} \\
&& {@{term "a \<otimes> \<I> \<otimes> b"}} \\
{@{term "(a \<otimes> \<I>) \<otimes> \<I> \<otimes> b"}}
\ar[urr]^{\scriptsize @{term "\<r>[a] \<otimes> \<I> \<otimes> b"}}
\ar[drr]_{\scriptsize @{term "\<a>[a, \<I>, \<I> \<otimes> b]"}}
&& &&
{@{term "a \<otimes> (\<I> \<otimes> \<I>) \<otimes> b"}}
\ar[ull]_{\scriptsize @{term "a \<otimes> \<iota> \<otimes> b"}}
\ar[dll]^{\scriptsize @{term "a \<otimes> \<a>[\<I>, \<I>, b]"}} \\
&& {@{term "a \<otimes> \<I> \<otimes> \<I> \<otimes> b"}}
\ar[uu]^{\scriptsize @{term "a \<otimes> \<l>[\<I> \<otimes> b]"}}
}$$
\<close>
have *: "(a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] = \<r>[a] \<otimes> \<I> \<otimes> b"
proof -
have 1: "((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b]
= (\<r>[a] \<otimes> \<I> \<otimes> b) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b]"
proof -
have "((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b] =
((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> (a \<otimes> \<a>[\<I>, \<I>, b])) \<cdot> \<a>[a, \<I> \<otimes> \<I>, b] \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
using assms pentagon comp_assoc by auto
also have "... = (a \<otimes> ((\<I> \<otimes> \<l>[b]) \<cdot> \<a>[\<I>, \<I>, b])) \<cdot> \<a>[a, \<I> \<otimes> \<I>, b] \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
using assms interchange lunit_commutes_with_L by simp
also have "... = ((a \<otimes> (\<iota> \<otimes> b)) \<cdot> \<a>[a, \<I> \<otimes> \<I>, b]) \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
using assms lunit_char \<iota>_in_hom comp_arr_dom comp_assoc by auto
also have "... = (\<a>[a, \<I>, b] \<cdot> ((a \<otimes> \<iota>) \<otimes> b)) \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
using assms \<iota>_in_hom assoc_naturality [of a \<iota> b] by fastforce
also have "... = \<a>[a, \<I>, b] \<cdot> ((\<r>[a] \<otimes> \<I>) \<otimes> b)"
using assms \<iota>_in_hom interchange runit_char(2) comp_assoc by auto
also have "... = (\<r>[a] \<otimes> \<I> \<otimes> b) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b]"
using assms assoc_naturality [of "\<r>[a]" \<I> b] by simp
finally show ?thesis by blast
qed
show ?thesis
proof -
have "epi \<a>[a \<otimes> \<I>, \<I>, b]"
using assms iso_assoc iso_is_retraction retraction_is_epi by simp
thus ?thesis
using 1 assms epiE [of "\<a>[a \<otimes> \<I>, \<I>, b]" "(a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]"]
by fastforce
qed
qed
text\<open>
In \cite{Etingof15} it merely states that the preceding result suffices
``because any object of \<open>C\<close> is isomorphic to one of the form @{term "\<I> \<otimes> b"}.''
However, it seems a little bit more involved than that to formally transport the
equation \<open>(*)\<close> along the isomorphism @{term "\<l>[b]"} from @{term "\<I> \<otimes> b"}
to @{term b}.
\<close>
have "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = ((a \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b])) \<cdot>
(a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
proof -
have "\<a>[a, \<I>, b] = (a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
proof -
have "(a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])
= ((a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b])) \<cdot> \<a>[a, \<I>, b]"
using assms assoc_naturality [of a \<I> "\<l>\<^sup>-\<^sup>1[b]"] comp_assoc by simp
also have "... = \<a>[a, \<I>, b]"
using assms inv_is_inverse interchange comp_cod_arr by simp
finally show ?thesis by auto
qed
moreover have "a \<otimes> \<l>[b] = (a \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b])"
using assms lunit_commutes_with_L comp_arr_dom interchange by auto
ultimately show ?thesis by argo
qed
also have "... = (a \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> ((a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>[b])) \<cdot>
\<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
using assms comp_assoc by auto
also have "... = (a \<otimes> \<l>[b]) \<cdot> ((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]) \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
using assms interchange comp_cod_arr comp_assoc by auto
also have "... = \<r>[a] \<otimes> b"
using assms * interchange runit_char(1) comp_arr_dom comp_cod_arr by auto
finally show ?thesis by blast
qed
lemma lunit_tensor_gen:
assumes "ide a" and "ide b" and "ide c"
shows "(a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c]) = a \<otimes> \<l>[b] \<otimes> c"
proof -
text\<open>
We show that the lower right triangle in the following diagram commutes.
\<close>
text\<open>
$$\xymatrix{
{@{term "((a \<otimes> \<I>) \<otimes> b) \<otimes> c"}}
\ar[rrrr]^{\scriptsize @{term "\<a>[a, \<I>, b] \<otimes> c"}}
\ar[ddd]_{\scriptsize @{term "\<a>[a \<otimes> \<I>, b, c]"}}
\ar[drr]_{\scriptsize @{term "\<r>[a] \<otimes> b \<otimes> c"}}
&& &&
{@{term "(a \<otimes> (\<I> \<otimes> b)) \<otimes> c"}}
\ar[dll]^{\scriptsize @{term "(a \<otimes> \<l>[b]) \<otimes> c"}}
\ar[ddd]^{\scriptsize @{term "\<a>[a, \<I> \<otimes> b, c]"}} \\
&& {@{term "(a \<otimes> b) \<otimes> c"}}
\ar[d]^{\scriptsize @{term "\<a>[a, b, c]"}} \\
&& {@{term "a \<otimes> b \<otimes> c"}} \\
{@{term "(a \<otimes> \<I>) \<otimes> b \<otimes> c"}}
\ar[urr]^{\scriptsize @{term "\<r>[a] \<otimes> b \<otimes> c"}}
\ar[drr]_{\scriptsize @{term "\<a>[a, \<I>, b \<otimes> c]"}}
&& &&
{@{term "a \<otimes> (\<I> \<otimes> b) \<otimes> c"}}
\ar[ull]_{\scriptsize @{term "a \<otimes> \<l>[b] \<otimes> c"}}
\ar[dll]^{\scriptsize @{term "a \<otimes> \<a>[\<I>, b, c]"}} \\
&& {@{term "a \<otimes> \<I> \<otimes> b \<otimes> c"}}
\ar[uu]^{\scriptsize @{term "a \<otimes> \<l>[b \<otimes> c]"}}
}$$
\<close>
have "((a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])) \<cdot> (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)) =
((a \<otimes> \<l>[b \<otimes> c]) \<cdot> \<a>[a, \<I>, b \<otimes> c]) \<cdot> \<a>[a \<otimes> \<I>, b, c]"
using assms pentagon comp_assoc by simp
also have "... = (\<r>[a] \<otimes> (b \<otimes> c)) \<cdot> \<a>[a \<otimes> \<I>, b, c]"
using assms triangle by auto
also have "... = \<a>[a, b, c] \<cdot> ((\<r>[a] \<otimes> b) \<otimes> c)"
using assms assoc_naturality [of "\<r>[a]" b c] by auto
also have "... = (\<a>[a, b, c] \<cdot> ((a \<otimes> \<l>[b]) \<otimes> c)) \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"
using assms triangle interchange comp_assoc by auto
also have "... = (a \<otimes> (\<l>[b] \<otimes> c)) \<cdot> (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
using assms assoc_naturality [of a "\<l>[b]" c] comp_assoc by auto
finally have 1: "((a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])) \<cdot> \<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)
= (a \<otimes> (\<l>[b] \<otimes> c)) \<cdot> \<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"
by blast
text\<open>
The result follows by cancelling the isomorphism
@{term "\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"}
\<close>
have 2: "iso (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
using assms isos_compose by simp
moreover have
"seq ((a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])) (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
using assms by auto
moreover have "seq (a \<otimes> (\<l>[b] \<otimes> c)) (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
using assms by auto
ultimately show ?thesis
using 1 2 assms iso_is_retraction retraction_is_epi
epiE [of "\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"
"(a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])" "a \<otimes> \<l>[b] \<otimes> c"]
by auto
qed
text\<open>
The following result is quoted without proof as Theorem 7 of \cite{Kelly64} where it is
attributed to MacLane \cite{MacLane63}. It also appears as \cite{MacLane71},
Exercise 1, page 161. I did not succeed within a few hours to construct a proof following
MacLane's hint. The proof below is based on \cite{Etingof15}, Proposition 2.2.4.
\<close>
lemma lunit_tensor':
assumes "ide a" and "ide b"
shows "\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b] = \<l>[a] \<otimes> b"
proof -
have "\<I> \<otimes> (\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b]) = \<I> \<otimes> (\<l>[a] \<otimes> b)"
using assms interchange [of \<I> \<I>] lunit_tensor_gen by simp
moreover have "par (\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b]) (\<l>[a] \<otimes> b)"
using assms by simp
ultimately show ?thesis
using assms L.is_faithful [of "\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b]" "\<l>[a] \<otimes> b"] unity_def by simp
qed
lemma lunit_tensor:
assumes "ide a" and "ide b"
shows "\<l>[a \<otimes> b] = (\<l>[a] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, a, b]"
using assms lunit_tensor' invert_side_of_triangle by simp
text\<open>
We next show the corresponding result for the right unitor.
\<close>
lemma runit_tensor_gen:
assumes "ide a" and "ide b" and "ide c"
shows "\<r>[a \<otimes> b] \<otimes> c = ((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> (\<a>[a, b, \<I>] \<otimes> c)"
proof -
text\<open>
We show that the upper right triangle in the following diagram commutes.
\<close>
text\<open>
$$\xymatrix{
&& {@{term "((a \<otimes> b) \<otimes> \<I>) \<otimes> c"}}
\ar[dll]_{\scriptsize @{term "\<a>[a \<otimes> b, \<I>, c]"}}
\ar[dd]^{\scriptsize @{term "\<r>[a \<otimes> b] \<otimes> c"}}
\ar[drr]^{\scriptsize @{term "\<a>[a, b, \<I>] \<otimes> c"}} \\
{@{term "(a \<otimes> b) \<otimes> \<I> \<otimes> c"}}
\ar[ddd]_{\scriptsize @{term "\<a>[a, b, \<I> \<otimes> c]"}}
\ar[drr]_{\scriptsize @{term "(a \<otimes> b) \<otimes> \<l>[c]"}}
&& &&
{@{term "(a \<otimes> b \<otimes> \<I>) \<otimes> c"}}
\ar[dll]^{\scriptsize @{term "(a \<otimes> \<r>[b]) \<otimes> c"}}
\ar[ddd]^{\scriptsize @{term "\<a>[a, b \<otimes> \<I>, c]"}} \\
&& {@{term "(a \<otimes> b) \<otimes> c"}}
\ar[d]^{\scriptsize @{term "\<a>[a, b, c]"}} \\
&& {@{term "a \<otimes> b \<otimes> c"}} \\
{@{term "a \<otimes> b \<otimes> \<I> \<otimes> c"}}
\ar[urr]^{\scriptsize @{term "a \<otimes> b \<otimes> \<l>[c]"}}
&& &&
{@{term "a \<otimes> (b \<otimes> \<I>) \<otimes> c"}}
\ar[llll]^{\scriptsize @{term "a \<otimes> \<a>[b, \<I>, c]"}}
\ar[ull]_{\scriptsize @{term "a \<otimes> \<r>[b] \<otimes> c"}}
}$$
\<close>
have "\<r>[a \<otimes> b] \<otimes> c = ((a \<otimes> b) \<otimes> \<l>[c]) \<cdot> \<a>[a \<otimes> b, \<I>, c]"
using assms triangle by simp
also have "... = (\<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> (a \<otimes> b \<otimes> \<l>[c]) \<cdot> \<a>[a, b, \<I> \<otimes> c]) \<cdot> \<a>[a \<otimes> b, \<I>, c]"
using assms assoc_naturality [of a b "\<l>[c]"] comp_arr_dom comp_cod_arr
invert_side_of_triangle(1)
by force
also have "... = \<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> (a \<otimes> b \<otimes> \<l>[c]) \<cdot> \<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
using comp_assoc by force
also have "... = \<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> ((a \<otimes> (\<r>[b] \<otimes> c)) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, \<I>, c])) \<cdot>
\<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
using assms triangle [of b c] interchange invert_side_of_triangle(2) by force
also have "... = (((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> \<I>, c]) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, \<I>, c]) \<cdot>
\<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
using assms assoc'_naturality [of a "\<r>[b]" c] comp_assoc by force
also have "... = ((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> \<I>, c] \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, \<I>, c]) \<cdot>
\<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
using comp_assoc by simp
also have "... = ((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> (\<a>[a, b, \<I>] \<otimes> c)"
using assms pentagon invert_side_of_triangle(1)
invert_side_of_triangle(1)
[of "\<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]" "a \<otimes> \<a>[b, \<I>, c]"
"\<a>[a, b \<otimes> \<I>, c] \<cdot> (\<a>[a, b, \<I>] \<otimes> c)"]
by force
finally show ?thesis by blast
qed
lemma runit_tensor:
assumes "ide a" and "ide b"
shows "\<r>[a \<otimes> b] = (a \<otimes> \<r>[b]) \<cdot> \<a>[a, b, \<I>]"
proof -
have "((a \<otimes> \<r>[b]) \<cdot> \<a>[a, b, \<I>]) \<otimes> \<I> = \<r>[a \<otimes> b] \<otimes> \<I>"
using assms interchange [of \<I> \<I>] runit_tensor_gen by simp
moreover have "par ((a \<otimes> \<r>[b]) \<cdot> \<a>[a, b, \<I>]) \<r>[a \<otimes> b]"
using assms by simp
ultimately show ?thesis
using assms R.is_faithful [of "(a \<otimes> \<r>[b]) \<cdot> (\<a>[a, b, \<I>])" "\<r>[a \<otimes> b]"] unity_def
by argo
qed
lemma runit_tensor':
assumes "ide a" and "ide b"
shows "\<r>[a \<otimes> b] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, \<I>] = a \<otimes> \<r>[b]"
using assms runit_tensor invert_side_of_triangle by force
text \<open>
Sometimes inverted forms of the triangle and pentagon axioms are useful.
\<close>
lemma triangle':
assumes "ide a" and "ide b"
shows "(a \<otimes> \<l>[b]) = (\<r>[a] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[a, \<I>, b]"
proof -
have "(\<r>[a] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[a, \<I>, b] = ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b]) \<cdot> \<a>\<^sup>-\<^sup>1[a, \<I>, b]"
using assms triangle by auto
also have "... = (a \<otimes> \<l>[b])"
using assms comp_arr_dom comp_assoc by auto
finally show ?thesis by auto
qed
lemma pentagon':
assumes "ide a" and "ide b" and "ide c" and "ide d"
shows "((\<a>\<^sup>-\<^sup>1[a, b, c] \<otimes> d) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> c, d]) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, c, d])
= \<a>\<^sup>-\<^sup>1[a \<otimes> b, c, d] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, c \<otimes> d]"
proof -
have "((\<a>\<^sup>-\<^sup>1[a, b, c] \<otimes> d) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> c, d]) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, c, d])
= inv ((a \<otimes> \<a>[b, c, d]) \<cdot> (\<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)))"
using assms isos_compose inv_comp by simp
also have "... = inv (\<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d])"
using assms pentagon by auto
also have "... = \<a>\<^sup>-\<^sup>1[a \<otimes> b, c, d] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, c \<otimes> d]"
using assms inv_comp by simp
finally show ?thesis by auto
qed
text\<open>
The following non-obvious fact is Corollary 2.2.5 from \cite{Etingof15}.
The statement that @{term "\<l>[\<I>] = \<r>[\<I>]"} is Theorem 6 from \cite{Kelly64}.
MacLane \cite{MacLane71} does not show this, but assumes it as an axiom.
\<close>
lemma unitor_coincidence:
shows "\<l>[\<I>] = \<iota>" and "\<r>[\<I>] = \<iota>"
proof -
have "\<l>[\<I>] \<otimes> \<I> = (\<I> \<otimes> \<l>[\<I>]) \<cdot> \<a>[\<I>, \<I>, \<I>]"
using lunit_tensor' [of \<I> \<I>] lunit_commutes_with_L [of \<I>] by simp
moreover have "\<r>[\<I>] \<otimes> \<I> = (\<I> \<otimes> \<l>[\<I>]) \<cdot> \<a>[\<I>, \<I>, \<I>]"
using triangle [of \<I> \<I>] by simp
moreover have "\<iota> \<otimes> \<I> = (\<I> \<otimes> \<l>[\<I>]) \<cdot> \<a>[\<I>, \<I>, \<I>]"
using lunit_char comp_arr_dom \<iota>_in_hom comp_assoc by auto
ultimately have "\<l>[\<I>] \<otimes> \<I> = \<iota> \<otimes> \<I> \<and> \<r>[\<I>] \<otimes> \<I> = \<iota> \<otimes> \<I>"
by argo
moreover have "par \<l>[\<I>] \<iota> \<and> par \<r>[\<I>] \<iota>"
using \<iota>_in_hom by force
ultimately have 1: "\<l>[\<I>] = \<iota> \<and> \<r>[\<I>] = \<iota>"
using R.is_faithful unity_def by metis
show "\<l>[\<I>] = \<iota>" using 1 by auto
show "\<r>[\<I>] = \<iota>" using 1 by auto
qed
lemma \<iota>_triangle:
shows "\<iota> \<otimes> \<I> = (\<I> \<otimes> \<iota>) \<cdot> \<a>[\<I>, \<I>, \<I>]"
and "(\<iota> \<otimes> \<I>) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>] = \<I> \<otimes> \<iota>"
using triangle [of \<I> \<I>] triangle' [of \<I> \<I>] unitor_coincidence by auto
text\<open>
The only isomorphism that commutes with @{term \<iota>} is @{term \<I>}.
\<close>
lemma iso_commuting_with_\<iota>_equals_\<I>:
assumes "\<guillemotleft>f : \<I> \<rightarrow> \<I>\<guillemotright>" and "iso f" and "f \<cdot> \<iota> = \<iota> \<cdot> (f \<otimes> f)"
shows "f = \<I>"
proof -
have 1: "f \<otimes> f = f \<otimes> \<I>"
proof -
have "f \<otimes> f = (inv \<iota> \<cdot> \<iota>) \<cdot> (f \<otimes> f)"
using assms \<iota>_in_hom \<iota>_is_iso inv_is_inverse comp_inv_arr comp_cod_arr [of "f \<otimes> f"]
by force
also have "... = (inv \<iota> \<cdot> f) \<cdot> \<iota>"
using assms \<iota>_is_iso inv_is_inverse comp_assoc by force
also have "... = ((f \<otimes> \<I>) \<cdot> inv \<iota>) \<cdot> \<iota>"
using assms unitor_coincidence runit'_naturality [of f] by auto
also have "... = (f \<otimes> \<I>) \<cdot> (inv \<iota> \<cdot> \<iota>)"
using comp_assoc by force
also have "... = f \<otimes> \<I>"
using assms \<iota>_in_hom \<iota>_is_iso inv_is_inverse comp_inv_arr
comp_arr_dom [of "f \<otimes> \<I>" "\<I> \<otimes> \<I>"]
by force
finally show ?thesis by blast
qed
moreover have "(f \<otimes> f) \<cdot> (inv f \<otimes> \<I>) = \<I> \<otimes> f \<and> (f \<otimes> \<I>) \<cdot> (inv f \<otimes> \<I>) = \<I> \<otimes> \<I>"
using assms interchange comp_arr_inv inv_is_inverse comp_arr_dom by auto
ultimately have "\<I> \<otimes> f = \<I> \<otimes> \<I>" by metis
moreover have "par f \<I>"
using assms by auto
ultimately have "f = \<I>"
using L.is_faithful unity_def by metis
thus ?thesis using 1 by blast
qed
end
text\<open>
We now show that the unit \<open>\<iota>\<close> of a monoidal category is unique up to a unique
isomorphism (Proposition 2.2.6 of \cite{Etingof15}).
\<close>
locale monoidal_category_with_alternate_unit =
monoidal_category C T \<alpha> \<iota> +
C\<^sub>1: monoidal_category C T \<alpha> \<iota>\<^sub>1
for C :: "'a comp" (infixr "\<cdot>" 55)
and T :: "'a * 'a \<Rightarrow> 'a"
and \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a"
and \<iota> :: 'a
and \<iota>\<^sub>1 :: 'a
begin
no_notation C\<^sub>1.tensor (infixr "\<otimes>" 53)
no_notation C\<^sub>1.unity ("\<I>")
no_notation C\<^sub>1.lunit ("\<l>[_]")
no_notation C\<^sub>1.runit ("\<r>[_]")
no_notation C\<^sub>1.assoc ("\<a>[_, _, _]")
no_notation C\<^sub>1.assoc' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
notation C\<^sub>1.tensor (infixr "\<otimes>\<^sub>1" 53)
notation C\<^sub>1.unity ("\<I>\<^sub>1")
notation C\<^sub>1.lunit ("\<l>\<^sub>1[_]")
notation C\<^sub>1.runit ("\<r>\<^sub>1[_]")
notation C\<^sub>1.assoc ("\<a>\<^sub>1[_, _, _]")
notation C\<^sub>1.assoc' ("\<a>\<^sub>1\<^sup>-\<^sup>1[_, _, _]")
definition i
where "i \<equiv> \<l>[\<I>\<^sub>1] \<cdot> inv \<r>\<^sub>1[\<I>]"
lemma iso_i:
shows "\<guillemotleft>i : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright>" and "iso i"
proof -
show "\<guillemotleft>i : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright>"
using C\<^sub>1.iso_runit inv_in_hom i_def by auto
show "iso i"
using iso_lunit C\<^sub>1.iso_runit iso_inv_iso isos_compose i_def by simp
qed
text\<open>
The following is Exercise 2.2.7 of \cite{Etingof15}.
\<close>
lemma i_maps_\<iota>_to_\<iota>\<^sub>1:
shows "i \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (i \<otimes> i)"
proof -
have 1: "inv \<r>\<^sub>1[\<I>] \<cdot> \<iota> = (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]) \<cdot> (inv \<r>\<^sub>1[\<I>] \<otimes> inv \<r>\<^sub>1[\<I>])"
proof -
have "\<iota> \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]) = \<r>\<^sub>1[\<I>] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])"
proof -
text \<open>
$$\xymatrix{
&& {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<I> \<otimes> \<I>\<^sub>1"}}
\ar[dddll]_{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]"}}
\ar[dd]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1"}}
\ar[dddrr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]"}}
\\
\\
&& {@{term[source=true] "\<I> \<otimes> \<I> \<otimes> \<I>\<^sub>1"}}
\ar[dll]^{\scriptsize @{term[source=true] "\<I> \<otimes> \<r>\<^sub>1[\<I>]"}}
\ar[drr]_{\scriptsize @{term[source=true] "\<I> \<otimes> \<l>[\<I>\<^sub>1]"}}
\ar[dd]^{\scriptsize @{term[source=true] "\<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1]"}}
\\
{@{term[source=true] "\<I> \<otimes> \<I>"}}
\ar[dddrr]_{\scriptsize @{term[source=true] "\<iota>"}}
&&
&&
{@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1"}}
\ar[dddll]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>]"}}
\\
&& {@{ term[source=true] "(\<I> \<otimes> \<I>) \<otimes> \<I>\<^sub>1"}}
\ar[ull]_{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I> \<otimes> \<I>]"}}
\ar[urr]^{\scriptsize @{term[source=true] "\<iota> \<otimes> \<I>"}}
\\
\\
&& {@{term[source=true] "\<I>"}}
}$$
\<close>
have "\<iota> \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]) = \<iota> \<cdot> (\<I> \<otimes> \<r>\<^sub>1[\<I>]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
using interchange comp_cod_arr comp_arr_dom by simp
also have "... = \<iota> \<cdot> (\<r>\<^sub>1[\<I> \<otimes> \<I>] \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
using C\<^sub>1.runit_tensor' by auto
also have "... = (\<iota> \<cdot> \<r>\<^sub>1[\<I> \<otimes> \<I>]) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
using comp_assoc by auto
also have "... = (\<r>\<^sub>1[\<I>] \<cdot> (\<iota> \<otimes> \<I>\<^sub>1)) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
using C\<^sub>1.runit_naturality [of \<iota>] \<iota>_in_hom by fastforce
also have "... = \<r>\<^sub>1[\<I>] \<cdot> ((\<iota> \<otimes> \<I>\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
using comp_assoc by auto
also have "... = \<r>\<^sub>1[\<I>] \<cdot> (\<I> \<otimes> \<l>[\<I>\<^sub>1]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
using lunit_tensor lunit_commutes_with_L unitor_coincidence by simp
also have "... = \<r>\<^sub>1[\<I>] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])"
using interchange comp_arr_dom comp_cod_arr by simp
finally show ?thesis by blast
qed
moreover have "seq \<iota> (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]) \<and> seq \<r>\<^sub>1[\<I>] (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])"
using \<iota>_in_hom by fastforce
moreover have "iso \<r>\<^sub>1[\<I>] \<and> iso (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>])"
using C\<^sub>1.iso_runit tensor_preserves_iso by force
ultimately show ?thesis
using invert_opposite_sides_of_square inv_tensor by metis
qed
have 2: "\<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]) = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1])"
proof -
text \<open>
$$\xymatrix{
&& {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> (\<I> \<otimes> \<I>\<^sub>1)"}}
\ar[dddll]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1]"}}
\ar[dd]^{\scriptsize @{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1]"}}
\ar[dddrr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]"}}
\\
\\
&& {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<I>\<^sub>1"}}
\ar[dll]^{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1] \<otimes> \<I>\<^sub>1"}}
\ar[drr]_{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<I>\<^sub>1"}}
\ar[dd]^{\scriptsize @{term[source=true] "\<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1]"}}
\\
{@{term[source=true] "\<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
\ar[dddrr]_{\scriptsize @{term[source=true] "\<iota>\<^sub>1"}}
&&
&&
{@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1"}}
\ar[dddll]^{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1]"}}
\\
&& {@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
\ar[ull]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1 \<otimes> \<I>\<^sub>1]"}}
\ar[urr]^{\scriptsize @{term[source=true] "\<I> \<otimes> \<iota>\<^sub>1"}}
\\
\\
&& {@{term[source=true] "\<I>\<^sub>1"}}
}$$
\<close>
have "\<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]) = \<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I>\<^sub>1) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
using interchange comp_arr_dom comp_cod_arr by force
also have "... = \<l>[\<I>\<^sub>1] \<cdot> ((\<I> \<otimes> \<iota>\<^sub>1) \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1]) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
using C\<^sub>1.runit_tensor C\<^sub>1.unitor_coincidence C\<^sub>1.runit_commutes_with_R by simp
also have "... = (\<l>[\<I>\<^sub>1] \<cdot> (\<I> \<otimes> \<iota>\<^sub>1)) \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1] \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
using comp_assoc by fastforce
also have "... = (\<iota>\<^sub>1 \<cdot> \<l>[\<I>\<^sub>1 \<otimes> \<I>\<^sub>1]) \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1] \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
using lunit_naturality [of \<iota>\<^sub>1] C\<^sub>1.\<iota>_in_hom lunit_commutes_with_L by fastforce
also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1 \<otimes> \<I>\<^sub>1] \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1]) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
using comp_assoc by force
also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<I>\<^sub>1) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
using lunit_tensor' by auto
also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1])"
using interchange comp_arr_dom comp_cod_arr by simp
finally show ?thesis by blast
qed
show ?thesis
proof -
text \<open>
$$\xymatrix{
{@{term[source=true] "\<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
\ar[dd]_{\scriptsize @{term "\<iota>\<^sub>1"}}
&&
{@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> (\<I> \<otimes> \<I>\<^sub>1)"}}
\ar[ll]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1]"}}
\ar[dd]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]"}}
\ar[rr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]"}}
&&
{@{term[source=true] "\<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
\ar[dd]^{\scriptsize @{term[source=true] "\<iota>"}}
\\
\\
{@{term[source=true] "\<I>\<^sub>1"}}
&&
{@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1"}}
\ar[ll]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1]"}}
\ar[rr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>]"}}
&&
{@{term[source=true] "\<I>"}}
}$$
\<close>
have "i \<cdot> \<iota> = \<l>[\<I>\<^sub>1] \<cdot> inv \<r>\<^sub>1[\<I>] \<cdot> \<iota>"
using i_def comp_assoc by auto
also have "... = (\<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])) \<cdot> (inv \<r>\<^sub>1[\<I>] \<otimes> inv \<r>\<^sub>1[\<I>])"
using 1 comp_assoc by simp
also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1]) \<cdot> (inv \<r>\<^sub>1[\<I>] \<otimes> inv \<r>\<^sub>1[\<I>])"
using 2 comp_assoc by fastforce
also have "... = \<iota>\<^sub>1 \<cdot> (i \<otimes> i)"
using interchange i_def by simp
finally show ?thesis by blast
qed
qed
lemma inv_i_iso_\<iota>:
assumes "\<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright>" and "iso f" and "f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f)"
shows "\<guillemotleft>inv i \<cdot> f : \<I> \<rightarrow> \<I>\<guillemotright>" and "iso (inv i \<cdot> f)"
and "(inv i \<cdot> f) \<cdot> \<iota> = \<iota> \<cdot> (inv i \<cdot> f \<otimes> inv i \<cdot> f)"
proof -
show 1: "\<guillemotleft>inv i \<cdot> f : \<I> \<rightarrow> \<I>\<guillemotright>"
using assms iso_i inv_in_hom by blast
show "iso (inv i \<cdot> f)"
using assms 1 iso_i inv_in_hom iso_inv_iso
by (intro isos_compose, auto)
show "(inv i \<cdot> f) \<cdot> \<iota> = \<iota> \<cdot> (inv i \<cdot> f \<otimes> inv i \<cdot> f)"
proof -
have "(inv i \<cdot> f) \<cdot> \<iota> = (inv i \<cdot> \<iota>\<^sub>1) \<cdot> (f \<otimes> f)"
using assms iso_i comp_assoc by auto
also have "... = (\<iota> \<cdot> (inv i \<otimes> inv i)) \<cdot> (f \<otimes> f)"
using assms iso_i invert_opposite_sides_of_square
inv_tensor \<iota>_in_hom C\<^sub>1.\<iota>_in_hom tensor_in_hom tensor_preserves_iso
inv_in_hom i_maps_\<iota>_to_\<iota>\<^sub>1 unity_def seqI'
by metis
also have "... = \<iota> \<cdot> (inv i \<cdot> f \<otimes> inv i \<cdot> f)"
using assms 1 iso_i interchange comp_assoc by fastforce
finally show ?thesis by blast
qed
qed
lemma unit_unique_upto_unique_iso:
shows "\<exists>!f. \<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso f \<and> f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f)"
proof
show "\<guillemotleft>i : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso i \<and> i \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (i \<otimes> i)"
using iso_i i_maps_\<iota>_to_\<iota>\<^sub>1 by auto
show "\<And>f. \<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso f \<and> f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f) \<Longrightarrow> f = i"
proof -
fix f
assume f: "\<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso f \<and> f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f)"
have "inv i \<cdot> f = \<I>"
using f inv_i_iso_\<iota> iso_commuting_with_\<iota>_equals_\<I> by blast
hence "ide (C (inv i) f)"
using iso_i iso_inv_iso inv_in_hom by simp
thus "f = i"
using section_retraction_of_iso(2) [of "inv i" f] inverse_arrow_unique inv_is_inverse
inv_inv iso_inv_iso iso_i
by blast
qed
qed
end
section "Elementary Monoidal Category"
text\<open>
Although the economy of data assumed by @{locale monoidal_category} is useful for general
results, to establish interpretations it is more convenient to work with a traditional
definition of monoidal category. The following locale provides such a definition.
It permits a monoidal category to be specified by giving the tensor product and the
components of the associator and unitors, which are required only to satisfy elementary
conditions that imply functoriality and naturality, without having to worry about
extensionality or formal interpretations for the various functors and natural transformations.
\<close>
locale elementary_monoidal_category =
category C
for C :: "'a comp" (infixr "\<cdot>" 55)
and tensor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<otimes>" 53)
and unity :: 'a ("\<I>")
and lunit :: "'a \<Rightarrow> 'a" ("\<l>[_]")
and runit :: "'a \<Rightarrow> 'a" ("\<r>[_]")
and assoc :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]") +
assumes ide_unity [simp]: "ide \<I>"
and iso_lunit: "ide a \<Longrightarrow> iso \<l>[a]"
and iso_runit: "ide a \<Longrightarrow> iso \<r>[a]"
and iso_assoc: "\<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> iso \<a>[a, b, c]"
and tensor_in_hom [simp]: "\<lbrakk> \<guillemotleft>f : a \<rightarrow> b\<guillemotright>; \<guillemotleft>g : c \<rightarrow> d\<guillemotright> \<rbrakk> \<Longrightarrow> \<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
and tensor_preserves_ide: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes> b)"
and interchange: "\<lbrakk> seq g f; seq g' f' \<rbrakk> \<Longrightarrow> (g \<otimes> g') \<cdot> (f \<otimes> f') = g \<cdot> f \<otimes> g' \<cdot> f'"
and lunit_in_hom [simp]: "ide a \<Longrightarrow> \<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
and lunit_naturality: "arr f \<Longrightarrow> \<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
and runit_in_hom [simp]: "ide a \<Longrightarrow> \<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
and runit_naturality: "arr f \<Longrightarrow> \<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
and assoc_in_hom [simp]:
"\<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>"
and assoc_naturality:
"\<lbrakk> arr f0; arr f1; arr f2 \<rbrakk> \<Longrightarrow> \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)
= (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[dom f0, dom f1, dom f2]"
and triangle: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
and pentagon: "\<lbrakk> ide a; ide b; ide c; ide d \<rbrakk> \<Longrightarrow>
(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)
= \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
text\<open>
An interpretation for the \<open>monoidal_category\<close> locale readily induces an
interpretation for the \<open>elementary_monoidal_category\<close> locale.
\<close>
context monoidal_category
begin
lemma induces_elementary_monoidal_category:
shows "elementary_monoidal_category C tensor \<I> lunit runit assoc"
using \<iota>_in_hom iso_assoc tensor_preserves_ide assoc_in_hom tensor_in_hom
assoc_naturality lunit_naturality runit_naturality lunit_in_hom runit_in_hom
iso_lunit iso_runit interchange pentagon triangle
apply unfold_locales by auto
end
context elementary_monoidal_category
begin
interpretation CC: product_category C C ..
interpretation CCC: product_category C CC.comp ..
text\<open>
To avoid name clashes between the @{locale monoidal_category} and
@{locale elementary_monoidal_category} locales, some constants for which definitions
are needed here are given separate names from the versions in @{locale monoidal_category}.
We eventually show that the locally defined versions are equal to their counterparts
in @{locale monoidal_category}.
\<close>
definition T\<^sub>E\<^sub>M\<^sub>C :: "'a * 'a \<Rightarrow> 'a"
where "T\<^sub>E\<^sub>M\<^sub>C f \<equiv> if CC.arr f then (fst f \<otimes> snd f) else null"
lemma T_simp [simp]:
assumes "arr f" and "arr g"
shows "T\<^sub>E\<^sub>M\<^sub>C (f, g) = f \<otimes> g"
using assms T\<^sub>E\<^sub>M\<^sub>C_def by simp
lemma arr_tensor [simp]:
assumes "arr f" and "arr g"
shows "arr (f \<otimes> g)"
using assms tensor_in_hom by blast
lemma dom_tensor [simp]:
assumes "arr f" and "arr g"
shows "dom (f \<otimes> g) = dom f \<otimes> dom g"
using assms tensor_in_hom by blast
lemma cod_tensor [simp]:
assumes "arr f" and "arr g"
shows "cod (f \<otimes> g) = cod f \<otimes> cod g"
using assms tensor_in_hom by blast
definition L\<^sub>E\<^sub>M\<^sub>C
where "L\<^sub>E\<^sub>M\<^sub>C \<equiv> \<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (\<I>, f)"
definition R\<^sub>E\<^sub>M\<^sub>C :: "'a \<Rightarrow> 'a"
where "R\<^sub>E\<^sub>M\<^sub>C \<equiv> \<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (f, \<I>)"
definition \<alpha>
where "\<alpha> f \<equiv> if CCC.arr f then (fst f \<otimes> (fst (snd f) \<otimes> snd (snd f))) \<cdot>
\<a>[dom (fst f), dom (fst (snd f)), dom (snd (snd f))]
else null"
lemma \<alpha>_ide_simp [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "\<alpha> (a, b, c) = \<a>[a, b, c]"
unfolding \<alpha>_def using assms assoc_in_hom comp_cod_arr
by (metis CC.arrI CCC.arrI fst_conv ide_char in_homE snd_conv)
lemma arr_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "arr \<a>[a, b, c]"
using assms assoc_in_hom by blast
lemma dom_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
using assms assoc_in_hom by blast
lemma cod_assoc [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
using assms assoc_in_hom by blast
definition \<ll>\<^sub>E\<^sub>M\<^sub>C
where "\<ll>\<^sub>E\<^sub>M\<^sub>C f \<equiv> if arr f then f \<cdot> \<l>[dom f] else null"
lemma arr_lunit [simp]:
assumes "ide a"
shows "arr \<l>[a]"
using assms lunit_in_hom by blast
lemma dom_lunit [simp]:
assumes "ide a"
shows "dom \<l>[a] = \<I> \<otimes> a"
using assms lunit_in_hom by blast
lemma cod_lunit [simp]:
assumes "ide a"
shows "cod \<l>[a] = a"
using assms lunit_in_hom by blast
definition \<rho>\<^sub>E\<^sub>M\<^sub>C
where "\<rho>\<^sub>E\<^sub>M\<^sub>C f \<equiv> if arr f then f \<cdot> \<r>[dom f] else null"
lemma arr_runit [simp]:
assumes "ide a"
shows "arr \<r>[a]"
using assms runit_in_hom by blast
lemma dom_runit [simp]:
assumes "ide a"
shows "dom \<r>[a] = a \<otimes> \<I>"
using assms runit_in_hom by blast
lemma cod_runit [simp]:
assumes "ide a"
shows "cod \<r>[a] = a"
using assms runit_in_hom by blast
interpretation T: binary_endofunctor C T\<^sub>E\<^sub>M\<^sub>C
using tensor_in_hom interchange T\<^sub>E\<^sub>M\<^sub>C_def
apply unfold_locales
apply auto[4]
by (elim CC.seqE, auto)
lemma binary_endofunctor_T:
shows "binary_endofunctor C T\<^sub>E\<^sub>M\<^sub>C" ..
interpretation ToTC: "functor" CCC.comp C T.ToTC
using T.functor_ToTC by auto
interpretation ToCT: "functor" CCC.comp C T.ToCT
using T.functor_ToCT by auto
interpretation L: "functor" C C L\<^sub>E\<^sub>M\<^sub>C
using T.fixing_ide_gives_functor_1 L\<^sub>E\<^sub>M\<^sub>C_def by auto
lemma functor_L:
shows "functor C C L\<^sub>E\<^sub>M\<^sub>C" ..
interpretation R: "functor" C C R\<^sub>E\<^sub>M\<^sub>C
using T.fixing_ide_gives_functor_2 R\<^sub>E\<^sub>M\<^sub>C_def by auto
lemma functor_R:
shows "functor C C R\<^sub>E\<^sub>M\<^sub>C" ..
interpretation \<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>
proof -
interpret \<alpha>: transformation_by_components CCC.comp C T.ToTC T.ToCT \<alpha>
apply unfold_locales
unfolding \<alpha>_def T.ToTC_def T.ToCT_def T\<^sub>E\<^sub>M\<^sub>C_def
using comp_arr_dom comp_cod_arr assoc_naturality
by simp_all
interpret \<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>.map
using iso_assoc \<alpha>.map_simp_ide assoc_in_hom tensor_preserves_ide \<alpha>_def
by (unfold_locales, auto)
have "\<alpha> = \<alpha>.map"
using assoc_naturality \<alpha>_def comp_cod_arr T.ToTC_def T\<^sub>E\<^sub>M\<^sub>C_def \<alpha>.map_def by auto
thus "natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>"
using \<alpha>.natural_isomorphism_axioms by simp
qed
lemma natural_isomorphism_\<alpha>:
shows "natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>" ..
interpretation \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> ..
interpretation \<ll>: natural_isomorphism C C L\<^sub>E\<^sub>M\<^sub>C map \<ll>\<^sub>E\<^sub>M\<^sub>C
proof -
- interpret \<ll>: transformation_by_components C C L\<^sub>E\<^sub>M\<^sub>C map "\<lambda>a. \<l>[a]"
+ interpret \<ll>: transformation_by_components C C L\<^sub>E\<^sub>M\<^sub>C map \<open>\<lambda>a. \<l>[a]\<close>
using lunit_naturality L\<^sub>E\<^sub>M\<^sub>C_def by (unfold_locales, auto)
interpret \<ll>: natural_isomorphism C C L\<^sub>E\<^sub>M\<^sub>C map \<ll>.map
using iso_lunit by (unfold_locales, simp)
have "\<ll>.map = \<ll>\<^sub>E\<^sub>M\<^sub>C"
using \<ll>.map_def lunit_naturality \<ll>\<^sub>E\<^sub>M\<^sub>C_def L\<^sub>E\<^sub>M\<^sub>C_def by fastforce
thus "natural_isomorphism C C L\<^sub>E\<^sub>M\<^sub>C map \<ll>\<^sub>E\<^sub>M\<^sub>C"
using \<ll>.natural_isomorphism_axioms by force
qed
lemma natural_isomorphism_\<ll>:
shows "natural_isomorphism C C L\<^sub>E\<^sub>M\<^sub>C map \<ll>\<^sub>E\<^sub>M\<^sub>C" ..
interpretation \<ll>': inverse_transformation C C L\<^sub>E\<^sub>M\<^sub>C map \<ll>\<^sub>E\<^sub>M\<^sub>C ..
interpretation \<rho>: natural_isomorphism C C R\<^sub>E\<^sub>M\<^sub>C map \<rho>\<^sub>E\<^sub>M\<^sub>C
proof -
- interpret \<rho>: transformation_by_components C C R\<^sub>E\<^sub>M\<^sub>C map "\<lambda>a. \<r>[a]"
+ interpret \<rho>: transformation_by_components C C R\<^sub>E\<^sub>M\<^sub>C map \<open>\<lambda>a. \<r>[a]\<close>
using runit_naturality R\<^sub>E\<^sub>M\<^sub>C_def by (unfold_locales, auto)
interpret \<rho>: natural_isomorphism C C R\<^sub>E\<^sub>M\<^sub>C map \<rho>.map
using iso_runit \<rho>.map_simp_ide by (unfold_locales, simp)
have "\<rho>\<^sub>E\<^sub>M\<^sub>C = \<rho>.map"
using \<rho>.map_def runit_naturality T_simp \<rho>\<^sub>E\<^sub>M\<^sub>C_def R\<^sub>E\<^sub>M\<^sub>C_def by fastforce
thus "natural_isomorphism C C R\<^sub>E\<^sub>M\<^sub>C map \<rho>\<^sub>E\<^sub>M\<^sub>C"
using \<rho>.natural_isomorphism_axioms by force
qed
lemma natural_isomorphism_\<rho>:
shows "natural_isomorphism C C R\<^sub>E\<^sub>M\<^sub>C map \<rho>\<^sub>E\<^sub>M\<^sub>C" ..
interpretation \<rho>': inverse_transformation C C R\<^sub>E\<^sub>M\<^sub>C map \<rho>\<^sub>E\<^sub>M\<^sub>C ..
text\<open>
The endofunctors @{term L\<^sub>E\<^sub>M\<^sub>C} and @{term R\<^sub>E\<^sub>M\<^sub>C} are equivalence functors,
due to the existence of the unitors.
\<close>
lemma L_is_equivalence_functor:
shows "equivalence_functor C C L\<^sub>E\<^sub>M\<^sub>C"
proof -
interpret endofunctor C L\<^sub>E\<^sub>M\<^sub>C ..
show ?thesis
using isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
qed
interpretation L: equivalence_functor C C L\<^sub>E\<^sub>M\<^sub>C
using L_is_equivalence_functor by auto
lemma R_is_equivalence_functor:
shows "equivalence_functor C C R\<^sub>E\<^sub>M\<^sub>C"
proof -
interpret endofunctor C R\<^sub>E\<^sub>M\<^sub>C ..
show ?thesis
using isomorphic_to_identity_is_equivalence \<rho>.natural_isomorphism_axioms by simp
qed
interpretation R: equivalence_functor C C R\<^sub>E\<^sub>M\<^sub>C
using R_is_equivalence_functor by auto
text\<open>
To complete an interpretation of the @{locale "monoidal_category"} locale,
we define @{term "\<iota> \<equiv> \<l>[\<I>]"}.
We could also have chosen @{term "\<iota> \<equiv> \<rho>[\<I>]"} as the two are equal, though to prove
that requires some work yet.
\<close>
definition \<iota>
where "\<iota> \<equiv> \<l>[\<I>]"
lemma \<iota>_in_hom:
shows "\<guillemotleft>\<iota> : \<I> \<otimes> \<I> \<rightarrow> \<I>\<guillemotright>"
using lunit_in_hom \<iota>_def by simp
lemma induces_monoidal_category:
shows "monoidal_category C T\<^sub>E\<^sub>M\<^sub>C \<alpha> \<iota>"
proof -
- interpret L: equivalence_functor C C "\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (cod \<iota>, f)"
+ interpret L: equivalence_functor C C \<open>\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (cod \<iota>, f)\<close>
proof -
have "L\<^sub>E\<^sub>M\<^sub>C = (\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (cod \<iota>, f))" using \<iota>_in_hom L\<^sub>E\<^sub>M\<^sub>C_def by auto
thus "equivalence_functor C C (\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (cod \<iota>, f))"
using L.equivalence_functor_axioms T\<^sub>E\<^sub>M\<^sub>C_def L\<^sub>E\<^sub>M\<^sub>C_def by simp
qed
- interpret R: equivalence_functor C C "\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (f, cod \<iota>)"
+ interpret R: equivalence_functor C C \<open>\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (f, cod \<iota>)\<close>
proof -
have "R\<^sub>E\<^sub>M\<^sub>C = (\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (f, cod \<iota>))" using \<iota>_in_hom R\<^sub>E\<^sub>M\<^sub>C_def by auto
thus "equivalence_functor C C (\<lambda>f. T\<^sub>E\<^sub>M\<^sub>C (f, cod \<iota>))"
using R.equivalence_functor_axioms T\<^sub>E\<^sub>M\<^sub>C_def R\<^sub>E\<^sub>M\<^sub>C_def by simp
qed
show ?thesis
proof
show "\<guillemotleft>\<iota> : T\<^sub>E\<^sub>M\<^sub>C (cod \<iota>, cod \<iota>) \<rightarrow> cod \<iota>\<guillemotright>" using \<iota>_in_hom by fastforce
show "iso \<iota>" using iso_lunit \<iota>_def by simp
show "\<And>a b c d. \<lbrakk> ide a; ide b; ide c; ide d \<rbrakk> \<Longrightarrow>
T\<^sub>E\<^sub>M\<^sub>C (a, \<alpha> (b, c, d)) \<cdot> \<alpha> (a, T\<^sub>E\<^sub>M\<^sub>C (b, c), d) \<cdot> T\<^sub>E\<^sub>M\<^sub>C (\<alpha> (a, b, c), d)
= \<alpha> (a, b, T\<^sub>E\<^sub>M\<^sub>C (c, d)) \<cdot> \<alpha> (T\<^sub>E\<^sub>M\<^sub>C (a, b), c, d)"
using pentagon tensor_preserves_ide by simp
qed
qed
interpretation MC: monoidal_category C T\<^sub>E\<^sub>M\<^sub>C \<alpha> \<iota>
using induces_monoidal_category by auto
text\<open>
We now show that the notions defined in the interpretation \<open>MC\<close> agree with their
counterparts in the present locale. These facts are needed if we define an
interpretation for the @{locale elementary_monoidal_category} locale, use it to
obtain the induced interpretation for @{locale monoidal_category}, and then want to
transfer facts obtained in the induced interpretation back to the original one.
\<close>
lemma \<I>_agreement:
shows "\<I> = MC.unity"
using \<iota>_in_hom MC.unity_def by auto
lemma L\<^sub>E\<^sub>M\<^sub>C_agreement:
shows "L\<^sub>E\<^sub>M\<^sub>C = MC.L"
using \<iota>_in_hom L\<^sub>E\<^sub>M\<^sub>C_def MC.unity_def by auto
lemma R\<^sub>E\<^sub>M\<^sub>C_agreement:
shows "R\<^sub>E\<^sub>M\<^sub>C = MC.R"
using \<iota>_in_hom R\<^sub>E\<^sub>M\<^sub>C_def MC.unity_def by auto
text\<open>
We wish to show that the components of the unitors @{term MC.\<ll>} and @{term MC.\<rho>}
defined in the induced interpretation \<open>MC\<close> agree with those given by the
parameters @{term lunit} and @{term runit} to the present locale. To avoid a lengthy
development that repeats work already done in the @{locale monoidal_category} locale,
we establish the agreement in a special case and then use the properties already
shown for \<open>MC\<close> to prove the general case. In particular, we first show that
@{term "\<l>[\<I>] = MC.lunit MC.unity"} and @{term "\<r>[\<I>] = MC.runit MC.unity"},
from which it follows by facts already proved for @{term MC} that both are equal to @{term \<iota>}.
We then show that for an arbitrary identity @{term a} the arrows @{term "\<l>[a]"}
and @{term "\<r>[a]"} satisfy the equations that uniquely characterize the components
@{term "MC.lunit a"} and @{term "MC.runit a"}, respectively, and are therefore equal
to those components.
\<close>
lemma unitor_coincidence\<^sub>E\<^sub>M\<^sub>C:
shows "\<l>[\<I>] = \<iota>" and "\<r>[\<I>] = \<iota>"
proof -
have "\<r>[\<I>] = MC.runit MC.unity"
proof (intro MC.runit_eqI)
show "\<guillemotleft>\<r>[\<I>] : MC.tensor MC.unity MC.unity \<rightarrow> MC.unity\<guillemotright>"
using runit_in_hom \<iota>_in_hom MC.unity_def by auto
show "MC.tensor \<r>[\<I>] MC.unity
= MC.tensor MC.unity \<iota> \<cdot> MC.assoc MC.unity MC.unity MC.unity"
using T\<^sub>E\<^sub>M\<^sub>C_def \<iota>_in_hom \<iota>_def triangle MC.unity_def
by (elim in_homE, auto)
qed
moreover have "\<l>[\<I>] = MC.lunit MC.unity"
proof (intro MC.lunit_eqI)
show "\<guillemotleft>\<l>[\<I>] : MC.tensor MC.unity MC.unity \<rightarrow> MC.unity\<guillemotright>"
using lunit_in_hom [of \<I>] \<iota>_in_hom MC.unity_def by auto
show "MC.tensor MC.unity \<l>[\<I>]
= MC.tensor \<iota> MC.unity \<cdot> MC.assoc' MC.unity MC.unity MC.unity"
using T\<^sub>E\<^sub>M\<^sub>C_def lunit_in_hom \<iota>_in_hom \<iota>_def MC.\<iota>_triangle by argo
qed
moreover have "MC.lunit MC.unity = \<iota> \<and> MC.runit MC.unity = \<iota>"
using MC.unitor_coincidence by simp
ultimately have 1: "\<l>[\<I>] = \<iota> \<and> \<r>[\<I>] = \<iota>" by simp
show "\<l>[\<I>] = \<iota>" using 1 by simp
show "\<r>[\<I>] = \<iota>" using 1 by simp
qed
lemma lunit_char\<^sub>E\<^sub>M\<^sub>C:
assumes "ide a"
shows "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a"
proof -
have "(\<r>[\<I>] \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a
= ((\<I> \<otimes> \<l>[a]) \<cdot> \<a>[\<I>, \<I>, a]) \<cdot> MC.assoc' MC.unity MC.unity a"
using assms triangle by simp
also have "... = \<I> \<otimes> \<l>[a]"
using assms MC.assoc_inv comp_arr_inv \<I>_agreement iso_assoc comp_arr_dom comp_assoc
by auto
finally have "\<I> \<otimes> \<l>[a] = (\<r>[\<I>] \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a" by argo
thus "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a"
using unitor_coincidence\<^sub>E\<^sub>M\<^sub>C by auto
qed
lemma runit_char\<^sub>E\<^sub>M\<^sub>C:
assumes "ide a"
shows "\<r>[a] \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
using assms triangle \<iota>_def by simp
lemma \<ll>\<^sub>E\<^sub>M\<^sub>C_agreement:
shows "\<ll>\<^sub>E\<^sub>M\<^sub>C = MC.\<ll>"
proof
fix f
have "\<not> arr f \<Longrightarrow> \<ll>\<^sub>E\<^sub>M\<^sub>C f = MC.\<ll> f" by (simp add: \<ll>\<^sub>E\<^sub>M\<^sub>C_def)
moreover have "arr f \<Longrightarrow> \<ll>\<^sub>E\<^sub>M\<^sub>C f = MC.\<ll> f"
proof -
have "\<And>a. ide a \<Longrightarrow> \<l>[a] = MC.lunit a"
using \<I>_agreement T\<^sub>E\<^sub>M\<^sub>C_def lunit_char\<^sub>E\<^sub>M\<^sub>C \<iota>_in_hom
by (intro MC.lunit_eqI, auto)
thus ?thesis using \<ll>\<^sub>E\<^sub>M\<^sub>C_def by force
qed
ultimately show "\<ll>\<^sub>E\<^sub>M\<^sub>C f = MC.\<ll> f" by blast
qed
lemma \<rho>\<^sub>E\<^sub>M\<^sub>C_agreement:
shows "\<rho>\<^sub>E\<^sub>M\<^sub>C = MC.\<rho>"
proof
fix f
have "\<not> arr f \<Longrightarrow> \<rho>\<^sub>E\<^sub>M\<^sub>C f = MC.\<rho> f" by (simp add: \<rho>\<^sub>E\<^sub>M\<^sub>C_def)
moreover have "arr f \<Longrightarrow> \<rho>\<^sub>E\<^sub>M\<^sub>C f = MC.\<rho> f"
proof -
have "\<And>a. ide a \<Longrightarrow> \<r>[a] = MC.runit a"
using \<I>_agreement T\<^sub>E\<^sub>M\<^sub>C_def runit_char\<^sub>E\<^sub>M\<^sub>C \<iota>_in_hom
by (intro MC.runit_eqI, auto)
thus ?thesis using \<rho>\<^sub>E\<^sub>M\<^sub>C_def by force
qed
ultimately show "\<rho>\<^sub>E\<^sub>M\<^sub>C f = MC.\<rho> f" by blast
qed
lemma assoc_agreement:
assumes "ide a" and "ide b" and "ide c"
shows "MC.assoc a b c = \<a>[a, b, c]"
using assms \<alpha>_ide_simp by auto
lemma lunit_agreement:
assumes "ide a"
shows "MC.lunit a = \<l>[a]"
proof -
have "MC.lunit a = \<ll>\<^sub>E\<^sub>M\<^sub>C a"
using assms comp_cod_arr \<ll>\<^sub>E\<^sub>M\<^sub>C_agreement by simp
also have "... = \<l>[a]"
using assms \<ll>\<^sub>E\<^sub>M\<^sub>C_def comp_cod_arr by simp
finally show ?thesis by simp
qed
lemma runit_agreement:
assumes "ide a"
shows "MC.runit a = \<r>[a]"
proof -
have "MC.runit a = \<rho>\<^sub>E\<^sub>M\<^sub>C a"
using assms comp_cod_arr \<rho>\<^sub>E\<^sub>M\<^sub>C_agreement by simp
also have "... = \<r>[a]"
using assms \<rho>\<^sub>E\<^sub>M\<^sub>C_def comp_cod_arr by simp
finally show ?thesis by simp
qed
end
section "Strict Monoidal Category"
text\<open>
A monoidal category is \emph{strict} if the components of the associator and unitors
are all identities.
\<close>
locale strict_monoidal_category =
monoidal_category +
assumes strict_assoc: "\<lbrakk> ide a0; ide a1; ide a2 \<rbrakk> \<Longrightarrow> ide \<a>[a0, a1, a2]"
and strict_lunit: "ide a \<Longrightarrow> \<l>[a] = a"
and strict_runit: "ide a \<Longrightarrow> \<r>[a] = a"
begin
lemma strict_unit:
shows "\<iota> = \<I>"
using strict_lunit unitor_coincidence(1) by auto
lemma tensor_assoc [simp]:
assumes "arr f0" and "arr f1" and "arr f2"
shows "(f0 \<otimes> f1) \<otimes> f2 = f0 \<otimes> f1 \<otimes> f2"
proof -
have "(f0 \<otimes> f1) \<otimes> f2 = \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
using assms assoc_in_hom [of "cod f0" "cod f1" "cod f2"] strict_assoc comp_cod_arr
by auto
also have "... = (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
using assms assoc_naturality by simp
also have "... = f0 \<otimes> f1 \<otimes> f2"
using assms assoc_in_hom [of "dom f0" "dom f1" "dom f2"] strict_assoc comp_arr_dom
by auto
finally show ?thesis by simp
qed
end
section "Opposite Monoidal Category"
text\<open>
The \emph{opposite} of a monoidal category has the same underlying category, but the
arguments to the tensor product are reversed and the associator is inverted and its
arguments reversed.
\<close>
locale opposite_monoidal_category =
C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>
for C :: "'a comp" (infixr "\<cdot>" 55)
and T\<^sub>C :: "'a * 'a \<Rightarrow> 'a"
and \<alpha>\<^sub>C :: "'a * 'a * 'a \<Rightarrow> 'a"
and \<iota> :: 'a
begin
abbreviation T
where "T f \<equiv> T\<^sub>C (snd f, fst f)"
abbreviation \<alpha>
where "\<alpha> f \<equiv> C.\<alpha>' (snd (snd f), fst (snd f), fst f)"
end
sublocale opposite_monoidal_category \<subseteq> monoidal_category C T \<alpha> \<iota>
proof -
interpret T: binary_endofunctor C T
using C.T.is_extensional C.CC.seq_char C.interchange by (unfold_locales, auto)
interpret ToTC: "functor" C.CCC.comp C T.ToTC
using T.functor_ToTC by auto
interpret ToCT: "functor" C.CCC.comp C T.ToCT
using T.functor_ToCT by auto
interpret \<alpha>: natural_transformation C.CCC.comp C T.ToTC T.ToCT \<alpha>
using C.\<alpha>'.is_extensional C.CCC.dom_char C.CCC.cod_char T.ToTC_def T.ToCT_def
C.\<alpha>'_simp C.\<alpha>'.naturality
by (unfold_locales, auto)
interpret \<alpha>: natural_isomorphism C.CCC.comp C T.ToTC T.ToCT \<alpha>
using C.\<alpha>'.components_are_iso by (unfold_locales, simp)
- interpret L: equivalence_functor C C "\<lambda>f. T (C.cod \<iota>, f)"
+ interpret L: equivalence_functor C C \<open>\<lambda>f. T (C.cod \<iota>, f)\<close>
using C.R.equivalence_functor_axioms by simp
- interpret R: equivalence_functor C C "\<lambda>f. T (f, C.cod \<iota>)"
+ interpret R: equivalence_functor C C \<open>\<lambda>f. T (f, C.cod \<iota>)\<close>
using C.L.equivalence_functor_axioms by simp
show "monoidal_category C T \<alpha> \<iota>"
using C.\<iota>_in_hom C.\<iota>_is_iso C.unity_def C.pentagon' C.comp_assoc
by (unfold_locales, auto)
qed
context opposite_monoidal_category
begin
lemma lunit_simp:
assumes "C.ide a"
shows "lunit a = C.runit a"
using assms lunit_char C.iso_assoc by (intro C.runit_eqI, auto)
lemma runit_simp:
assumes "C.ide a"
shows "runit a = C.lunit a"
using assms runit_char C.iso_assoc by (intro C.lunit_eqI, auto)
end
section "Monoidal Language"
text\<open>
In this section we assume that a category @{term C} is given, and we define a
formal syntax of terms constructed from arrows of @{term C} using function symbols
that correspond to unity, composition, tensor, the associator and its formal inverse,
and the left and right unitors and their formal inverses.
We will use this syntax to state and prove the coherence theorem and then to construct
the free monoidal category generated by @{term C}.
\<close>
locale monoidal_language =
C: category C
for C :: "'a comp" (infixr "\<cdot>" 55)
begin
datatype (discs_sels) 't "term" =
Prim 't ("\<^bold>\<langle>_\<^bold>\<rangle>")
| Unity ("\<^bold>\<I>")
| Tensor "'t term" "'t term" (infixr "\<^bold>\<otimes>" 53)
| Comp "'t term" "'t term" (infixr "\<^bold>\<cdot>" 55)
| Lunit "'t term" ("\<^bold>\<l>\<^bold>[_\<^bold>]")
| Lunit' "'t term" ("\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
| Runit "'t term" ("\<^bold>\<r>\<^bold>[_\<^bold>]")
| Runit' "'t term" ("\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
| Assoc "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^bold>[_, _, _\<^bold>]")
| Assoc' "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[_, _, _\<^bold>]")
lemma not_is_Tensor_Unity:
shows "\<not> is_Tensor Unity"
by simp
text\<open>
We define formal domain and codomain functions on terms.
\<close>
primrec Dom :: "'a term \<Rightarrow> 'a term"
where "Dom \<^bold>\<langle>f\<^bold>\<rangle> = \<^bold>\<langle>C.dom f\<^bold>\<rangle>"
| "Dom \<^bold>\<I> = \<^bold>\<I>"
| "Dom (t \<^bold>\<otimes> u) = (Dom t \<^bold>\<otimes> Dom u)"
| "Dom (t \<^bold>\<cdot> u) = Dom u"
| "Dom \<^bold>\<l>\<^bold>[t\<^bold>] = (\<^bold>\<I> \<^bold>\<otimes> Dom t)"
| "Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
| "Dom \<^bold>\<r>\<^bold>[t\<^bold>] = (Dom t \<^bold>\<otimes> \<^bold>\<I>)"
| "Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
| "Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = ((Dom t \<^bold>\<otimes> Dom u) \<^bold>\<otimes> Dom v)"
| "Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Dom t \<^bold>\<otimes> (Dom u \<^bold>\<otimes> Dom v))"
primrec Cod :: "'a term \<Rightarrow> 'a term"
where "Cod \<^bold>\<langle>f\<^bold>\<rangle> = \<^bold>\<langle>C.cod f\<^bold>\<rangle>"
| "Cod \<^bold>\<I> = \<^bold>\<I>"
| "Cod (t \<^bold>\<otimes> u) = (Cod t \<^bold>\<otimes> Cod u)"
| "Cod (t \<^bold>\<cdot> u) = Cod t"
| "Cod \<^bold>\<l>\<^bold>[t\<^bold>] = Cod t"
| "Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = (\<^bold>\<I> \<^bold>\<otimes> Cod t)"
| "Cod \<^bold>\<r>\<^bold>[t\<^bold>] = Cod t"
| "Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = (Cod t \<^bold>\<otimes> \<^bold>\<I>)"
| "Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Cod t \<^bold>\<otimes> (Cod u \<^bold>\<otimes> Cod v))"
| "Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = ((Cod t \<^bold>\<otimes> Cod u) \<^bold>\<otimes> Cod v)"
text\<open>
A term is a ``formal arrow'' if it is constructed from arrows of @{term[source=true] C}
in such a way that composition is applied only to formally composable pairs of terms.
\<close>
primrec Arr :: "'a term \<Rightarrow> bool"
where "Arr \<^bold>\<langle>f\<^bold>\<rangle> = C.arr f"
| "Arr \<^bold>\<I> = True"
| "Arr (t \<^bold>\<otimes> u) = (Arr t \<and> Arr u)"
| "Arr (t \<^bold>\<cdot> u) = (Arr t \<and> Arr u \<and> Dom t = Cod u)"
| "Arr \<^bold>\<l>\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<r>\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
| "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v)"
| "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v)"
abbreviation Par :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
where "Par t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Dom u \<and> Cod t = Cod u"
abbreviation Seq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
where "Seq t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Cod u"
abbreviation Hom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
where "Hom a b \<equiv> { t. Arr t \<and> Dom t = a \<and> Cod t = b }"
text\<open>
A term is a ``formal identity'' if it is constructed from identity arrows of
@{term[source=true] C} and @{term "\<^bold>\<I>"} using only the \<open>\<^bold>\<otimes>\<close> operator.
\<close>
primrec Ide :: "'a term \<Rightarrow> bool"
where "Ide \<^bold>\<langle>f\<^bold>\<rangle> = C.ide f"
| "Ide \<^bold>\<I> = True"
| "Ide (t \<^bold>\<otimes> u) = (Ide t \<and> Ide u)"
| "Ide (t \<^bold>\<cdot> u) = False"
| "Ide \<^bold>\<l>\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<r>\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
| "Ide \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
| "Ide \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
lemma Ide_implies_Arr [simp]:
shows "Ide t \<Longrightarrow> Arr t"
by (induct t) auto
lemma Arr_implies_Ide_Dom [elim]:
shows "Arr t \<Longrightarrow> Ide (Dom t)"
by (induct t) auto
lemma Arr_implies_Ide_Cod [elim]:
shows "Arr t \<Longrightarrow> Ide (Cod t)"
by (induct t) auto
lemma Ide_in_Hom [simp]:
shows "Ide t \<Longrightarrow> t \<in> Hom t t"
by (induct t) auto
text\<open>
A formal arrow is ``canonical'' if the only arrows of @{term[source=true] C} used in its
construction are identities.
\<close>
primrec Can :: "'a term \<Rightarrow> bool"
where "Can \<^bold>\<langle>f\<^bold>\<rangle> = C.ide f"
| "Can \<^bold>\<I> = True"
| "Can (t \<^bold>\<otimes> u) = (Can t \<and> Can u)"
| "Can (t \<^bold>\<cdot> u) = (Can t \<and> Can u \<and> Dom t = Cod u)"
| "Can \<^bold>\<l>\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<r>\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
| "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v)"
| "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v)"
lemma Ide_implies_Can:
shows "Ide t \<Longrightarrow> Can t"
by (induct t) auto
lemma Can_implies_Arr:
shows "Can t \<Longrightarrow> Arr t"
by (induct t) auto
text\<open>
We next define the formal inverse of a term.
This is only sensible for formal arrows built using only isomorphisms of
@{term[source=true] C}; in particular, for canonical formal arrows.
\<close>
primrec Inv :: "'a term \<Rightarrow> 'a term"
where "Inv \<^bold>\<langle>f\<^bold>\<rangle> = \<^bold>\<langle>C.inv f\<^bold>\<rangle>"
| "Inv \<^bold>\<I> = \<^bold>\<I>"
| "Inv (t \<^bold>\<otimes> u) = (Inv t \<^bold>\<otimes> Inv u)"
| "Inv (t \<^bold>\<cdot> u) = (Inv u \<^bold>\<cdot> Inv t)"
| "Inv \<^bold>\<l>\<^bold>[t\<^bold>] = \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<l>\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<r>\<^bold>[t\<^bold>] = \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<r>\<^bold>[Inv t\<^bold>]"
| "Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
| "Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
lemma Inv_preserves_Ide:
shows "Ide t \<Longrightarrow> Ide (Inv t)"
by (induct t) auto
lemma Inv_preserves_Can:
assumes "Can t"
shows "Can (Inv t)" and "Dom (Inv t) = Cod t" and "Cod (Inv t) = Dom t"
proof -
have 0: "Can t \<Longrightarrow> Can (Inv t) \<and> Dom (Inv t) = Cod t \<and> Cod (Inv t) = Dom t"
by (induct t) auto
show "Can (Inv t)" using assms 0 by blast
show "Dom (Inv t) = Cod t" using assms 0 by blast
show "Cod (Inv t) = Dom t" using assms 0 by blast
qed
lemma Inv_in_Hom [simp]:
assumes "Can t"
shows "Inv t \<in> Hom (Cod t) (Dom t)"
using assms Inv_preserves_Can Can_implies_Arr by simp
lemma Inv_Ide [simp]:
assumes "Ide a"
shows "Inv a = a"
using assms by (induct a) auto
lemma Inv_Inv [simp]:
assumes "Can t"
shows "Inv (Inv t) = t"
using assms by (induct t) auto
text\<open>
We call a term ``diagonal'' if it is either @{term "\<^bold>\<I>"} or it is constructed from
arrows of @{term[source=true] C} using only the \<open>\<^bold>\<otimes>\<close> operator associated to the right.
Essentially, such terms are lists of arrows of @{term[source=true] C}, where @{term "\<^bold>\<I>"}
represents the empty list and \<open>\<^bold>\<otimes>\<close> is used as the list constructor.
We call them ``diagonal'' because terms can regarded as defining ``interconnection matrices''
of arrows connecting ``inputs'' to ``outputs'', and from this point of view diagonal
terms correspond to diagonal matrices. The matrix point of view is suggestive for the
extension of the results presented here to the symmetric monoidal and cartesian monoidal
cases.
\<close>
fun Diag :: "'a term \<Rightarrow> bool"
where "Diag \<^bold>\<I> = True"
| "Diag \<^bold>\<langle>f\<^bold>\<rangle> = C.arr f"
| "Diag (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u) = (C.arr f \<and> Diag u \<and> u \<noteq> \<^bold>\<I>)"
| "Diag _ = False"
lemma Diag_TensorE:
assumes "Diag (Tensor t u)"
shows "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" and "C.arr (un_Prim t)" and "Diag t" and "Diag u" and "u \<noteq> \<^bold>\<I>"
proof -
have 1: "t = \<^bold>\<langle>un_Prim t\<^bold>\<rangle> \<and> C.arr (un_Prim t) \<and> Diag t \<and> Diag u \<and> u \<noteq> \<^bold>\<I>"
using assms by (cases t; simp; cases u; simp)
show "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" using 1 by simp
show "C.arr (un_Prim t)" using 1 by simp
show "Diag t" using 1 by simp
show "Diag u" using 1 by simp
show "u \<noteq> \<^bold>\<I>" using 1 by simp
qed
lemma Diag_implies_Arr [elim]:
shows "Diag t \<Longrightarrow> Arr t"
apply (induct t, simp_all)
by (simp add: Diag_TensorE)
lemma Dom_preserves_Diag [elim]:
shows "Diag t \<Longrightarrow> Diag (Dom t)"
apply (induct t, simp_all)
proof -
fix u v
assume I2: "Diag v \<Longrightarrow> Diag (Dom v)"
assume uv: "Diag (u \<^bold>\<otimes> v)"
show "Diag (Dom u \<^bold>\<otimes> Dom v)"
proof -
have 1: "is_Prim (Dom u) \<and> C.arr (un_Prim (Dom u)) \<and>
Dom u = \<^bold>\<langle>C.dom (un_Prim u)\<^bold>\<rangle>"
using uv by (cases u; simp; cases v, simp_all)
have 2: "Diag v \<and> v \<noteq> \<^bold>\<I> \<and> \<not> is_Comp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
using uv by (cases u; simp; cases v, simp_all)
have "Diag (Dom v) \<and> Dom v \<noteq> \<^bold>\<I>"
using 2 I2 by (cases v, simp_all)
thus ?thesis using 1 by force
qed
qed
lemma Cod_preserves_Diag [elim]:
shows "Diag t \<Longrightarrow> Diag (Cod t)"
apply (induct t, simp_all)
proof -
fix u v
assume I2: "Diag v \<Longrightarrow> Diag (Cod v)"
assume uv: "Diag (u \<^bold>\<otimes> v)"
show "Diag (Cod u \<^bold>\<otimes> Cod v)"
proof -
have 1: "is_Prim (Cod u) \<and> C.arr (un_Prim (Cod u)) \<and> Cod u = \<^bold>\<langle>C.cod (un_Prim u)\<^bold>\<rangle>"
using uv by (cases u; simp; cases v; simp)
have 2: "Diag v \<and> v \<noteq> \<^bold>\<I> \<and> \<not> is_Comp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
using uv by (cases u; simp; cases v; simp)
have "Diag (Cod v) \<and> Cod v \<noteq> \<^bold>\<I>"
using I2 2 by (cases v, simp_all)
thus ?thesis using 1 by force
qed
qed
lemma Inv_preserves_Diag:
assumes "Can t" and "Diag t"
shows "Diag (Inv t)"
proof -
have "Can t \<and> Diag t \<Longrightarrow> Diag (Inv t)"
apply (induct t, simp_all)
by (metis (no_types, lifting) Can.simps(1) Inv.simps(1) Inv.simps(2) Diag.simps(3)
Inv_Inv Diag_TensorE(1) C.inv_ide)
thus ?thesis using assms by blast
qed
text\<open>
The following function defines the ``dimension'' of a term,
which is the number of arrows of @{term C} it contains.
For diagonal terms, this is just the length of the term when regarded as a list
of arrows of @{term C}.
Alternatively, if a term is regarded as defining an interconnection matrix,
then the dimension is the number of inputs (or outputs).
\<close>
primrec dim :: "'a term \<Rightarrow> nat"
where "dim \<^bold>\<langle>f\<^bold>\<rangle> = 1"
| "dim \<^bold>\<I> = 0"
| "dim (t \<^bold>\<otimes> u) = (dim t + dim u)"
| "dim (t \<^bold>\<cdot> u) = dim t"
| "dim \<^bold>\<l>\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<r>\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
| "dim \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
| "dim \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
text\<open>
The following function defines a tensor product for diagonal terms.
If terms are regarded as lists, this is just list concatenation.
If terms are regarded as matrices, this corresponds to constructing a block
diagonal matrix.
\<close>
fun TensorDiag (infixr "\<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>" 53)
where "\<^bold>\<I> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = u"
| "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<I> = t"
| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u"
| "(t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
| "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = undefined"
lemma TensorDiag_Prim [simp]:
assumes "t \<noteq> \<^bold>\<I>"
shows "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> t = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> t"
using assms by (cases t, simp_all)
lemma TensorDiag_term_Unity [simp]:
shows "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<I> = t"
by (cases "t = \<^bold>\<I>"; cases t, simp_all)
lemma TensorDiag_Diag:
assumes "Diag (t \<^bold>\<otimes> u)"
shows "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = t \<^bold>\<otimes> u"
using assms TensorDiag_Prim by (cases t, simp_all)
lemma TensorDiag_preserves_Diag:
assumes "Diag t" and "Diag u"
shows "Diag (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
and "Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u"
and "Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
proof -
have 0: "\<And>u. \<lbrakk> Diag t; Diag u \<rbrakk> \<Longrightarrow>
Diag (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
apply (induct t, simp_all)
proof -
fix f :: 'a and u :: "'a term"
assume f: "C.arr f"
assume u: "Diag u"
show "Diag (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = \<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
Cod (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = \<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
using u f by (cases u, simp_all)
next
fix u v w
assume I1: "\<And>u. Diag v \<Longrightarrow> Diag u \<Longrightarrow> Diag (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and>
Dom (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
Cod (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
assume I2: "\<And>u. Diag w \<Longrightarrow> Diag u \<Longrightarrow> Diag (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and>
Dom (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
Cod (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
assume vw: "Diag (v \<^bold>\<otimes> w)"
assume u: "Diag u"
show "Diag ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and>
Dom ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = (Dom v \<^bold>\<otimes> Dom w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
Cod ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = (Cod v \<^bold>\<otimes> Cod w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
proof -
have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> Diag v"
using vw Diag_implies_Arr Diag_TensorE [of v w] by force
have w: "Diag w"
using vw by (simp add: Diag_TensorE)
have "u = \<^bold>\<I> \<Longrightarrow> ?thesis" by (simp add: vw)
moreover have "u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
using u v w I1 I2 Dom_preserves_Diag [of u] Cod_preserves_Diag [of u]
by (cases u, simp_all)
ultimately show ?thesis by blast
qed
qed
show "Diag (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) " using assms 0 by blast
show "Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u" using assms 0 by blast
show "Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u" using assms 0 by blast
qed
lemma TensorDiag_in_Hom:
assumes "Diag t" and "Diag u"
shows "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u \<in> Hom (Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u) (Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)"
using assms TensorDiag_preserves_Diag Diag_implies_Arr by simp
lemma Dom_TensorDiag:
assumes "Diag t" and "Diag u"
shows "Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u"
using assms TensorDiag_preserves_Diag(2) by simp
lemma Cod_TensorDiag:
assumes "Diag t" and "Diag u"
shows "Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
using assms TensorDiag_preserves_Diag(3) by simp
lemma not_is_Tensor_TensorDiagE:
assumes "\<not> is_Tensor (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)" and "Diag t" and "Diag u"
and "t \<noteq> \<^bold>\<I>" and "u \<noteq> \<^bold>\<I>"
shows "False"
proof -
have "\<lbrakk> \<not> is_Tensor (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u); Diag t; Diag u; t \<noteq> \<^bold>\<I>; u \<noteq> \<^bold>\<I> \<rbrakk> \<Longrightarrow> False"
apply (induct t, simp_all)
proof -
fix v w
assume I2: "\<not> is_Tensor (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<Longrightarrow> Diag w \<Longrightarrow> w \<noteq> \<^bold>\<I> \<Longrightarrow> False"
assume 1: "\<not> is_Tensor ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
assume vw: "Diag (v \<^bold>\<otimes> w)"
assume u: "Diag u"
assume 2: "u \<noteq> \<^bold>\<I>"
show "False"
proof -
have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle>"
using vw Diag_TensorE [of v w] by force
have w: "Diag w \<and> w \<noteq> \<^bold>\<I>"
using vw Diag_TensorE [of v w] by simp
have "(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = v \<^bold>\<otimes> (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
proof -
have "(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
using u 2 by (cases u, simp_all)
also have "... = v \<^bold>\<otimes> (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
using u v w I2 TensorDiag_Prim not_is_Tensor_Unity by metis
finally show ?thesis by simp
qed
thus ?thesis using 1 by simp
qed
qed
thus ?thesis using assms by blast
qed
lemma TensorDiag_assoc:
assumes "Diag t" and "Diag u" and "Diag v"
shows "(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
proof -
have "\<And>n t u v. \<lbrakk> dim t = n; Diag t; Diag u; Diag v \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
proof -
fix n
show "\<And>t u v. \<lbrakk> dim t = n; Diag t; Diag u; Diag v \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
proof (induction n rule: nat_less_induct)
fix n :: nat and t :: "'a term" and u v
assume I: "\<forall>m<n. \<forall>t u v. dim t = m \<longrightarrow> Diag t \<longrightarrow> Diag u \<longrightarrow> Diag v \<longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
assume dim: "dim t = n"
assume t: "Diag t"
assume u: "Diag u"
assume v: "Diag v"
show "(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
proof -
have "t = \<^bold>\<I> \<Longrightarrow> ?thesis" by simp
moreover have "u = \<^bold>\<I> \<Longrightarrow> ?thesis" by simp
moreover have "v = \<^bold>\<I> \<Longrightarrow> ?thesis" by simp
moreover have "t \<noteq> \<^bold>\<I> \<and> u \<noteq> \<^bold>\<I> \<and> v \<noteq> \<^bold>\<I> \<and> is_Prim t \<Longrightarrow> ?thesis"
using v by (cases t, simp_all, cases u, simp_all; cases v, simp_all)
moreover have "t \<noteq> \<^bold>\<I> \<and> u \<noteq> \<^bold>\<I> \<and> v \<noteq> \<^bold>\<I> \<and> is_Tensor t \<Longrightarrow> ?thesis"
proof (cases t; simp)
fix w :: "'a term" and x :: "'a term"
assume 1: "u \<noteq> \<^bold>\<I> \<and> v \<noteq> \<^bold>\<I>"
assume 2: "t = (w \<^bold>\<otimes> x)"
show "((w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = (w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
proof -
have w: "w = \<^bold>\<langle>un_Prim w\<^bold>\<rangle>"
using t 1 2 Diag_TensorE [of w x] by auto
have x: "Diag x"
using t w 1 2 by (cases w, simp_all)
have "((w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v"
using u v w x 1 2 by (cases u, simp_all)
also have "... = (w \<^bold>\<otimes> (x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v"
using t w u 1 2 TensorDiag_Prim not_is_Tensor_TensorDiagE Diag_TensorE
not_is_Tensor_Unity
by metis
also have "... = w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> ((x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
using u v w x 1 by (cases u, simp_all; cases v, simp_all)
also have "... = w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v))"
proof -
have "dim x < dim t"
using w 2 by (cases w, simp_all)
thus ?thesis
using u v x dim I by simp
qed
also have "... = (w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
proof -
have 3: "is_Tensor (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
using u v 1 not_is_Tensor_TensorDiagE by auto
obtain u' :: "'a term" and v' where uv': "u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = u' \<^bold>\<otimes> v'"
using 3 is_Tensor_def by blast
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
qed
moreover have "t = \<^bold>\<I> \<or> is_Prim t \<or> is_Tensor t"
using t by (cases t, simp_all)
ultimately show ?thesis by blast
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma TensorDiag_preserves_Ide:
assumes "Ide t" and "Ide u" and "Diag t" and "Diag u"
shows "Ide (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
using assms
by (metis (mono_tags, lifting) Arr_implies_Ide_Dom Ide_in_Hom Diag_implies_Arr
TensorDiag_preserves_Diag(1) TensorDiag_preserves_Diag(2) mem_Collect_eq)
lemma TensorDiag_preserves_Can:
assumes "Can t" and "Can u" and "Diag t" and "Diag u"
shows "Can (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
proof (induct t; simp)
show "\<And>x u. C.ide x \<and> C.arr x \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow> Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
by (metis Ide.simps(1) Ide.simps(2) Ide_implies_Can Diag.simps(2) TensorDiag_Prim
TensorDiag_preserves_Ide Can.simps(3))
show "\<And>t1 t2 u. (\<And>u. Diag t1 \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow> Can (t1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<Longrightarrow>
(\<And>u. Diag t2 \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow> Can (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<Longrightarrow>
Can t1 \<and> Can t2 \<and> Diag (t1 \<^bold>\<otimes> t2) \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow>
Can ((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
by (metis Diag_TensorE(3) Diag_TensorE(4) TensorDiag_Diag TensorDiag_assoc
TensorDiag_preserves_Diag(1))
qed
thus ?thesis using assms by blast
qed
lemma Inv_TensorDiag:
assumes "Can t" and "Can u" and "Diag t" and "Diag u"
shows "Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv u"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u \<rbrakk> \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv u"
proof (induct t, simp_all)
fix f u
assume f: "C.ide f \<and> C.arr f"
assume u: "Can u \<and> Diag u"
show "Inv (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv u"
using f u by (cases u, simp_all)
next
fix t u v
assume I1: "\<And>v. \<lbrakk> Diag t; Can v \<and> Diag v \<rbrakk> \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
assume I2: "\<And>v. \<lbrakk> Diag u; Can v \<and> Diag v \<rbrakk> \<Longrightarrow> Inv (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = Inv u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
assume tu: "Can t \<and> Can u \<and> Diag (t \<^bold>\<otimes> u)"
have t: "Can t \<and> Diag t"
using tu Diag_TensorE [of t u] by force
have u: "Can u \<and> Diag u"
using t tu by (cases t, simp_all)
assume v: "Can v \<and> Diag v"
show "Inv ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = (Inv t \<^bold>\<otimes> Inv u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
proof -
have "v = Unity \<Longrightarrow> ?thesis" by simp
moreover have "v \<noteq> Unity \<Longrightarrow> ?thesis"
proof -
assume 1: "v \<noteq> Unity"
have "Inv ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v))"
using 1 by (cases v, simp_all)
also have "... = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
using t u v I1 TensorDiag_preserves_Diag TensorDiag_preserves_Can
Inv_preserves_Diag Inv_preserves_Can
by simp
also have "... = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (Inv u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v)"
using t u v I2 TensorDiag_preserves_Diag TensorDiag_preserves_Can
Inv_preserves_Diag Inv_preserves_Can
by simp
also have "... = (Inv t \<^bold>\<otimes> Inv u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
using v 1 by (cases v, simp_all)
finally show ?thesis by blast
qed
ultimately show ?thesis by blast
qed
qed
thus ?thesis using assms by blast
qed
text\<open>
The following function defines composition for compatible diagonal terms,
by ``pushing the composition down'' to arrows of \<open>C\<close>.
\<close>
fun CompDiag :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term" (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
where "\<^bold>\<I> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = u"
| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>g\<^bold>\<rangle> = \<^bold>\<langle>f \<cdot> g\<^bold>\<rangle>"
| "(u \<^bold>\<otimes> v) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (w \<^bold>\<otimes> x) = (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<^bold>\<otimes> v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
| "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<I> = t"
| "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> _ = undefined \<^bold>\<cdot> undefined"
text\<open>
Note that the last clause above is not relevant to diagonal terms.
We have chosen a provably non-diagonal value in order to validate associativity.
\<close>
lemma CompDiag_preserves_Diag:
assumes "Diag t" and "Diag u" and "Dom t = Cod u"
shows "Diag (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
and "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
and "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
proof -
have 0: "\<And>u. \<lbrakk> Diag t; Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
Diag (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
proof (induct t, simp_all add: Diag_TensorE)
fix f u
assume f: "C.arr f"
assume u: "Diag u"
assume 1: "\<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
show "Diag (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = \<^bold>\<langle>C.cod f\<^bold>\<rangle>"
using f u 1 by (cases u, simp_all)
next
fix u v w
assume I2: "\<And>u. \<lbrakk> Diag u; Dom w = Cod u \<rbrakk> \<Longrightarrow>
Diag (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod w"
assume vw: "Diag (v \<^bold>\<otimes> w)"
have v: "Diag v"
using vw Diag_TensorE [of v w] by force
have w: "Diag w"
using vw Diag_TensorE [of v w] by force
assume u: "Diag u"
assume 1: "(Dom v \<^bold>\<otimes> Dom w) = Cod u"
show "Diag ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
Cod ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod v \<^bold>\<otimes> Cod w"
using u v w 1
proof (cases u, simp_all)
fix x y
assume 2: "u = Tensor x y"
have 4: "is_Prim x \<and> x = \<^bold>\<langle>un_Prim x\<^bold>\<rangle> \<and> C.arr (un_Prim x) \<and> Diag y \<and> y \<noteq> \<^bold>\<I>"
using u 2 by (cases x, cases y, simp_all)
have 5: "is_Prim v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr (un_Prim v) \<and> Diag w \<and> w \<noteq> \<^bold>\<I>"
using v w vw by (cases v, simp_all)
have 6: "C.dom (un_Prim v) = C.cod (un_Prim x) \<and> Dom w = Cod y"
using 1 2 4 5 apply (cases u, simp_all)
by (metis Cod.simps(1) Dom.simps(1) term.simps(1))
have "(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<otimes> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y"
using 2 4 5 6 CompDiag.simps(2) [of "un_Prim v" "un_Prim x"] by simp
moreover have "Diag (\<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<otimes> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
proof -
have "Diag (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
using I2 4 5 6 by simp
thus ?thesis
using 4 5 6 Diag.simps(3) [of "un_Prim v \<cdot> un_Prim x" "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"]
by (cases w; cases y) auto
qed
ultimately show "Diag (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<otimes> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) \<and>
Dom (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Dom x \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Dom y \<and>
Cod (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Cod v \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Cod w"
using 4 5 6 I2
by (metis (full_types) C.cod_comp C.dom_comp Cod.simps(1) CompDiag.simps(2)
Dom.simps(1) C.seqI)
qed
qed
show "Diag (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)" using assms 0 by blast
show "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u" using assms 0 by blast
show "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t" using assms 0 by blast
qed
lemma CompDiag_in_Hom:
assumes "Diag t" and "Diag u" and "Dom t = Cod u"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> Hom (Dom u) (Cod t)"
using assms CompDiag_preserves_Diag Diag_implies_Arr by simp
lemma Dom_CompDiag:
assumes "Diag t" and "Diag u" and "Dom t = Cod u"
shows "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
using assms CompDiag_preserves_Diag(2) by simp
lemma Cod_CompDiag:
assumes "Diag t" and "Diag u" and "Dom t = Cod u"
shows "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
using assms CompDiag_preserves_Diag(3) by simp
lemma CompDiag_Cod_Diag [simp]:
assumes "Diag t"
shows "Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
proof -
have "Diag t \<Longrightarrow> Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
using C.comp_cod_arr
apply (induct t, auto)
by (auto simp add: Diag_TensorE)
thus ?thesis using assms by blast
qed
lemma CompDiag_Diag_Dom [simp]:
assumes "Diag t"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
proof -
have "Diag t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
using C.comp_arr_dom
apply (induct t, auto)
by (auto simp add: Diag_TensorE)
thus ?thesis using assms by blast
qed
lemma CompDiag_Ide_Diag [simp]:
assumes "Diag t" and "Ide a" and "Dom a = Cod t"
shows "a \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
using assms Ide_in_Hom by simp
lemma CompDiag_Diag_Ide [simp]:
assumes "Diag t" and "Ide a" and "Dom t = Cod a"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> a = t"
using assms Ide_in_Hom by auto
lemma CompDiag_assoc:
assumes "Diag t" and "Diag u" and "Diag v"
and "Dom t = Cod u" and "Dom u = Cod v"
shows "(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
proof -
have "\<And>u v. \<lbrakk> Diag t; Diag u; Diag v; Dom t = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
proof (induct t, simp_all)
fix f u v
assume f: "C.arr f"
assume u: "Diag u"
assume v: "Diag v"
assume 1: "\<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
assume 2: "Dom u = Cod v"
show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
using C.comp_assoc by (cases u, simp_all; cases v, simp_all)
next
fix u v w x
assume I1: "\<And>u v. \<lbrakk> Diag w; Diag u; Diag v; Dom w = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume I2: "\<And>u v. \<lbrakk> Diag x; Diag u; Diag v; Dom x = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
(x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume wx: "Diag (w \<^bold>\<otimes> x)"
assume u: "Diag u"
assume v: "Diag v"
assume 1: "(Dom w \<^bold>\<otimes> Dom x) = Cod u"
assume 2: "Dom u = Cod v"
show "((w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = (w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
proof -
have w: "Diag w"
using wx Diag_TensorE by blast
have x: "Diag x"
using wx Diag_TensorE by blast
have "is_Tensor u"
using u 1 by (cases u) simp_all
thus ?thesis
using u v apply (cases u, simp_all, cases v, simp_all)
proof -
fix u1 u2 v1 v2
assume 3: "u = (u1 \<^bold>\<otimes> u2)"
assume 4: "v = (v1 \<^bold>\<otimes> v2)"
show "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<and>
(x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2 = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2"
proof -
have "Diag u1 \<and> Diag u2"
using u 3 Diag_TensorE by blast
moreover have "Diag v1 \<and> Diag v2"
using v 4 Diag_TensorE by blast
ultimately show ?thesis using w x I1 I2 1 2 3 4 by simp
qed
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma CompDiag_preserves_Ide:
assumes "Ide t" and "Ide u" and "Diag t" and "Diag u" and "Dom t = Cod u"
shows "Ide (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
proof -
have "\<And>u. \<lbrakk> Ide t; Ide u; Diag t; Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Ide (CompDiag t u)"
by (induct t; simp)
thus ?thesis using assms by blast
qed
lemma CompDiag_preserves_Can:
assumes "Can t" and "Can u" and "Diag t" and "Diag u" and "Dom t = Cod u"
shows "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
proof (induct t, simp_all)
fix t u v
assume I1: "\<And>v. \<lbrakk> Diag t; Can v \<and> Diag v; Dom t = Cod v \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume I2: "\<And>v. \<lbrakk> Diag u; Can v \<and> Diag v; Dom u = Cod v \<rbrakk> \<Longrightarrow> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
assume tu: "Can t \<and> Can u \<and> Diag (t \<^bold>\<otimes> u)"
have t: "Can t \<and> Diag t"
using tu Diag_TensorE by blast
have u: "Can u \<and> Diag u"
using tu Diag_TensorE by blast
assume v: "Can v \<and> Diag v"
assume 1: "(Dom t \<^bold>\<otimes> Dom u) = Cod v"
show "Can ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
proof -
have 2: "(Dom t \<^bold>\<otimes> Dom u) = Cod v" using 1 by simp
show ?thesis
using v 2
proof (cases v; simp)
fix w x
assume wx: "v = (w \<^bold>\<otimes> x)"
have "Can w \<and> Diag w" using v wx Diag_TensorE [of w x] by auto
moreover have "Can x \<and> Diag x" using v wx Diag_TensorE [of w x] by auto
moreover have "Dom t = Cod w" using 2 wx by simp
moreover have ux: "Dom u = Cod x" using 2 wx by simp
ultimately show "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) \<and> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
using t u I1 I2 by simp
qed
qed
qed
thus ?thesis using assms by blast
qed
lemma Inv_CompDiag:
assumes "Can t" and "Can u" and "Diag t" and "Diag u" and "Dom t = Cod u"
shows "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
proof -
have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
proof (induct t, simp_all)
show "\<And>x u. \<lbrakk> C.ide x \<and> C.arr x; Can u \<and> Diag u; \<^bold>\<langle>x\<^bold>\<rangle> = Cod u \<rbrakk> \<Longrightarrow>
Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
by (metis CompDiag_Diag_Dom Inv_Ide Inv_preserves_Can(2) Inv_preserves_Diag
Ide.simps(1))
show "\<And>u. Can u \<and> Diag u \<Longrightarrow> \<^bold>\<I> = Cod u \<Longrightarrow> Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<I>"
by (simp add: Inv_preserves_Can(2) Inv_preserves_Diag)
fix t u v
assume tu: "Can t \<and> Can u \<and> Diag (t \<^bold>\<otimes> u)"
have t: "Can t \<and> Diag t"
using tu Diag_TensorE by blast
have u: "Can u \<and> Diag u"
using tu Diag_TensorE by blast
assume I1: "\<And>v. \<lbrakk> Diag t; Can v \<and> Diag v; Dom t = Cod v \<rbrakk> \<Longrightarrow>
Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) = Inv v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
assume I2: "\<And>v. \<lbrakk> Diag u; Can v \<and> Diag v; Dom u = Cod v \<rbrakk> \<Longrightarrow>
Inv (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) = Inv v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv u"
assume v: "Can v \<and> Diag v"
assume 1: "(Dom t \<^bold>\<otimes> Dom u) = Cod v"
show "Inv ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) = Inv v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv t \<^bold>\<otimes> Inv u)"
using v 1
proof (cases v, simp_all)
fix w x
assume wx: "v = (w \<^bold>\<otimes> x)"
have "Can w \<and> Diag w" using v wx Diag_TensorE [of w x] by auto
moreover have "Can x \<and> Diag x" using v wx Diag_TensorE [of w x] by auto
moreover have "Dom t = Cod w" using wx 1 by simp
moreover have "Dom u = Cod x" using wx 1 by simp
ultimately show "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) = Inv w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t \<and>
Inv (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv u"
using t u I1 I2 by simp
qed
qed
thus ?thesis using assms by blast
qed
lemma Can_and_Diag_implies_Ide:
assumes "Can t" and "Diag t"
shows "Ide t"
proof -
have "\<lbrakk> Can t; Diag t \<rbrakk> \<Longrightarrow> Ide t"
apply (induct t, simp_all)
by (simp add: Diag_TensorE)
thus ?thesis using assms by blast
qed
lemma CompDiag_Can_Inv [simp]:
assumes "Can t" and "Diag t"
shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t = Cod t"
using assms Can_and_Diag_implies_Ide Ide_in_Hom by simp
lemma CompDiag_Inv_Can [simp]:
assumes "Can t" and "Diag t"
shows "Inv t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = Dom t"
using assms Can_and_Diag_implies_Ide Ide_in_Hom by simp
text\<open>
The next fact is a syntactic version of the interchange law, for diagonal terms.
\<close>
lemma CompDiag_TensorDiag:
assumes "Diag t" and "Diag u" and "Diag v" and "Diag w"
and "Seq t v" and "Seq u w"
shows "(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have "\<And>u v w. \<lbrakk> Diag t; Diag u; Diag v; Diag w; Seq t v; Seq u w \<rbrakk> \<Longrightarrow>
(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof (induct t, simp_all)
fix u v w
assume u: "Diag u"
assume v: "Diag v"
assume w: "Diag w"
assume uw: "Seq u w"
show "Arr v \<and> \<^bold>\<I> = Cod v \<Longrightarrow> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
using u v w uw by (cases v) simp_all
show "\<And>f. \<lbrakk> C.arr f; Arr v \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod v \<rbrakk> \<Longrightarrow>
(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
fix f
assume f: "C.arr f"
assume 1: "Arr v \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod v"
show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have 2: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr (un_Prim v)" using v 1 by (cases v) simp_all
have "u = \<^bold>\<I> \<Longrightarrow> ?thesis"
using v w uw 1 2 Cod.simps(3) CompDiag_Cod_Diag Dom.simps(2)
TensorDiag_Prim TensorDiag_term_Unity TensorDiag_preserves_Diag(3)
by (cases w) simp_all
moreover have "u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
proof -
assume 3: "u \<noteq> \<^bold>\<I>"
hence 4: "w \<noteq> \<^bold>\<I>" using u w uw by (cases u, simp_all; cases w, simp_all)
have "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<otimes> w)"
proof -
have "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u"
using u f 3 TensorDiag_Diag by (cases u) simp_all
moreover have "v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w = v \<^bold>\<otimes> w"
using w 2 4 TensorDiag_Diag by (cases v, simp_all; cases w, simp_all)
ultimately show ?thesis by simp
qed
also have 5: "... = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<otimes> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)" by simp
also have "... = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
using f u w uw 1 2 3 4 5
TensorDiag_Diag TensorDiag_Prim TensorDiag_preserves_Diag(1)
CompDiag_preserves_Diag(1)
by (metis Cod.simps(3) Dom.simps(1) Dom.simps(3) Diag.simps(2))
finally show ?thesis by blast
qed
ultimately show ?thesis by blast
qed
qed
fix t1 t2
assume I2: "\<And>u v w. \<lbrakk> Diag t2; Diag u; Diag v; Diag w;
Arr v \<and> Dom t2 = Cod v; Seq u w \<rbrakk> \<Longrightarrow>
(t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
assume t12: "Diag (t1 \<^bold>\<otimes> t2)"
have t1: "t1 = \<^bold>\<langle>un_Prim t1\<^bold>\<rangle> \<and> C.arr (un_Prim t1) \<and> Diag t1"
using t12 by (cases t1) simp_all
have t2: "Diag t2 \<and> t2 \<noteq> \<^bold>\<I>"
using t12 by (cases t1) simp_all
assume 1: "Arr t1 \<and> Arr t2 \<and> Arr v \<and> Dom t1 \<^bold>\<otimes> Dom t2 = Cod v"
show "((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = ((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have "u = \<^bold>\<I> \<Longrightarrow> ?thesis"
using w uw TensorDiag_term_Unity CompDiag_Cod_Diag by (cases w) simp_all
moreover have "u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
proof -
assume u': "u \<noteq> \<^bold>\<I>"
hence w': "w \<noteq> \<^bold>\<I>" using u w uw by (cases u; simp; cases w; simp)
show ?thesis
using 1 v
proof (cases v, simp_all)
fix v1 v2
assume v12: "v = Tensor v1 v2"
have v1: "v1 = \<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<and> C.arr (un_Prim v1) \<and> Diag v1"
using v v12 by (cases v1) simp_all
have v2: "Diag v2 \<and> v2 \<noteq> \<^bold>\<I>"
using v v12 by (cases v1) simp_all
have 2: "v = (\<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<^bold>\<otimes> v2)"
using v1 v12 by simp
show "((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<otimes> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)
= ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<otimes> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have 3: "(t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = t1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
using u u' by (cases u) simp_all
have 4: "v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w = v1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)"
using v w v1 v2 2 TensorDiag_assoc TensorDiag_Diag by metis
have "((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<otimes> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)
= (t1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w))"
using 3 4 v12 by simp
also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w))"
proof -
have "is_Tensor (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
using t2 u u' not_is_Tensor_TensorDiagE by auto
moreover have "is_Tensor (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)"
using v2 v12 w w' not_is_Tensor_TensorDiagE by auto
ultimately show ?thesis
using u u' v w t1 v1 t12 v12 TensorDiag_Prim not_is_Tensor_Unity
by (metis (no_types, lifting) CompDiag.simps(2) CompDiag.simps(3)
is_Tensor_def)
qed
also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
using u w uw t2 v2 1 2 Diag_implies_Arr I2 by fastforce
also have "... = ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<otimes> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
proof -
have "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<noteq> Unity"
proof -
have "Arr v1 \<and> \<^bold>\<langle>C.dom (un_Prim t1)\<^bold>\<rangle> = Cod v1"
using t1 v1 1 2 by (cases t1, auto)
thus ?thesis
using t1 t2 v1 v2 u w uw u' CompDiag_preserves_Diag
TensorDiag_preserves_Diag TensorDiag_Prim
by (metis (mono_tags, lifting) Cod.simps(2) Cod.simps(3)
TensorDiag.simps(2) term.distinct(3))
qed
hence "((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<otimes> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)
= (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w))"
by (cases "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w") simp_all
thus ?thesis by argo
qed
finally show ?thesis by blast
qed
qed
qed
ultimately show ?thesis by blast
qed
qed
thus ?thesis using assms by blast
qed
text\<open>
The following function reduces an arrow to diagonal form.
The precise relationship between a term and its diagonalization is developed below.
\<close>
fun Diagonalize :: "'a term \<Rightarrow> 'a term" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
where "\<^bold>\<lfloor>\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<rfloor> = \<^bold>\<langle>f\<^bold>\<rangle>"
| "\<^bold>\<lfloor>\<^bold>\<I>\<^bold>\<rfloor> = \<^bold>\<I>"
| "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"
| "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
lemma Diag_Diagonalize:
assumes "Arr t"
shows "Diag \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
proof -
have 0: "Arr t \<Longrightarrow> Diag \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
using TensorDiag_preserves_Diag CompDiag_preserves_Diag TensorDiag_assoc
apply (induct t)
apply auto
apply (metis (full_types))
by (metis (full_types))
show "Diag \<^bold>\<lfloor>t\<^bold>\<rfloor>" using assms 0 by blast
show "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" using assms 0 by blast
show "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>" using assms 0 by blast
qed
lemma Diagonalize_in_Hom:
assumes "Arr t"
shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
using assms Diag_Diagonalize Diag_implies_Arr by blast
lemma Diagonalize_Dom:
assumes "Arr t"
shows "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Diagonalize_in_Hom by simp
lemma Diagonalize_Cod:
assumes "Arr t"
shows "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Diagonalize_in_Hom by simp
lemma Diagonalize_preserves_Ide:
assumes "Ide a"
shows "Ide \<^bold>\<lfloor>a\<^bold>\<rfloor>"
proof -
have "Ide a \<Longrightarrow> Ide \<^bold>\<lfloor>a\<^bold>\<rfloor>"
using Ide_implies_Arr TensorDiag_preserves_Ide Diag_Diagonalize
by (induct a) simp_all
thus ?thesis using assms by blast
qed
text\<open>
The diagonalizations of canonical arrows are identities.
\<close>
lemma Ide_Diagonalize_Can:
assumes "Can t"
shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Can t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using Can_implies_Arr TensorDiag_preserves_Ide Diag_Diagonalize CompDiag_preserves_Ide
TensorDiag_preserves_Diag
by (induct t) auto
thus ?thesis using assms by blast
qed
lemma Diagonalize_preserves_Can:
assumes "Can t"
shows "Can \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Ide_Diagonalize_Can Ide_implies_Can by auto
lemma Diagonalize_Diag [simp]:
assumes "Diag t"
shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
proof -
have "Diag t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
apply (induct t, simp_all)
using TensorDiag_Prim Diag_TensorE by metis
thus ?thesis using assms by blast
qed
lemma Diagonalize_Diagonalize [simp]:
assumes "Arr t"
shows "\<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms Diag_Diagonalize Diagonalize_Diag by blast
lemma Diagonalize_Tensor:
assumes "Arr t" and "Arr u"
shows "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<^bold>\<rfloor>"
using assms Diagonalize_Diagonalize by simp
lemma Diagonalize_Tensor_Unity_Arr [simp]:
assumes "Arr u"
shows "\<^bold>\<lfloor>\<^bold>\<I> \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using assms by simp
lemma Diagonalize_Tensor_Arr_Unity [simp]:
assumes "Arr t"
shows "\<^bold>\<lfloor>t \<^bold>\<otimes> \<^bold>\<I>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms by simp
lemma Diagonalize_Tensor_Prim_Arr [simp]:
assumes "arr f" and "Arr u" and "\<^bold>\<lfloor>u\<^bold>\<rfloor> \<noteq> Unity"
shows "\<^bold>\<lfloor>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using assms by simp
lemma Diagonalize_Tensor_Tensor:
assumes "Arr t" and "Arr u" and "Arr v"
shows "\<^bold>\<lfloor>(t \<^bold>\<otimes> u) \<^bold>\<otimes> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<otimes> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>v\<^bold>\<rfloor>)\<^bold>\<rfloor>"
using assms Diag_Diagonalize Diagonalize_Diagonalize by (simp add: TensorDiag_assoc)
lemma Diagonalize_Comp_Cod_Arr:
assumes "Arr t"
shows "\<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Arr t \<Longrightarrow> \<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using C.comp_cod_arr
apply (induct t, simp_all)
using CompDiag_TensorDiag Arr_implies_Ide_Cod Ide_in_Hom Diag_Diagonalize
Diagonalize_in_Hom
apply simp
using CompDiag_preserves_Diag CompDiag_Cod_Diag Diag_Diagonalize
apply metis
using CompDiag_TensorDiag Arr_implies_Ide_Cod Ide_in_Hom TensorDiag_in_Hom
TensorDiag_preserves_Diag Diag_Diagonalize Diagonalize_in_Hom TensorDiag_assoc
by simp_all
thus ?thesis using assms by blast
qed
lemma Diagonalize_Comp_Arr_Dom:
assumes "Arr t"
shows "\<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Arr t \<Longrightarrow> \<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using C.comp_arr_dom
apply (induct t, simp_all)
using CompDiag_TensorDiag Arr_implies_Ide_Dom Ide_in_Hom Diag_Diagonalize
Diagonalize_in_Hom
apply simp
using CompDiag_preserves_Diag CompDiag_Diag_Dom Diag_Diagonalize
apply metis
using CompDiag_TensorDiag Arr_implies_Ide_Dom Ide_in_Hom TensorDiag_in_Hom
TensorDiag_preserves_Diag Diag_Diagonalize Diagonalize_in_Hom TensorDiag_assoc
by simp_all
thus ?thesis using assms by blast
qed
lemma Diagonalize_Inv:
assumes "Can t"
shows "\<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof -
have "Can t \<Longrightarrow> \<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
proof (induct t, simp_all)
fix u v
assume I1: "\<^bold>\<lfloor>Inv u\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>u\<^bold>\<rfloor>"
assume I2: "\<^bold>\<lfloor>Inv v\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>"
show "Can u \<and> Can v \<Longrightarrow> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
using Inv_TensorDiag Diag_Diagonalize Can_implies_Arr Diagonalize_preserves_Can
I1 I2
by simp
show "Can u \<and> Can v \<and> Dom u = Cod v \<Longrightarrow> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
using Inv_CompDiag Diag_Diagonalize Can_implies_Arr Diagonalize_in_Hom
Diagonalize_preserves_Can I1 I2
by simp
fix w
assume I3: "\<^bold>\<lfloor>Inv w\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>"
assume uvw: "Can u \<and> Can v \<and> Can w"
show "Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>) = Inv ((\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
using uvw I1 I2 I3
Inv_TensorDiag Diag_Diagonalize Can_implies_Arr Diagonalize_preserves_Can
TensorDiag_preserves_Diag TensorDiag_preserves_Can TensorDiag_assoc
by simp
show "(Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>))"
using uvw I1 I2 I3
Inv_TensorDiag Diag_Diagonalize Can_implies_Arr Diagonalize_preserves_Can
TensorDiag_preserves_Diag TensorDiag_preserves_Can
apply simp
using TensorDiag_assoc [of "\<^bold>\<lfloor>u\<^bold>\<rfloor>" "\<^bold>\<lfloor>v\<^bold>\<rfloor>" "\<^bold>\<lfloor>w\<^bold>\<rfloor>"] by metis
qed
thus ?thesis using assms by blast
qed
text\<open>
Our next objective is to begin making the connection, to be completed in a
subsequent section, between arrows and their diagonalizations.
To summarize, an arrow @{term t} and its diagonalization @{term "\<^bold>\<lfloor>t\<^bold>\<rfloor>"} are opposite sides
of a square whose other sides are certain canonical terms
\<open>Dom t\<^bold>\<down> \<in> Hom (Dom t) \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>\<close> and \<open>Cod t\<^bold>\<down> \<in> Hom (Cod t) \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>\<close>,
where \<open>Dom t\<^bold>\<down>\<close> and \<open>Cod t\<^bold>\<down>\<close> are defined by the function \<open>red\<close>
below. The coherence theorem amounts to the statement that every such square commutes
when the formal terms involved are evaluated in the evident way in any monoidal category.
Function \<open>red\<close> defined below takes an identity term @{term a} to a canonical arrow
\<open>a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>\<close>. The auxiliary function \<open>red2\<close> takes a pair @{term "(a, b)"}
of diagonal identity terms and produces a canonical arrow
\<open>a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>\<close>.
The canonical arrow \<open>a\<^bold>\<down>\<close> amounts to a ``parallel innermost reduction''
from @{term a} to @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor>"}, where the reduction steps are canonical arrows
that involve the unitors and associator only in their uninverted forms.
In general, a parallel innermost reduction from @{term a} will not be unique:
at some points there is a choice available between left and right unitors
and at other points there are choices between unitors and associators.
These choices are inessential, and the ordering of the clauses in the function definitions
below resolves them in an arbitrary way. What is more important is having chosen an
innermost reduction, which is what allows us to write these definitions in structurally
recursive form.
The essence of coherence is that the axioms for a monoidal category allow us to
prove that any reduction from @{term a} to @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor>"} is equivalent
(under evaluation of terms) to a parallel innermost reduction.
The problematic cases are terms of the form @{term "((a \<^bold>\<otimes> b) \<^bold>\<otimes> c) \<^bold>\<otimes> d"},
which present a choice between an inner and outer reduction that lead to terms
with different structures. It is of course the pentagon axiom that ensures the
confluence (under evaluation) of the two resulting paths.
Although simple in appearance, the structurally recursive definitions below were
difficult to get right even after I started to understand what I was doing.
I wish I could have just written them down straightaway. If so, then I could have
avoided laboriously constructing and then throwing away thousands of lines of proof
text that used a non-structural, ``operational'' approach to defining a reduction
from @{term a} to @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor>"}.
\<close>
fun red2 (infixr "\<^bold>\<Down>" 53)
where "\<^bold>\<I> \<^bold>\<Down> a = \<^bold>\<l>\<^bold>[a\<^bold>]"
| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> \<^bold>\<I> = \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]"
| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> a = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> a"
| "(a \<^bold>\<otimes> b) \<^bold>\<Down> \<^bold>\<I> = \<^bold>\<r>\<^bold>[a \<^bold>\<otimes> b\<^bold>]"
| "(a \<^bold>\<otimes> b) \<^bold>\<Down> c = (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<^bold>\<cdot> (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
| "a \<^bold>\<Down> b = undefined"
fun red ("_\<^bold>\<down>" [56] 56)
where "\<^bold>\<I>\<^bold>\<down> = \<^bold>\<I>"
| "\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>"
| "(a \<^bold>\<otimes> b)\<^bold>\<down> = (if Diag (a \<^bold>\<otimes> b) then a \<^bold>\<otimes> b else (\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<cdot> (a\<^bold>\<down> \<^bold>\<otimes> b\<^bold>\<down>))"
| "a\<^bold>\<down> = undefined"
lemma red_Diag [simp]:
assumes "Diag a"
shows "a\<^bold>\<down> = a"
using assms by (cases a) simp_all
lemma red2_Diag:
assumes "Diag (a \<^bold>\<otimes> b)"
shows "a \<^bold>\<Down> b = a \<^bold>\<otimes> b"
proof -
have a: "a = \<^bold>\<langle>un_Prim a\<^bold>\<rangle>"
using assms Diag_TensorE by metis
have b: "Diag b \<and> b \<noteq> \<^bold>\<I>"
using assms Diag_TensorE by metis
show ?thesis using a b
apply (cases b)
apply simp_all
apply (metis red2.simps(3))
by (metis red2.simps(4))
qed
lemma Can_red2:
assumes "Ide a" and "Diag a" and "Ide b" and "Diag b"
shows "Can (a \<^bold>\<Down> b)"
and "a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
proof -
have 0: "\<And>b. \<lbrakk> Ide a \<and> Diag a; Ide b \<and> Diag b \<rbrakk> \<Longrightarrow>
Can (a \<^bold>\<Down> b) \<and> a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
proof (induct a, simp_all)
fix b
show "Ide b \<and> Diag b \<Longrightarrow> Can b \<and> Dom b = b \<and> Cod b = b"
using Ide_implies_Can Ide_in_Hom Diagonalize_Diag by auto
fix f
show "\<lbrakk> C.ide f \<and> C.arr f; Ide b \<and> Diag b \<rbrakk> \<Longrightarrow>
Can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Arr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Dom (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b \<and>
Cod (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b"
using Ide_implies_Can Ide_in_Hom by (cases b; auto)
next
fix a b c
assume ab: "Ide a \<and> Ide b \<and> Diag (Tensor a b)"
assume c: "Ide c \<and> Diag c"
assume I1: "\<And>c. \<lbrakk> Diag a; Ide c \<and> Diag c \<rbrakk> \<Longrightarrow>
Can (a \<^bold>\<Down> c) \<and> Arr (a \<^bold>\<Down> c) \<and> Dom (a \<^bold>\<Down> c) = a \<^bold>\<otimes> c \<and>
Cod (a \<^bold>\<Down> c) = a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
assume I2: "\<And>c. \<lbrakk> Diag b; Ide c \<and> Diag c \<rbrakk> \<Longrightarrow>
Can (b \<^bold>\<Down> c) \<and> Arr (b \<^bold>\<Down> c) \<and> Dom (b \<^bold>\<Down> c) = b \<^bold>\<otimes> c \<and>
Cod (b \<^bold>\<Down> c) = b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
show "Can ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) \<and> Arr ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) \<and>
Dom ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = (a \<^bold>\<otimes> b) \<^bold>\<otimes> c \<and>
Cod ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = (\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
proof -
have a: "Diag a \<and> Ide a"
using ab Diag_TensorE by blast
have b: "Diag b \<and> Ide b"
using ab Diag_TensorE by blast
have "c = \<^bold>\<I> \<Longrightarrow> ?thesis"
proof -
assume 1: "c = \<^bold>\<I>"
have 2: "(a \<^bold>\<otimes> b) \<^bold>\<Down> c = \<^bold>\<r>\<^bold>[a \<^bold>\<otimes> b\<^bold>]"
using 1 by simp
have 3: "Can (a \<^bold>\<Down> b) \<and> Arr (a \<^bold>\<Down> b) \<and> Dom (a \<^bold>\<Down> b) = a \<^bold>\<otimes> b \<and> Cod (a \<^bold>\<Down> b) = a \<^bold>\<otimes> b"
using a b ab 1 2 I1 Diagonalize_Diag Diagonalize.simps(3) by metis
hence 4: "Seq (a \<^bold>\<Down> b) \<^bold>\<r>\<^bold>[a \<^bold>\<otimes> b\<^bold>]"
using ab
by (metis (mono_tags, lifting) Arr.simps(7) Cod.simps(3) Cod.simps(7)
Diag_implies_Arr Ide_in_Hom mem_Collect_eq)
have "Can ((a \<^bold>\<otimes> b) \<^bold>\<Down> c)"
using 1 2 3 4 ab by (simp add: Ide_implies_Can)
moreover have "Dom ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = (a \<^bold>\<otimes> b) \<^bold>\<otimes> c"
using 1 2 3 4 a b ab I1 Ide_in_Hom TensorDiag_preserves_Diag by simp
moreover have "Cod ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = \<^bold>\<lfloor>(a \<^bold>\<otimes> b) \<^bold>\<otimes> c\<^bold>\<rfloor>"
using 1 2 3 4 ab using Diagonalize_Diag by fastforce
ultimately show ?thesis using Can_implies_Arr by (simp add: 1 ab)
qed
moreover have "c \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
proof -
assume 1: "c \<noteq> \<^bold>\<I>"
have 2: "(a \<^bold>\<otimes> b) \<^bold>\<Down> c = (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<^bold>\<cdot> (a \<^bold>\<otimes> b \<^bold>\<Down> c) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
using 1 a b ab c by (cases c; simp)
have 3: "Can (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<and> Dom (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor> \<and>
Cod (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = \<^bold>\<lfloor>a \<^bold>\<otimes> (b \<^bold>\<otimes> c)\<^bold>\<rfloor>"
proof -
have "Can (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<and> Dom (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor> \<and>
Cod (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = \<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor>"
using a c ab 1 2 I1 Diag_implies_Arr Diag_Diagonalize(1)
Diagonalize_preserves_Ide TensorDiag_preserves_Ide
TensorDiag_preserves_Diag(1)
by auto
moreover have "\<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>a \<^bold>\<otimes> (b \<^bold>\<otimes> c)\<^bold>\<rfloor>"
using ab c Diagonalize_Tensor Diagonalize_Diagonalize Diag_implies_Arr
by (metis Arr.simps(3) Diagonalize.simps(3))
ultimately show ?thesis by metis
qed
have 4: "Can (b \<^bold>\<Down> c) \<and> Dom (b \<^bold>\<Down> c) = b \<^bold>\<otimes> c \<and> Cod (b \<^bold>\<Down> c) = \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>"
using b c ab 1 2 I2 by simp
hence "Can (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) \<and> Dom (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) = a \<^bold>\<otimes> (b \<^bold>\<otimes> c) \<and>
Cod (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) = a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>"
using ab Ide_implies_Can Ide_in_Hom by force
moreover have "\<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor> = a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)"
using a b c 4
by (metis Arr_implies_Ide_Dom Can_implies_Arr Ide_implies_Arr
Diag_Diagonalize(1) Diagonalize.simps(3) Diagonalize_Diag)
also have "... = (a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
using a b ab c TensorDiag_assoc by metis
also have "... = \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
using a b c by (metis Diagonalize.simps(3) Diagonalize_Diag)
finally show ?thesis by blast
qed
moreover have "Can \<^bold>\<a>\<^bold>[a, b, c\<^bold>] \<and> Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>] = (a \<^bold>\<otimes> b) \<^bold>\<otimes> c \<and>
Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>] = a \<^bold>\<otimes> (b \<^bold>\<otimes> c)"
using ab c Ide_implies_Can Ide_in_Hom by auto
ultimately show ?thesis
using ab c 2 3 4 Diag_implies_Arr Diagonalize_Diagonalize Ide_implies_Can
Diagonalize_Diag Arr_implies_Ide_Dom Can_implies_Arr
by (metis Can.simps(4) Cod.simps(4) Dom.simps(4) Diagonalize.simps(3))
qed
ultimately show ?thesis by blast
qed
qed
show "Can (a \<^bold>\<Down> b)" using assms 0 by blast
show "a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>" using 0 assms by blast
qed
lemma red2_in_Hom:
assumes "Ide a" and "Diag a" and "Ide b" and "Diag b"
shows "a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
using assms Can_red2 Can_implies_Arr by simp
lemma Can_red:
assumes "Ide a"
shows "Can (a\<^bold>\<down>)" and "a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>"
proof -
have 0: "Ide a \<Longrightarrow> Can (a\<^bold>\<down>) \<and> a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>"
proof (induct a, simp_all)
fix b c
assume b: "Can (b\<^bold>\<down>) \<and> Arr (b\<^bold>\<down>) \<and> Dom (b\<^bold>\<down>) = b \<and> Cod (b\<^bold>\<down>) = \<^bold>\<lfloor>b\<^bold>\<rfloor>"
assume c: "Can (c\<^bold>\<down>) \<and> Arr (c\<^bold>\<down>) \<and> Dom (c\<^bold>\<down>) = c \<and> Cod (c\<^bold>\<down>) = \<^bold>\<lfloor>c\<^bold>\<rfloor>"
assume bc: "Ide b \<and> Ide c"
show "(Diag (b \<^bold>\<otimes> c) \<longrightarrow>
Can b \<and> Can c \<and> Dom b = b \<and> Dom c = c \<and> Cod b \<^bold>\<otimes> Cod c = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and>
(\<not> Diag (b \<^bold>\<otimes> c) \<longrightarrow>
Can (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and> Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and>
Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)"
proof
show "Diag (b \<^bold>\<otimes> c) \<longrightarrow>
Can b \<and> Can c \<and> Dom b = b \<and> Dom c = c \<and> Cod b \<^bold>\<otimes> Cod c = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
using bc Diag_TensorE Ide_implies_Can Inv_preserves_Can(2)
CompDiag_Ide_Diag Inv_Ide Diagonalize.simps(3) Diagonalize_Diag
by (metis CompDiag_Inv_Can)
show "\<not> Diag (b \<^bold>\<otimes> c) \<longrightarrow>
Can (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and> Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and>
Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
using b c bc Ide_in_Hom Ide_implies_Can Diagonalize_Diag Can_red2 Diag_Diagonalize
Ide_implies_Arr Diagonalize_Tensor Diagonalize_preserves_Ide
TensorDiag_preserves_Diag TensorDiag_preserves_Ide
TensorDiag_preserves_Can
by (cases b) simp_all
qed
qed
show "Can (a\<^bold>\<down>)" using assms 0 by blast
show "a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>" using assms 0 by blast
qed
lemma red_in_Hom:
assumes "Ide a"
shows "a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>"
using assms Can_red Can_implies_Arr by simp
lemma Diagonalize_red [simp]:
assumes "Ide a"
shows "\<^bold>\<lfloor>a\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>a\<^bold>\<rfloor>"
using assms Can_red Ide_Diagonalize_Can Diagonalize_in_Hom Ide_in_Hom by fastforce
lemma Diagonalize_red2 [simp]:
assumes "Ide a" and "Ide b" and "Diag a" and "Diag b"
shows "\<^bold>\<lfloor>a \<^bold>\<Down> b\<^bold>\<rfloor> = \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
using assms Can_red2 Ide_Diagonalize_Can Diagonalize_in_Hom [of "a \<^bold>\<Down> b"]
red2_in_Hom Ide_in_Hom
by simp
end
section "Coherence"
text\<open>
If @{term D} is a monoidal category, then a functor \<open>V: C \<rightarrow> D\<close> extends
in an evident way to an evaluation map that interprets each formal arrow of the
monoidal language of @{term C} as an arrow of @{term D}.
\<close>
locale evaluation_map =
monoidal_language C +
monoidal_category D T \<alpha> \<iota> +
V: "functor" C D V
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and D :: "'d comp" (infixr "\<cdot>" 55)
and T :: "'d * 'd \<Rightarrow> 'd"
and \<alpha> :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota> :: 'd
and V :: "'c \<Rightarrow> 'd"
begin
no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation unity ("\<I>")
notation runit ("\<r>[_]")
notation lunit ("\<l>[_]")
notation assoc' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
notation runit' ("\<r>\<^sup>-\<^sup>1[_]")
notation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
primrec eval :: "'c term \<Rightarrow> 'd" ("\<lbrace>_\<rbrace>")
where "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = V f"
| "\<lbrace>\<^bold>\<I>\<rbrace> = \<I>"
| "\<lbrace>t \<^bold>\<otimes> u\<rbrace> = \<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>"
| "\<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
| "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<ll> \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<ll>' \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<rho> \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<rho>' \<lbrace>t\<rbrace>"
| "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
| "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>' (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
text\<open>
Identity terms evaluate to identities of \<open>D\<close> and evaluation preserves
domain and codomain.
\<close>
lemma ide_eval_Ide [simp]:
shows "Ide t \<Longrightarrow> ide \<lbrace>t\<rbrace>"
by (induct t, auto)
lemma eval_in_hom:
shows "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
apply (induct t)
apply auto[4]
apply fastforce
proof -
fix t u v
assume I: "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
using I arr_dom_iff_arr [of "\<lbrace>t\<rbrace>"] by force
show "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
using I arr_cod_iff_arr [of "\<lbrace>t\<rbrace>"] by force
show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
using I arr_dom_iff_arr [of "\<lbrace>t\<rbrace>"] by force
assume I1: "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
assume I2: "Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
assume I3: "Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
proof -
assume 1: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
have t: "\<guillemotleft>\<lbrace>t\<rbrace> : dom \<lbrace>t\<rbrace> \<rightarrow> cod \<lbrace>t\<rbrace>\<guillemotright>" using 1 I1 by auto
have u: "\<guillemotleft>\<lbrace>u\<rbrace> : dom \<lbrace>u\<rbrace> \<rightarrow> cod \<lbrace>u\<rbrace>\<guillemotright>" using 1 I2 by auto
have v: "\<guillemotleft>\<lbrace>v\<rbrace> : dom \<lbrace>v\<rbrace> \<rightarrow> cod \<lbrace>v\<rbrace>\<guillemotright>" using 1 I3 by auto
have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
using t u v \<alpha>_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] by auto
moreover have "\<guillemotleft>(\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] :
(dom \<lbrace>t\<rbrace> \<otimes> dom \<lbrace>u\<rbrace>) \<otimes> dom \<lbrace>v\<rbrace> \<rightarrow> cod \<lbrace>t\<rbrace> \<otimes> cod \<lbrace>u\<rbrace> \<otimes> cod \<lbrace>v\<rbrace>\<guillemotright>"
using t u v by (elim in_homE, auto)
moreover have "\<lbrace>Dom t\<rbrace> = dom \<lbrace>t\<rbrace> \<and> \<lbrace>Dom u\<rbrace> = dom \<lbrace>u\<rbrace> \<and> \<lbrace>Dom v\<rbrace> = dom \<lbrace>v\<rbrace> \<and>
\<lbrace>Cod t\<rbrace> = cod \<lbrace>t\<rbrace> \<and> \<lbrace>Cod u\<rbrace> = cod \<lbrace>u\<rbrace> \<and> \<lbrace>Cod v\<rbrace> = cod \<lbrace>v\<rbrace>"
using 1 I1 I2 I3 by auto
ultimately show "\<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
by simp
qed
show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
proof -
assume 1: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
have t: "\<guillemotleft>\<lbrace>t\<rbrace> : dom \<lbrace>t\<rbrace> \<rightarrow> cod \<lbrace>t\<rbrace>\<guillemotright>" using 1 I1 by auto
have u: "\<guillemotleft>\<lbrace>u\<rbrace> : dom \<lbrace>u\<rbrace> \<rightarrow> cod \<lbrace>u\<rbrace>\<guillemotright>" using 1 I2 by auto
have v: "\<guillemotleft>\<lbrace>v\<rbrace> : dom \<lbrace>v\<rbrace> \<rightarrow> cod \<lbrace>v\<rbrace>\<guillemotright>" using 1 I3 by auto
have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
using 1 I1 I2 I3 \<alpha>'_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] by auto
moreover have "\<guillemotleft>((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] :
dom \<lbrace>t\<rbrace> \<otimes> dom \<lbrace>u\<rbrace> \<otimes> dom \<lbrace>v\<rbrace> \<rightarrow> (cod \<lbrace>t\<rbrace> \<otimes> cod \<lbrace>u\<rbrace>) \<otimes> cod \<lbrace>v\<rbrace>\<guillemotright>"
using t u v assoc'_in_hom [of "dom \<lbrace>t\<rbrace>" "dom \<lbrace>u\<rbrace>" "dom \<lbrace>v\<rbrace>"]
by (elim in_homE, auto)
moreover have "\<lbrace>Dom t\<rbrace> = dom \<lbrace>t\<rbrace> \<and> \<lbrace>Dom u\<rbrace> = dom \<lbrace>u\<rbrace> \<and> \<lbrace>Dom v\<rbrace> = dom \<lbrace>v\<rbrace> \<and>
\<lbrace>Cod t\<rbrace> = cod \<lbrace>t\<rbrace> \<and> \<lbrace>Cod u\<rbrace> = cod \<lbrace>u\<rbrace> \<and> \<lbrace>Cod v\<rbrace> = cod \<lbrace>v\<rbrace>"
using 1 I1 I2 I3 by auto
ultimately show " \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
by simp
qed
qed
lemma arr_eval [simp]:
assumes "Arr f"
shows "arr \<lbrace>f\<rbrace>"
using assms eval_in_hom by auto
lemma dom_eval [simp]:
assumes "Arr f"
shows "dom \<lbrace>f\<rbrace> = \<lbrace>Dom f\<rbrace>"
using assms eval_in_hom by auto
lemma cod_eval [simp]:
assumes "Arr f"
shows "cod \<lbrace>f\<rbrace> = \<lbrace>Cod f\<rbrace>"
using assms eval_in_hom by auto
lemma eval_Prim [simp]:
assumes "C.arr f"
shows "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = V f"
by simp
lemma eval_Tensor [simp]:
assumes "Arr t" and "Arr u"
shows "\<lbrace>t \<^bold>\<otimes> u\<rbrace> = \<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>"
using assms eval_in_hom by auto
lemma eval_Comp [simp]:
assumes "Arr t" and "Arr u" and "Dom t = Cod u"
shows " \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
using assms by simp
lemma eval_Lunit [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<I> \<otimes> \<lbrace>t\<rbrace>)"
using assms lunit_naturality [of "\<lbrace>t\<rbrace>"] by simp
lemma eval_Lunit' [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
using assms lunit'_naturality [of "\<lbrace>t\<rbrace>"] \<ll>'.map_simp [of "\<lbrace>t\<rbrace>"] \<ll>_ide_simp
Arr_implies_Ide_Cod
by simp
lemma eval_Runit [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<I>)"
using assms runit_naturality [of "\<lbrace>t\<rbrace>"] by simp
lemma eval_Runit' [simp]:
assumes "Arr t"
shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
using assms runit'_naturality [of "\<lbrace>t\<rbrace>"] \<rho>'.map_simp [of "\<lbrace>t\<rbrace>"] \<rho>_ide_simp
Arr_implies_Ide_Cod
by simp
lemma eval_Assoc [simp]:
assumes "Arr t" and "Arr u" and "Arr v"
shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>)"
using assms \<alpha>.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by auto
lemma eval_Assoc' [simp]:
assumes "Arr t" and "Arr u" and "Arr v"
shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>)"
using assms \<alpha>'_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] assoc'_naturality [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"]
by simp
text\<open>
The following are conveniences for the case of identity arguments
to avoid having to get rid of the extra identities that are introduced by
the general formulas above.
\<close>
lemma eval_Lunit_Ide [simp]:
assumes "Ide a"
shows "\<lbrace>\<^bold>\<l>\<^bold>[a\<^bold>]\<rbrace> = \<l>[\<lbrace>a\<rbrace>]"
using assms comp_cod_arr by simp
lemma eval_Lunit'_Ide [simp]:
assumes "Ide a"
shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>a\<rbrace>]"
using assms comp_cod_arr by simp
lemma eval_Runit_Ide [simp]:
assumes "Ide a"
shows "\<lbrace>\<^bold>\<r>\<^bold>[a\<^bold>]\<rbrace> = \<r>[\<lbrace>a\<rbrace>]"
using assms comp_cod_arr by simp
lemma eval_Runit'_Ide [simp]:
assumes "Ide a"
shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>a\<rbrace>]"
using assms comp_cod_arr by simp
lemma eval_Assoc_Ide [simp]:
assumes "Ide a" and "Ide b" and "Ide c"
shows "\<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace> = \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms by simp
lemma eval_Assoc'_Ide [simp]:
assumes "Ide a" and "Ide b" and "Ide c"
shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using assms \<alpha>'_ide_simp by simp
text\<open>
Canonical arrows evaluate to isomorphisms in \<open>D\<close>, and formal inverses evaluate
to inverses in \<open>D\<close>.
\<close>
lemma iso_eval_Can:
shows "Can t \<Longrightarrow> iso \<lbrace>t\<rbrace>"
using Can_implies_Arr iso_is_arr \<ll>'.preserves_iso \<rho>'.preserves_iso
\<alpha>.preserves_iso \<alpha>'.preserves_iso Arr_implies_Ide_Dom Arr_implies_Ide_Cod
by (induct t, auto)
lemma eval_Inv_Can:
shows "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
apply (induct t)
using iso_eval_Can inv_comp Can_implies_Arr
apply auto[4]
proof -
fix t
assume I: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
show "Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
using I \<ll>'.is_natural_2 [of "inv \<lbrace>t\<rbrace>"] iso_eval_Can \<ll>_ide_simp iso_is_arr
comp_cod_arr inv_comp
by simp
show "Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
using I \<rho>'.is_natural_2 [of "inv \<lbrace>t\<rbrace>"] iso_eval_Can \<rho>_ide_simp iso_is_arr
comp_cod_arr inv_comp
by simp
show "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
proof -
assume t: "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
hence 1: "iso \<lbrace>t\<rbrace>" using iso_eval_Can by simp
have "inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv (\<ll>' \<lbrace>t\<rbrace>)"
using t by simp
also have "... = inv (\<l>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>)"
using 1 \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"] \<ll>'_ide_simp iso_is_arr by auto
also have "... = \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
using t I 1 iso_inv_iso iso_is_arr inv_comp by auto
finally show ?thesis by simp
qed
show "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
proof -
assume t: "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
hence 1: "iso \<lbrace>t\<rbrace>" using iso_eval_Can by simp
have "inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv (\<rho>' \<lbrace>t\<rbrace>)"
using t by simp
also have "... = inv (\<r>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>)"
using 1 \<rho>'.is_natural_2 [of "\<lbrace>t\<rbrace>"] \<rho>'_ide_simp iso_is_arr by auto
also have "... = \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
using t I 1 iso_inv_iso iso_is_arr inv_comp by auto
finally show ?thesis by simp
qed
next
fix t u v
assume I1: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
assume I2: "Can u \<Longrightarrow> \<lbrace>Inv u\<rbrace> = inv \<lbrace>u\<rbrace>"
assume I3: "Can v \<Longrightarrow> \<lbrace>Inv v\<rbrace> = inv \<lbrace>v\<rbrace>"
show "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
proof -
assume tuv: "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
have t: "iso \<lbrace>t\<rbrace>" using tuv iso_eval_Can by auto
have u: "iso \<lbrace>u\<rbrace>" using tuv iso_eval_Can by auto
have v: "iso \<lbrace>v\<rbrace>" using tuv iso_eval_Can by auto
have "\<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>' (inv \<lbrace>t\<rbrace>, inv \<lbrace>u\<rbrace>, inv \<lbrace>v\<rbrace>)"
using tuv I1 I2 I3 by simp
also have "... = inv (\<a>[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>))"
using t u v \<alpha>'_simp iso_is_arr iso_inv_iso inv_comp inv_inv by auto
also have "... = inv ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
using t u v iso_is_arr assoc_naturality by simp
also have "... = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
using t u v iso_is_arr \<alpha>_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] by simp
finally show ?thesis by simp
qed
show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
proof -
assume tuv: "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
have t: "iso \<lbrace>t\<rbrace>" using tuv iso_eval_Can by auto
have u: "iso \<lbrace>u\<rbrace>" using tuv iso_eval_Can by auto
have v: "iso \<lbrace>v\<rbrace>" using tuv iso_eval_Can by auto
have "\<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (inv \<lbrace>t\<rbrace>, inv \<lbrace>u\<rbrace>, inv \<lbrace>v\<rbrace>)"
using tuv I1 I2 I3 by simp
also have "... = (inv \<lbrace>t\<rbrace> \<otimes> inv \<lbrace>u\<rbrace> \<otimes> inv \<lbrace>v\<rbrace>) \<cdot> \<a>[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>]"
using t u v iso_is_arr \<alpha>_simp [of "inv \<lbrace>t\<rbrace>" "inv \<lbrace>u\<rbrace>" "inv \<lbrace>v\<rbrace>"] by simp
also have "... = inv (\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>))"
using t u v iso_is_arr iso_inv_iso inv_inv inv_comp by auto
also have "... = inv (((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
using t u v iso_is_arr assoc'_naturality by simp
also have "... = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
using t u v iso_is_arr \<alpha>'_simp by auto
finally show ?thesis by blast
qed
qed
text\<open>
The operation \<open>\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>\<close> evaluates to composition in \<open>D\<close>.
\<close>
lemma eval_CompDiag:
assumes "Diag t" and "Diag u" and "Seq t u"
shows "\<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
proof -
have "\<And>u. \<lbrakk> Diag t; Diag u; Seq t u \<rbrakk> \<Longrightarrow> \<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
using eval_in_hom comp_cod_arr
proof (induct t, simp_all)
fix u f
assume u: "Diag u"
assume f: "C.arr f"
assume 1: "Arr u \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
show "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = V f \<cdot> \<lbrace>u\<rbrace>"
using f u 1 preserves_comp_2 by (cases u; simp)
next
fix u v w
assume I1: "\<And>u. \<lbrakk> Diag v; Diag u; Arr u \<and> Dom v = Cod u \<rbrakk> \<Longrightarrow>
\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>v\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
assume I2: "\<And>u. \<lbrakk> Diag w; Diag u; Arr u \<and> Dom w = Cod u \<rbrakk> \<Longrightarrow>
\<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>w\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
assume vw: "Diag (Tensor v w)"
have v: "Diag v \<and> v = Prim (un_Prim v)"
using vw by (simp add: Diag_TensorE)
have w: "Diag w"
using vw by (simp add: Diag_TensorE)
assume u: "Diag u"
assume 1: "Arr v \<and> Arr w \<and> Arr u \<and> Dom v \<^bold>\<otimes> Dom w = Cod u"
show "\<lbrace>(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
using u 1 eval_in_hom CompDiag_in_Hom
proof (cases u, simp_all)
fix x y
assume 3: "u = x \<^bold>\<otimes> y"
assume 4: "Arr v \<and> Arr w \<and> Dom v = Cod x \<and> Dom w = Cod y"
have x: "Diag x"
using u 1 3 Diag_TensorE [of x y] by simp
have y: "Diag y"
using u x 1 3 Diag_TensorE [of x y] by simp
show "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<otimes> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<otimes> \<lbrace>y\<rbrace>)"
using v w x y 4 I1 I2 CompDiag_in_Hom eval_in_hom Diag_implies_Arr interchange
by auto
qed
qed
thus ?thesis using assms by blast
qed
text\<open>
For identity terms @{term a} and @{term b}, the reduction @{term "(a \<^bold>\<otimes> b)\<^bold>\<down>"}
factors (under evaluation in \<open>D\<close>) into the parallel reduction @{term "a\<^bold>\<down> \<^bold>\<otimes> b\<^bold>\<down>"},
followed by a reduction of its codomain @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>"}.
\<close>
lemma eval_red_Tensor:
assumes "Ide a" and "Ide b"
shows "\<lbrace>(a \<^bold>\<otimes> b)\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>)"
proof -
have "Diag (a \<^bold>\<otimes> b) \<Longrightarrow> ?thesis"
using assms Can_red2 Ide_implies_Arr red_Diag
Diagonalize_Diag red2_Diag Can_implies_Arr iso_eval_Can iso_is_arr
apply simp
using Diag_TensorE eval_Tensor Diagonalize_Diag Diag_implies_Arr red_Diag
tensor_preserves_ide ide_eval_Ide dom_eval comp_arr_dom
by metis
moreover have "\<not> Diag (a \<^bold>\<otimes> b) \<Longrightarrow> ?thesis"
using assms Can_red2 by (simp add: Can_red(1) iso_eval_Can)
ultimately show ?thesis by blast
qed
lemma eval_red2_Diag_Unity:
assumes "Ide a" and "Diag a"
shows "\<lbrace>a \<^bold>\<Down> \<^bold>\<I>\<rbrace> = \<r>[\<lbrace>a\<rbrace>]"
using assms tensor_preserves_ide \<rho>_ide_simp unitor_coincidence \<iota>_in_hom comp_cod_arr
by (cases a, auto)
text\<open>
Define a formal arrow t to be ``coherent'' if the square formed by @{term t}, @{term "\<^bold>\<lfloor>t\<^bold>\<rfloor>"}
and the reductions @{term "Dom t\<^bold>\<down>"} and @{term "Cod t\<^bold>\<down>"} commutes under evaluation
in \<open>D\<close>. We will show that all formal arrows are coherent.
Since the diagonalizations of canonical arrows are identities, a corollary is that parallel
canonical arrows have equal evaluations.
\<close>
abbreviation coherent
where "coherent t \<equiv> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
text\<open>
Diagonal arrows are coherent, since for such arrows @{term t} the reductions
@{term "Dom t\<^bold>\<down>"} and @{term "Cod t\<^bold>\<down>"} are identities.
\<close>
lemma Diag_implies_coherent:
assumes "Diag t"
shows "coherent t"
using assms Diag_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod
Dom_preserves_Diag Cod_preserves_Diag Diagonalize_Diag red_Diag
comp_arr_dom comp_cod_arr
by simp
text\<open>
The evaluation of a coherent arrow @{term t} has a canonical factorization in \<open>D\<close>
into the evaluations of a reduction @{term "Dom t\<^bold>\<down>"}, diagonalization @{term "\<^bold>\<lfloor>t\<^bold>\<rfloor>"},
and inverse reduction @{term "Inv (Cod t\<^bold>\<down>)"}.
This will later allow us to use the term @{term "Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"}
as a normal form for @{term t}.
\<close>
lemma canonical_factorization:
assumes "Arr t"
shows "coherent t \<longleftrightarrow> \<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
proof
assume 1: "coherent t"
have "inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>"
using 1 by simp
also have "... = (inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>t\<rbrace>"
using comp_assoc by simp
also have "... = \<lbrace>t\<rbrace>"
using assms 1 red_in_Hom inv_in_hom Arr_implies_Ide_Cod Can_red iso_eval_Can
comp_cod_arr Ide_in_Hom inv_is_inverse
by (simp add: comp_inv_arr)
finally show "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
next
assume 1: "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
hence "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
using assms 1 red_in_Hom Arr_implies_Ide_Cod Can_red iso_eval_Can inv_is_inverse
Diagonalize_in_Hom comp_arr_inv comp_cod_arr Arr_implies_Ide_Dom Diagonalize_in_Hom
by auto
finally show "coherent t" by blast
qed
text\<open>
A canonical arrow is coherent if and only if its formal inverse is.
\<close>
lemma Can_implies_coherent_iff_coherent_Inv:
assumes "Can t"
shows "coherent t \<longleftrightarrow> coherent (Inv t)"
proof
have 1: "\<And>t. Can t \<Longrightarrow> coherent t \<Longrightarrow> coherent (Inv t)"
proof -
fix t
assume "Can t"
hence t: "Can t \<and> Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and>
arr \<lbrace>t\<rbrace> \<and> iso \<lbrace>t\<rbrace> \<and> inverse_arrows \<lbrace>t\<rbrace> (inv \<lbrace>t\<rbrace>) \<and>
Can \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Arr \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> arr \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> iso \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
inverse_arrows \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<and> Inv t \<in> Hom (Cod t) (Dom t)"
using assms Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod iso_eval_Can
inv_is_inverse Diagonalize_in_Hom Diagonalize_preserves_Can Inv_in_Hom
by simp
assume coh: "coherent t"
have "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace> = (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<cdot> \<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>"
using t coh red_in_Hom comp_cod_arr Can_implies_Arr Can_red(1) Inv_preserves_Can(1)
Inv_preserves_Can(3) canonical_factorization comp_inv_arr iso_eval_Can iso_is_arr
by auto
also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
using t eval_Inv_Can coh comp_assoc by auto
also have "... = \<lbrace>\<^bold>\<lfloor>Inv t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
using t Diagonalize_Inv eval_Inv_Can comp_arr_inv red_in_Hom comp_arr_dom comp_assoc
by auto
finally show "coherent (Inv t)" by blast
qed
show "coherent t \<Longrightarrow> coherent (Inv t)" using assms 1 by simp
show "coherent (Inv t) \<Longrightarrow> coherent t"
proof -
assume "coherent (Inv t)"
hence "coherent (Inv (Inv t))"
using assms 1 Inv_preserves_Can by blast
thus ?thesis using assms by simp
qed
qed
text\<open>
Some special cases of coherence are readily dispatched.
\<close>
lemma coherent_Unity:
shows "coherent \<^bold>\<I>"
by simp
lemma coherent_Prim:
assumes "Arr \<^bold>\<langle>f\<^bold>\<rangle>"
shows "coherent \<^bold>\<langle>f\<^bold>\<rangle>"
using assms by simp
lemma coherent_Lunit_Ide:
assumes "Ide a"
shows "coherent \<^bold>\<l>\<^bold>[a\<^bold>]"
proof -
have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
thus ?thesis
using a lunit_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>"] comp_cod_arr by auto
qed
lemma coherent_Runit_Ide:
assumes "Ide a"
shows "coherent \<^bold>\<r>\<^bold>[a\<^bold>]"
proof -
have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom
by auto
have "\<lbrace>Cod \<^bold>\<r>\<^bold>[a\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<r>\<^bold>[a\<^bold>]\<rbrace> = \<lbrace>a\<^bold>\<down>\<rbrace> \<cdot> \<r>[\<lbrace>a\<rbrace>]"
using a runit_in_hom comp_cod_arr by simp
also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<I>)"
using a eval_Runit runit_naturality [of "\<lbrace>red a\<rbrace>"] by auto
also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[a\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[a\<^bold>]\<^bold>\<down>\<rbrace>"
proof -
have "\<not> Diag (a \<^bold>\<otimes> \<^bold>\<I>)" by (cases a; simp)
thus ?thesis
using a comp_cod_arr red2_in_Hom eval_red2_Diag_Unity Diag_Diagonalize
Diagonalize_preserves_Ide
by auto
qed
finally show ?thesis by blast
qed
lemma coherent_Lunit'_Ide:
assumes "Ide a"
shows "coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
using assms Ide_implies_Can coherent_Lunit_Ide
Can_implies_coherent_iff_coherent_Inv [of "Lunit a"] by simp
lemma coherent_Runit'_Ide:
assumes "Ide a"
shows "coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
using assms Ide_implies_Can coherent_Runit_Ide
Can_implies_coherent_iff_coherent_Inv [of "Runit a"] by simp
text\<open>
To go further, we need the next result, which is in some sense the crux of coherence:
For diagonal identities @{term a}, @{term b}, and @{term c},
the reduction @{term "((a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c) \<^bold>\<cdot> ((a \<^bold>\<Down> b) \<^bold>\<otimes> c)"} from @{term "(a \<^bold>\<otimes> b) \<^bold>\<otimes> c"}
that first reduces the subterm @{term "a \<^bold>\<otimes> b"} and then reduces the result,
is equivalent under evaluation in \<open>D\<close> to the reduction that first
applies the associator @{term "\<^bold>\<a>\<^bold>[a, b, c\<^bold>]"} and then applies the reduction
@{term "(a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (a \<^bold>\<otimes> (b \<^bold>\<Down> c))"} from @{term "a \<^bold>\<otimes> (b \<^bold>\<otimes> c)"}.
The triangle and pentagon axioms are used in the proof.
\<close>
lemma coherence_key_fact:
assumes "Ide a \<and> Diag a" and "Ide b \<and> Diag b" and "Ide c \<and> Diag c"
shows "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "b = \<^bold>\<I> \<Longrightarrow> ?thesis"
using assms not_is_Tensor_TensorDiagE eval_red2_Diag_Unity triangle
comp_cod_arr comp_assoc
by simp
text \<open>The triangle is used!\<close>
moreover have "c = \<^bold>\<I> \<Longrightarrow> ?thesis"
using assms TensorDiag_preserves_Diag TensorDiag_preserves_Ide
not_is_Tensor_TensorDiagE eval_red2_Diag_Unity
red2_in_Hom runit_tensor runit_naturality [of "\<lbrace>a \<^bold>\<Down> b\<rbrace>"] comp_assoc
by simp
moreover have "\<lbrakk> b \<noteq> \<^bold>\<I>; c \<noteq> \<^bold>\<I> \<rbrakk> \<Longrightarrow> ?thesis"
proof -
assume b': "b \<noteq> \<^bold>\<I>"
hence b: "Ide b \<and> Diag b \<and> Arr b \<and> b \<noteq> \<^bold>\<I> \<and>
ide \<lbrace>b\<rbrace> \<and> arr \<lbrace>b\<rbrace> \<and> \<^bold>\<lfloor>b\<^bold>\<rfloor> = b \<and> b\<^bold>\<down> = b \<and> Dom b = b \<and> Cod b = b"
using assms Diagonalize_preserves_Ide Ide_in_Hom by simp
assume c': "c \<noteq> \<^bold>\<I>"
hence c: "Ide c \<and> Diag c \<and> Arr c \<and> c \<noteq> \<^bold>\<I> \<and>
ide \<lbrace>c\<rbrace> \<and> arr \<lbrace>c\<rbrace> \<and> \<^bold>\<lfloor>c\<^bold>\<rfloor> = c \<and> c\<^bold>\<down> = c \<and> Dom c = c \<and> Cod c = c"
using assms Diagonalize_preserves_Ide Ide_in_Hom by simp
have "\<And>a. Ide a \<and> Diag a \<Longrightarrow>
\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
fix a :: "'c term"
show "Ide a \<and> Diag a \<Longrightarrow>
\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
apply (induct a)
using b c TensorDiag_in_Hom apply simp_all
proof -
show "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>b\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)
= ((\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> \<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>]) \<cdot> (\<I> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<I>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>] \<cdot> (\<I> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<I>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] =
\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<otimes> \<lbrace>c\<rbrace>]) \<cdot> \<a>[\<I>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using b c red2_in_Hom lunit_naturality [of "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] by simp
thus ?thesis
using b c red2_in_Hom lunit_tensor comp_arr_dom comp_cod_arr comp_assoc by simp
qed
show "\<And>f. C.ide f \<and> C.arr f \<Longrightarrow>
\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
fix f
assume f: "C.ide f \<and> C.arr f"
show "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= ((V f \<otimes> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
((V f \<otimes> \<lbrace>b\<rbrace>) \<otimes> \<lbrace>c\<rbrace>)"
proof -
have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> = V f \<otimes> \<lbrace>b\<rbrace>"
using assms f b c red2_Diag by simp
moreover have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> = V f \<otimes> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>"
proof -
have "is_Tensor (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)"
using assms b c not_is_Tensor_TensorDiagE by blast
thus ?thesis
using assms f b c red2_Diag TensorDiag_preserves_Diag(1)
by (cases "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"; simp)
qed
ultimately show ?thesis
using assms b c by (cases c, simp_all)
qed
also have "... = ((V f \<otimes> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using b c f TensorDiag_in_Hom red2_in_Hom comp_arr_dom comp_cod_arr
by simp
also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using b c f Ide_implies_Arr TensorDiag_preserves_Ide not_is_Tensor_TensorDiagE
by (cases "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c", simp_all; blast)
finally show ?thesis by blast
qed
qed
fix d e
assume I: "Diag e \<Longrightarrow> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>e\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
assume de: "Ide d \<and> Ide e \<and> Diag (d \<^bold>\<otimes> e)"
show "\<lbrace>((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>) \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
let ?f = "un_Prim d"
have "is_Prim d"
using de by (cases d, simp_all)
hence "d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f"
using de by (cases d, simp_all)
hence d: "Ide d \<and> Arr d \<and> Dom d = d \<and> Cod d = d \<and> Diag d \<and>
d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f \<and> ide \<lbrace>d\<rbrace> \<and> arr \<lbrace>d\<rbrace>"
using de ide_eval_Ide Ide_implies_Arr Diag_Diagonalize(1) Ide_in_Hom
Diag_TensorE [of d e]
by simp
have "Diag e \<and> e \<noteq> \<^bold>\<I>"
using de Diag_TensorE by metis
hence e: "Ide e \<and> Arr e \<and> Dom e = e \<and> Cod e = e \<and> Diag e \<and>
e \<noteq> \<^bold>\<I> \<and> ide \<lbrace>e\<rbrace> \<and> arr \<lbrace>e\<rbrace>"
using de Ide_in_Hom by simp
have 1: "is_Tensor (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<and> is_Tensor (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c) \<and> is_Tensor (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))"
using b c e de not_is_Tensor_TensorDiagE TensorDiag_preserves_Diag
not_is_Tensor_TensorDiagE [of e "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"]
by auto
have "\<lbrace>((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
= ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
proof -
have "\<lbrace>((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>
= (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<Down> c"
using b c d e de 1 TensorDiag_Diag TensorDiag_preserves_Diag TensorDiag_assoc
TensorDiag_Prim not_is_Tensor_Unity
by metis
also have "... = (d \<^bold>\<Down> (\<^bold>\<lfloor>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<otimes> ((e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b, c\<^bold>]"
using c d 1 by (cases c) simp_all
also have "... = (d \<^bold>\<otimes> ((e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<otimes> ((e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b, c\<^bold>]"
using b c d e 1 TensorDiag_preserves_Diag Diagonalize_Diag
red2_Diag TensorDiag_assoc
by (cases "e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c", simp_all, cases d, simp_all)
finally show ?thesis
using b c d e TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Diag
TensorDiag_preserves_Ide
by simp
qed
moreover have "\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> b\<rbrace>
= (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]"
proof -
have "(d \<^bold>\<otimes> e) \<^bold>\<Down> b = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
using b c d e de 1 TensorDiag_Prim Diagonalize_Diag
by (cases b) simp_all
also have "... = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
using b c d e de 1 TensorDiag_Diag TensorDiag_preserves_Diag
by (cases "e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b", simp_all, cases d, simp_all)
finally have "(d \<^bold>\<otimes> e) \<^bold>\<Down> b = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
by simp
thus ?thesis using b d e eval_in_hom TensorDiag_in_Hom red2_in_Hom by simp
qed
ultimately show ?thesis by argo
qed
also have "... = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot>
((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<otimes> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
using b c d e red2_in_Hom TensorDiag_preserves_Ide
TensorDiag_preserves_Diag interchange comp_cod_arr comp_assoc
by simp
also have "... = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
using b c d e TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Ide
TensorDiag_preserves_Diag assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<lbrace>c\<rbrace>"]
comp_permute [of "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]" "(\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<otimes> \<lbrace>c\<rbrace>"
"\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"]
by simp
also have "... = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
using b c d e TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Ide
TensorDiag_preserves_Diag interchange
comp_reduce [of "\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>"
"\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)"
"\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)"
"\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"]
by simp
also have "... = (((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
(\<lbrace>d\<rbrace> \<otimes> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>])) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
using b c d e I TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Ide
TensorDiag_preserves_Diag interchange
by simp
also have "... = ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>))) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<otimes> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using b c d e comp_assoc red2_in_Hom TensorDiag_in_Hom ide_eval_Ide
TensorDiag_preserves_Diag tensor_preserves_ide TensorDiag_preserves_Ide
pentagon
by simp
text \<open>The pentagon is used!\<close>
also have "... = (((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>]) \<cdot> ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>) \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using b c d e 1 red2_in_Hom TensorDiag_preserves_Ide
TensorDiag_preserves_Diag assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e\<rbrace>" "\<lbrace>b \<^bold>\<Down> c\<rbrace>"]
comp_cod_arr comp_assoc
by simp
also have "... = (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>) \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
\<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
proof -
have "\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>
= (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>]"
proof -
have "(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)
= (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>\<rfloor>)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
using b c e not_is_Tensor_TensorDiagE
by (cases "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c") auto
also have "... = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
using b c d e 1 TensorDiag_preserves_Diag Diagonalize_Diag by simp
also have "... = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
using b c d e 1 TensorDiag_preserves_Diag(1) red2_Diag not_is_Tensor_Unity
by (cases d, simp_all, cases "e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c", simp_all)
finally have "(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)
= (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
by blast
thus ?thesis
using b c d e red2_in_Hom TensorDiag_in_Hom TensorDiag_preserves_Diag
TensorDiag_preserves_Ide
by simp
qed
thus ?thesis using d e b c by simp
qed
finally show ?thesis by simp
qed
qed
qed
thus ?thesis using assms(1) by blast
qed
ultimately show ?thesis by blast
qed
lemma coherent_Assoc_Ide:
assumes "Ide a" and "Ide b" and "Ide c"
shows "coherent \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
proof -
have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<guillemotleft>\<lbrace>a\<^bold>\<down>\<rbrace> : \<lbrace>a\<rbrace> \<rightarrow> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>\<guillemotright>"
using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
have b: "Ide b \<and> Arr b \<and> Dom b = b \<and> Cod b = b \<and>
ide \<lbrace>b\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<and> \<guillemotleft>\<lbrace>b\<^bold>\<down>\<rbrace> : \<lbrace>b\<rbrace> \<rightarrow> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>\<guillemotright>"
using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
have c: "Ide c \<and> Arr c \<and> Dom c = c \<and> Cod c = c \<and>
ide \<lbrace>c\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<and> \<guillemotleft>\<lbrace>c\<^bold>\<down>\<rbrace> : \<lbrace>c\<rbrace> \<rightarrow> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>\<guillemotright>"
using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
have "\<lbrace>Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace>
= (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<otimes> (\<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot>
(\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
using a b c red_in_Hom red2_in_Hom Diagonalize_in_Hom Diag_Diagonalize
Diagonalize_preserves_Ide interchange Ide_in_Hom eval_red_Tensor
comp_cod_arr [of "\<lbrace>a\<^bold>\<down>\<rbrace>"]
by simp
also have "... = ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot>
\<a>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>]) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>) \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)"
using a b c red_in_Hom Diag_Diagonalize TensorDiag_preserves_Diag
assoc_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>" "\<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"] comp_assoc
by simp
also have "... = (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot>
((\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>) \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)"
using a b c Diag_Diagonalize Diagonalize_preserves_Ide coherence_key_fact by simp
also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace>"
using a b c red_in_Hom red2_in_Hom TensorDiag_preserves_Diag
Diagonalize_preserves_Ide TensorDiag_preserves_Ide Diag_Diagonalize interchange
eval_red_Tensor TensorDiag_assoc comp_cod_arr [of "\<lbrace>c\<^bold>\<down>\<rbrace>"]
comp_cod_arr [of "\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>) \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)"]
comp_assoc
by simp
finally show ?thesis by blast
qed
lemma coherent_Assoc'_Ide:
assumes "Ide a" and "Ide b" and "Ide c"
shows "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]"
proof -
have "Can \<^bold>\<a>\<^bold>[a, b, c\<^bold>]" using assms Ide_implies_Can by simp
moreover have "\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>] = Inv \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
using assms Inv_Ide by simp
ultimately show ?thesis
using assms Ide_implies_Can coherent_Assoc_Ide Inv_Ide
Can_implies_coherent_iff_coherent_Inv
by metis
qed
text\<open>
The next lemma implies coherence for the special case of a term that is the tensor
of two diagonal arrows.
\<close>
lemma eval_red2_naturality:
assumes "Diag t" and "Diag u"
shows "\<lbrace>Cod t \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) = \<lbrace>t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom t \<^bold>\<Down> Dom u\<rbrace>"
proof -
have *: "\<And>t u. Diag (t \<^bold>\<otimes> u) \<Longrightarrow> arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>u\<rbrace>"
using Diag_implies_Arr by force
have "t = \<^bold>\<I> \<Longrightarrow> ?thesis"
using assms Diag_implies_Arr lunit_naturality [of "\<lbrace>u\<rbrace>"]
Arr_implies_Ide_Dom Arr_implies_Ide_Cod comp_cod_arr
by simp
moreover have "t \<noteq> \<^bold>\<I> \<and> u = \<^bold>\<I> \<Longrightarrow> ?thesis"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod
Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
eval_red2_Diag_Unity runit_naturality [of "\<lbrace>t\<rbrace>"]
by simp
moreover have "t \<noteq> \<^bold>\<I> \<and> u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
using assms * Arr_implies_Ide_Dom Arr_implies_Ide_Cod
Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
apply (induct t, simp_all)
proof -
fix f
assume f: "C.arr f"
assume "u \<noteq> \<^bold>\<I>"
hence u: "u \<noteq> \<^bold>\<I> \<and>
Diag u \<and> Diag (Dom u) \<and> Diag (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms(2) Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
Arr_implies_Ide_Dom Arr_implies_Ide_Cod
by simp
hence 1: "Dom u \<noteq> \<^bold>\<I> \<and> Cod u \<noteq> \<^bold>\<I>" using u by (cases u, simp_all)
show "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> \<cdot> (V f \<otimes> \<lbrace>u\<rbrace>) = (V f \<otimes> \<lbrace>u\<rbrace>) \<cdot> \<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace>"
using f u 1 Diag_implies_Arr red2_Diag comp_arr_dom comp_cod_arr by simp
next
fix v w
assume I2: "\<lbrakk> w \<noteq> Unity; Diag w \<rbrakk> \<Longrightarrow>
\<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>w\<rbrace> \<otimes> \<lbrace>u\<rbrace>) = \<lbrace>w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"
assume "u \<noteq> \<^bold>\<I>"
hence u: "u \<noteq> \<^bold>\<I> \<and> Arr u \<and> Arr (Dom u) \<and> Arr (Cod u) \<and>
Diag u \<and> Diag (Dom u) \<and> Diag (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms(2) Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
Arr_implies_Ide_Dom Arr_implies_Ide_Cod
by simp
assume vw: "Diag (v \<^bold>\<otimes> w)"
let ?f = "un_Prim v"
have "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f"
using vw by (metis Diag_TensorE(1) Diag_TensorE(2))
hence "Arr v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr ?f \<and> Diag v" by (cases v; simp)
hence v: "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f \<and> Arr v \<and> Ide (Dom v) \<and> Ide (Cod v) \<and> Diag v \<and>
Diag (Dom v) \<and> arr \<lbrace>v\<rbrace> \<and> arr \<lbrace>Dom v\<rbrace> \<and> arr \<lbrace>Cod v\<rbrace> \<and>
ide \<lbrace>Dom v\<rbrace> \<and> ide \<lbrace>Cod v\<rbrace>"
by (cases v, simp_all)
have "Diag w \<and> w \<noteq> \<^bold>\<I>"
using vw v by (metis Diag.simps(3))
hence w: "w \<noteq> \<^bold>\<I> \<and> Arr w \<and> Arr (Dom w) \<and> Arr (Cod w) \<and>
Diag w \<and> Diag (Dom w) \<and> Diag (Cod w) \<and>
Ide (Dom w) \<and> Ide (Cod w) \<and>
arr \<lbrace>w\<rbrace> \<and> arr \<lbrace>Dom w\<rbrace> \<and> arr \<lbrace>Cod w\<rbrace> \<and> ide \<lbrace>Dom w\<rbrace> \<and> ide \<lbrace>Cod w\<rbrace>"
using vw * Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag Arr_implies_Ide_Dom
Arr_implies_Ide_Cod ide_eval_Ide Ide_implies_Arr Ide_in_Hom
by simp
show "\<lbrace>(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)
= \<lbrace>(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
proof -
have u': "Dom u \<noteq> \<^bold>\<I> \<and> Cod u \<noteq> \<^bold>\<I>" using u by (cases u) simp_all
have w': "Dom w \<noteq> \<^bold>\<I> \<and> Cod w \<noteq> \<^bold>\<I>" using w by (cases w) simp_all
have D: "Diag (Dom v \<^bold>\<otimes> (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u))"
proof -
have "Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<noteq> \<^bold>\<I>"
using u u' w w' not_is_Tensor_TensorDiagE by blast
moreover have "Diag (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u)"
using u w TensorDiag_preserves_Diag by simp
moreover have "Dom v = \<^bold>\<langle>C.dom ?f\<^bold>\<rangle>"
using v by (cases v, simp_all)
ultimately show ?thesis
using u v w TensorDiag_preserves_Diag by auto
qed
have C: "Diag (Cod v \<^bold>\<otimes> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u))"
proof -
have "Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u \<noteq> \<^bold>\<I>"
using u u' w w' not_is_Tensor_TensorDiagE by blast
moreover have "Diag (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)"
using u w TensorDiag_preserves_Diag by simp
moreover have "Cod v = \<^bold>\<langle>C.cod ?f\<^bold>\<rangle>"
using v by (cases v, simp_all)
ultimately show ?thesis
using u v w by (cases "Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u", simp_all)
qed
have "\<lbrace>(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)
= (\<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
\<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)"
proof -
have "(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u
= (Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Cod v \<^bold>\<otimes> Cod w \<^bold>\<Down> Cod u) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[Cod v, Cod w, Cod u\<^bold>]"
using u v w by (cases u, simp_all)
hence "\<lbrace>(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u\<rbrace>
= \<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
\<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
using u v w by simp
thus ?thesis by argo
qed
also have "... = ((\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
\<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)"
using u v w C red2_Diag by simp
also have "... = ((\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot>
((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)"
proof -
have "(\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>)
= \<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>"
using u v w comp_cod_arr red2_in_Hom by simp
moreover have
"seq (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u\<rbrace>) (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>)"
using u v w red2_in_Hom TensorDiag_in_Hom Ide_in_Hom by simp
moreover have "seq (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
using u v w red2_in_Hom by simp
ultimately show ?thesis
using u v w comp_reduce by presburger
qed
also have
"... = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u v w I2 red2_in_Hom TensorDiag_in_Hom interchange comp_reduce
assoc_naturality [of "\<lbrace>v\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>u\<rbrace>"] comp_cod_arr comp_assoc
by simp
also have "... = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u v w red2_in_Hom TensorDiag_in_Hom interchange comp_reduce comp_arr_dom
by simp
also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u u' v w not_is_Tensor_TensorDiagE TensorDiag_Prim [of "w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u" ?f]
by force
also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
(\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
proof -
have
"\<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>] =
(\<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace>) \<cdot>
(\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using u v w comp_arr_dom TensorDiag_in_Hom TensorDiag_preserves_Diag by simp
also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
(\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using comp_assoc by simp
finally show ?thesis by blast
qed
also have "... = \<lbrace>(v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
proof -
have
"\<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>
= \<lbrace>Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u)\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
proof -
have "(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u
= (Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Dom v \<^bold>\<otimes> (Dom w \<^bold>\<Down> Dom u)) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[Dom v, Dom w, Dom u\<^bold>]"
using u u' v w red2_in_Hom TensorDiag_in_Hom tensor_in_hom Ide_in_Hom
by (cases u, simp_all)
thus ?thesis
using u v w red2_in_Hom by simp
qed
also have
"... = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
using D TensorDiag_Diag red2_Diag by simp
finally have
"\<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>
= \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
\<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
by blast
thus ?thesis
using assms v w TensorDiag_assoc by auto
qed
finally show ?thesis
using vw TensorDiag_Diag by simp
qed
qed
ultimately show ?thesis by blast
qed
lemma Tensor_preserves_coherent:
assumes "Arr t" and "Arr u" and "coherent t" and "coherent u"
shows "coherent (t \<^bold>\<otimes> u)"
proof -
have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
by auto
have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
by auto
have "\<lbrace>Cod (t \<^bold>\<otimes> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>)
= (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Cod u\<^bold>\<down>\<rbrace>)) \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>)"
using t u eval_red_Tensor by simp
also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Cod u\<^bold>\<down>\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>)"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using assms t u Diagonalize_in_Hom red_in_Hom interchange by simp
also have "... = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>)) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using comp_assoc by simp
also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using assms t u Diag_Diagonalize Diagonalize_in_Hom
eval_red2_naturality [of "Diagonalize t" "Diagonalize u"]
by simp
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
using comp_assoc by simp
also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<otimes> Dom u)\<^bold>\<down>\<rbrace>"
using t u eval_red_Tensor by simp
finally have "\<lbrace>Cod (t \<^bold>\<otimes> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<otimes> Dom u)\<^bold>\<down>\<rbrace>"
by blast
thus ?thesis using t u by simp
qed
lemma Comp_preserves_coherent:
assumes "Arr t" and "Arr u" and "Dom t = Cod u"
and "coherent t" and "coherent u"
shows "coherent (t \<^bold>\<cdot> u)"
proof -
have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
by auto
have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
by auto
have "\<lbrace>Cod (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
using t u by simp
also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
proof -
(* TODO: I still haven't figured out how to do this without spoon-feeding it. *)
have "seq \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<lbrace>t\<rbrace>"
using assms t red_in_Hom by (intro seqI, auto)
moreover have "seq \<lbrace>t\<rbrace> \<lbrace>u\<rbrace>"
using assms t u by auto
ultimately show ?thesis using comp_assoc by auto
qed
also have "... = \<lbrace>\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace>"
using t u assms red_in_Hom Diag_Diagonalize comp_assoc
by (simp add: Diag_implies_Arr eval_CompDiag)
finally show "coherent (t \<^bold>\<cdot> u)" by blast
qed
text\<open>
The main result: ``Every formal arrow is coherent.''
\<close>
theorem coherence:
assumes "Arr t"
shows "coherent t"
proof -
have "Arr t \<Longrightarrow> coherent t"
proof (induct t)
fix u v
show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<otimes> v)
\<Longrightarrow> coherent (u \<^bold>\<otimes> v)"
using Tensor_preserves_coherent by simp
show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<cdot> v)
\<Longrightarrow> coherent (u \<^bold>\<cdot> v)"
using Comp_preserves_coherent by simp
next
show "coherent \<^bold>\<I>" by simp
fix f
show "Arr \<^bold>\<langle>f\<^bold>\<rangle> \<Longrightarrow> coherent \<^bold>\<langle>f\<^bold>\<rangle>" by simp
next
fix t
assume I: "Arr t \<Longrightarrow> coherent t"
show Lunit: "Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
using I Arr_implies_Ide_Dom coherent_Lunit_Ide Ide_in_Hom Ide_implies_Arr
Comp_preserves_coherent [of t "\<^bold>\<l>\<^bold>[Dom t\<^bold>]"] Diagonalize_Comp_Arr_Dom \<ll>_ide_simp
by auto
show Runit: "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
using I Arr_implies_Ide_Dom coherent_Runit_Ide Ide_in_Hom Ide_implies_Arr
Comp_preserves_coherent [of t "\<^bold>\<r>\<^bold>[Dom t\<^bold>]"] Diagonalize_Comp_Arr_Dom \<rho>_ide_simp
by auto
show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
proof -
assume "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
hence t: "Arr t" by simp
have "coherent (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
using t I Arr_implies_Ide_Cod coherent_Lunit'_Ide Ide_in_Hom
Comp_preserves_coherent [of "\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
by fastforce
thus ?thesis
using t Arr_implies_Ide_Cod Ide_implies_Arr Ide_in_Hom Diagonalize_Comp_Cod_Arr
eval_in_hom \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
by force
qed
show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
proof -
assume "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
hence t: "Arr t" by simp
have "coherent (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
using t I Arr_implies_Ide_Cod coherent_Runit'_Ide Ide_in_Hom
Comp_preserves_coherent [of "\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
by fastforce
thus ?thesis
using t Arr_implies_Ide_Cod Ide_implies_Arr Ide_in_Hom Diagonalize_Comp_Cod_Arr
eval_in_hom \<rho>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
by force
qed
next
fix t u v
assume I1: "Arr t \<Longrightarrow> coherent t"
assume I2: "Arr u \<Longrightarrow> coherent u"
assume I3: "Arr v \<Longrightarrow> coherent v"
show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
proof -
assume tuv: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
have t: "Arr t" using tuv by simp
have u: "Arr u" using tuv by simp
have v: "Arr v" using tuv by simp
have "coherent ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
proof -
have "Arr (t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<and> coherent (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
proof
have 1: "Arr t \<and> coherent t" using t I1 by simp
have 2: "Arr (u \<^bold>\<otimes> v) \<and> coherent (u \<^bold>\<otimes> v)"
using u v I2 I3 Tensor_preserves_coherent by force
show "Arr (t \<^bold>\<otimes> u \<^bold>\<otimes> v) " using 1 2 by simp
show "coherent (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
using 1 2 Tensor_preserves_coherent by blast
qed
moreover have "Arr \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v Arr_implies_Ide_Dom by simp
moreover have "coherent \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v Arr_implies_Ide_Dom coherent_Assoc_Ide by blast
moreover have "Dom (t \<^bold>\<otimes> u \<^bold>\<otimes> v) = Cod \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v Arr_implies_Ide_Dom Ide_in_Hom by simp
ultimately show ?thesis
using t u v Arr_implies_Ide_Dom Ide_implies_Arr
Comp_preserves_coherent [of "t \<^bold>\<otimes> u \<^bold>\<otimes> v" "\<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"]
by blast
qed
moreover have "Par \<^bold>\<a>\<^bold>[t, u, v\<^bold>] ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
using t u v Arr_implies_Ide_Dom Ide_implies_Arr Ide_in_Hom by simp
moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>(t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
proof -
have "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>
= (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>)"
proof -
have 1: "Diag \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Diag \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Diag \<^bold>\<lfloor>v\<^bold>\<rfloor> \<and>
Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>"
using t u v Diag_Diagonalize by blast
moreover have "Diag (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>)"
using 1 TensorDiag_preserves_Diag(1) by blast
moreover have "\<And>t. Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using t Diagonalize_Comp_Arr_Dom by simp
moreover have "Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor>"
using Diag_Diagonalize tuv by blast
ultimately show ?thesis
using t u v tuv 1 TensorDiag_assoc TensorDiag_preserves_Diag(2)
by (metis (no_types) Diagonalize.simps(9))
qed
thus ?thesis
using t u v Diagonalize_Comp_Arr_Dom CompDiag_TensorDiag Diag_Diagonalize
by simp
qed
moreover have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>(t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
using t u v Arr_implies_Ide_Dom Ide_implies_Arr \<alpha>_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"]
by simp
ultimately show "coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]" by argo
qed
show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
proof -
assume tuv: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
have t: "Arr t" using tuv by simp
have u: "Arr u" using tuv by simp
have v: "Arr v" using tuv by simp
have "coherent (((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
proof -
have "Arr ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<and> coherent ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)"
proof
have 1: "Arr v \<and> coherent v" using v I3 by simp
have 2: "Arr (t \<^bold>\<otimes> u) \<and> coherent (t \<^bold>\<otimes> u)"
using t u I1 I2 Tensor_preserves_coherent by force
show "Arr ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)" using 1 2 by simp
show "coherent ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)"
using 1 2 Tensor_preserves_coherent by blast
qed
moreover have "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v Arr_implies_Ide_Dom by simp
moreover have "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v Arr_implies_Ide_Dom coherent_Assoc'_Ide by blast
moreover have "Dom ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) = Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
using t u v Arr_implies_Ide_Dom Ide_in_Hom by simp
ultimately show ?thesis
using t u v Arr_implies_Ide_Dom Ide_implies_Arr
Comp_preserves_coherent [of "((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)" "\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"]
by metis
qed
moreover have "Par \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] (((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
using t u v Arr_implies_Ide_Dom Ide_implies_Arr Ide_in_Hom by simp
moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
using t u v Diagonalize_Comp_Arr_Dom CompDiag_TensorDiag Diag_Diagonalize
TensorDiag_assoc TensorDiag_preserves_Diag TensorDiag_in_Hom
CompDiag_Diag_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
by simp
moreover have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
using t u v Arr_implies_Ide_Dom Ide_implies_Arr eval_in_hom comp_cod_arr
\<alpha>'.is_natural_1 \<alpha>'_simp
by simp
ultimately show "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]" by argo
qed
qed
thus ?thesis using assms by blast
qed
text\<open>
MacLane \cite{MacLane71} says: ``A coherence theorem asserts `Every diagram commutes',''
but that is somewhat misleading. A coherence theorem provides some kind of hopefully
useful way of distinguishing diagrams that definitely commute from diagrams that might not.
The next result expresses coherence for monoidal categories in this way.
As the hypotheses can be verified algorithmically (using the functions @{term Dom},
@{term Cod}, @{term Arr}, and @{term Diagonalize}) if we are given an oracle for equality
of arrows in \<open>C\<close>, the result provides a decision procedure, relative to \<open>C\<close>,
for the word problem for the free monoidal category generated by \<open>C\<close>.
\<close>
corollary eval_eqI:
assumes "Par t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
using assms coherence canonical_factorization by simp
text\<open>
Our final corollary expresses coherence in a more ``MacLane-like'' fashion:
parallel canonical arrows are equivalent under evaluation.
\<close>
corollary maclane_coherence:
assumes "Par t u" and "Can t" and "Can u"
shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
proof (intro eval_eqI)
show "Par t u" by fact
show "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
proof -
have "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Par \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
using assms eval_eqI Ide_Diagonalize_Can Diagonalize_in_Hom by simp
thus ?thesis using Ide_in_Hom by auto
qed
qed
end
end
diff --git a/thys/MonoidalCategory/MonoidalFunctor.thy b/thys/MonoidalCategory/MonoidalFunctor.thy
--- a/thys/MonoidalCategory/MonoidalFunctor.thy
+++ b/thys/MonoidalCategory/MonoidalFunctor.thy
@@ -1,767 +1,767 @@
(* Title: MonoidalFunctor
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
chapter "Monoidal Functor"
text_raw\<open>
\label{monoidal-functor-chap}
\<close>
theory MonoidalFunctor
imports MonoidalCategory
begin
text \<open>
A monoidal functor is a functor @{term F} between monoidal categories @{term C}
and @{term D} that preserves the monoidal structure up to isomorphism.
The traditional definition assumes a monoidal functor to be equipped with
two natural isomorphisms, a natural isomorphism @{term \<phi>} that expresses the preservation
of tensor product and a natural isomorphism @{term \<psi>} that expresses the preservation
of the unit object. These natural isomorphisms are subject to coherence conditions;
the condition for @{term \<phi>} involving the associator and the conditions for @{term \<psi>}
involving the unitors. However, as pointed out in \cite{Etingof15} (Section 2.4),
it is not necessary to take the natural isomorphism @{term \<psi>} as given,
since the mere assumption that @{term "F \<I>\<^sub>C"} is isomorphic to @{term "\<I>\<^sub>D"}
is sufficient for there to be a canonical definition of @{term \<psi>} from which the
coherence conditions can be derived. This leads to a more economical definition
of monoidal functor, which is the one we adopt here.
\<close>
locale monoidal_functor =
C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
"functor" C D F +
CC: product_category C C +
DD: product_category D D +
FF: product_functor C C D D F F +
FoT\<^sub>C: composite_functor C.CC.comp C D T\<^sub>C F +
T\<^sub>DoFF: composite_functor C.CC.comp D.CC.comp D FF.map T\<^sub>D +
\<phi>: natural_isomorphism C.CC.comp D T\<^sub>DoFF.map FoT\<^sub>C.map \<phi>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
and \<iota>\<^sub>C :: "'c"
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and F :: "'c \<Rightarrow> 'd"
and \<phi> :: "'c * 'c \<Rightarrow> 'd" +
assumes preserves_unity: "D.isomorphic D.unity (F C.unity)"
and assoc_coherence:
"\<lbrakk> C.ide a; C.ide b; C.ide c \<rbrakk> \<Longrightarrow>
F (\<alpha>\<^sub>C (a, b, c)) \<cdot>\<^sub>D \<phi> (T\<^sub>C (a, b), c) \<cdot>\<^sub>D T\<^sub>D (\<phi> (a, b), F c)
= \<phi> (a, T\<^sub>C (b, c)) \<cdot>\<^sub>D T\<^sub>D (F a, \<phi> (b, c)) \<cdot>\<^sub>D \<alpha>\<^sub>D (F a, F b, F c)"
begin
notation C.tensor (infixr "\<otimes>\<^sub>C" 53)
and C.unity ("\<I>\<^sub>C")
and C.lunit ("\<l>\<^sub>C[_]")
and C.runit ("\<r>\<^sub>C[_]")
and C.assoc ("\<a>\<^sub>C[_, _, _]")
and D.tensor (infixr "\<otimes>\<^sub>D" 53)
and D.unity ("\<I>\<^sub>D")
and D.lunit ("\<l>\<^sub>D[_]")
and D.runit ("\<r>\<^sub>D[_]")
and D.assoc ("\<a>\<^sub>D[_, _, _]")
lemma \<phi>_in_hom:
assumes "C.ide a" and "C.ide b"
shows "\<guillemotleft>\<phi> (a, b) : F a \<otimes>\<^sub>D F b \<rightarrow>\<^sub>D F (a \<otimes>\<^sub>C b)\<guillemotright>"
using assms by auto
text \<open>
We wish to exhibit a canonical definition of an isomorphism
@{term "\<psi> \<in> D.hom \<I>\<^sub>D (F \<I>\<^sub>C)"} that satisfies certain coherence conditions that
involve the left and right unitors. In \cite{Etingof15}, the isomorphism @{term \<psi>}
is defined by the equation @{term "\<l>\<^sub>D[F \<I>\<^sub>C] = F \<l>\<^sub>C[\<I>\<^sub>C] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F \<I>\<^sub>C)"},
which suffices for the definition because the functor \<open>- \<otimes>\<^sub>D F \<I>\<^sub>C\<close> is fully faithful.
It is then asserted (Proposition 2.4.3) that the coherence condition
@{term "\<l>\<^sub>D[F a] = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)"} is satisfied for any object @{term a}
of \<open>C\<close>, as well as the corresponding condition for the right unitor.
However, the proof is left as an exercise (Exercise 2.4.4).
The organization of the presentation suggests that that one should derive the
general coherence condition from the special case
@{term "\<l>\<^sub>D[F \<I>\<^sub>C] = F \<l>\<^sub>C[\<I>\<^sub>C] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F \<I>\<^sub>C)"} used as the definition of @{term \<psi>}.
However, I did not see how to do it that way, so I used a different approach.
The isomorphism @{term "\<iota>\<^sub>D' \<equiv> F \<iota>\<^sub>C \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C)"} serves as an alternative unit for the
monoidal category \<open>D\<close>. There is consequently a unique isomorphism that maps
@{term "\<iota>\<^sub>D"} to @{term "\<iota>\<^sub>D'"}. We define @{term \<psi>} to be this isomorphism and then use
the definition to establish the desired coherence conditions.
\<close>
abbreviation \<iota>\<^sub>1
where "\<iota>\<^sub>1 \<equiv> F \<iota>\<^sub>C \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C)"
lemma \<iota>\<^sub>1_in_hom:
shows "\<guillemotleft>\<iota>\<^sub>1 : F \<I>\<^sub>C \<otimes>\<^sub>D F \<I>\<^sub>C \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>"
using C.\<iota>_in_hom by (intro D.in_homI, auto)
lemma \<iota>\<^sub>1_is_iso:
shows "D.iso \<iota>\<^sub>1"
using C.\<iota>_is_iso C.\<iota>_in_hom \<phi>_in_hom D.isos_compose by auto
interpretation D: monoidal_category_with_alternate_unit D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<iota>\<^sub>1
proof -
have 1: "\<exists>\<psi>. \<guillemotleft>\<psi> : F \<I>\<^sub>C \<rightarrow>\<^sub>D \<I>\<^sub>D\<guillemotright> \<and> D.iso \<psi>"
proof -
obtain \<psi>' where \<psi>': "\<guillemotleft>\<psi>' : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi>'"
using preserves_unity by auto
have "\<guillemotleft>D.inv \<psi>' : F \<I>\<^sub>C \<rightarrow>\<^sub>D \<I>\<^sub>D\<guillemotright> \<and> D.iso (D.inv \<psi>')"
using \<psi>' D.iso_inv_iso by simp
thus ?thesis by auto
qed
obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : F \<I>\<^sub>C \<rightarrow>\<^sub>D \<I>\<^sub>D\<guillemotright> \<and> D.iso \<psi>"
using 1 by blast
- interpret L: equivalence_functor D D "\<lambda>f. (D.cod \<iota>\<^sub>1) \<otimes>\<^sub>D f"
+ interpret L: equivalence_functor D D \<open>\<lambda>f. (D.cod \<iota>\<^sub>1) \<otimes>\<^sub>D f\<close>
proof -
- interpret L: "functor" D D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f"
+ interpret L: "functor" D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close>
using D.T.fixing_ide_gives_functor_1 by simp
- interpret L: endofunctor D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f" ..
- interpret \<psi>x: natural_transformation D D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f" "\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f" "\<lambda>f. \<psi> \<otimes>\<^sub>D f"
+ interpret L: endofunctor D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> ..
+ interpret \<psi>x: natural_transformation D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<psi> \<otimes>\<^sub>D f\<close>
using \<psi> D.T.fixing_arr_gives_natural_transformation_1 [of \<psi>] by auto
- interpret \<psi>x: natural_isomorphism D D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f" "\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f" "\<lambda>f. \<psi> \<otimes>\<^sub>D f"
+ interpret \<psi>x: natural_isomorphism D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<psi> \<otimes>\<^sub>D f\<close>
apply unfold_locales using \<psi> D.tensor_preserves_iso by simp
- interpret \<ll>\<^sub>Do\<psi>x: vertical_composite D D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f" "\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f" D.map
- "\<lambda>f. \<psi> \<otimes>\<^sub>D f" D.\<ll> ..
- interpret \<ll>\<^sub>Do\<psi>x: natural_isomorphism D D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f" D.map \<ll>\<^sub>Do\<psi>x.map
+ interpret \<ll>\<^sub>Do\<psi>x: vertical_composite D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f\<close> D.map
+ \<open>\<lambda>f. \<psi> \<otimes>\<^sub>D f\<close> D.\<ll> ..
+ interpret \<ll>\<^sub>Do\<psi>x: natural_isomorphism D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> D.map \<ll>\<^sub>Do\<psi>x.map
using \<psi>x.natural_isomorphism_axioms D.\<ll>.natural_isomorphism_axioms
natural_isomorphisms_compose by blast
- interpret L: equivalence_functor D D "\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f"
+ interpret L: equivalence_functor D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close>
using L.isomorphic_to_identity_is_equivalence \<ll>\<^sub>Do\<psi>x.natural_isomorphism_axioms
by simp
show "equivalence_functor D D (\<lambda>f. (D.cod \<iota>\<^sub>1) \<otimes>\<^sub>D f)"
using L.equivalence_functor_axioms C.\<iota>_in_hom by auto
qed
- interpret R: equivalence_functor D D "\<lambda>f. T\<^sub>D (f, D.cod \<iota>\<^sub>1)"
+ interpret R: equivalence_functor D D \<open>\<lambda>f. T\<^sub>D (f, D.cod \<iota>\<^sub>1)\<close>
proof -
- interpret R: "functor" D D "\<lambda>f. T\<^sub>D (f, F \<I>\<^sub>C)"
+ interpret R: "functor" D D \<open>\<lambda>f. T\<^sub>D (f, F \<I>\<^sub>C)\<close>
using D.T.fixing_ide_gives_functor_2 by simp
- interpret R: endofunctor D "\<lambda>f. T\<^sub>D (f, F \<I>\<^sub>C)" ..
- interpret x\<psi>: natural_transformation D D "\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)" "\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D" "\<lambda>f. f \<otimes>\<^sub>D \<psi>"
+ interpret R: endofunctor D \<open>\<lambda>f. T\<^sub>D (f, F \<I>\<^sub>C)\<close> ..
+ interpret x\<psi>: natural_transformation D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<psi>\<close>
using \<psi> D.T.fixing_arr_gives_natural_transformation_2 [of \<psi>] by auto
- interpret x\<psi>: natural_isomorphism D D "\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)" "\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D" "\<lambda>f. f \<otimes>\<^sub>D \<psi>"
+ interpret x\<psi>: natural_isomorphism D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<psi>\<close>
using \<psi> D.tensor_preserves_iso by (unfold_locales, simp)
- interpret \<rho>\<^sub>Dox\<psi>: vertical_composite D D "\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)" "\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D" D.map
- "\<lambda>f. f \<otimes>\<^sub>D \<psi>" D.\<rho> ..
- interpret \<rho>\<^sub>Dox\<psi>: natural_isomorphism D D "\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)" D.map \<rho>\<^sub>Dox\<psi>.map
+ interpret \<rho>\<^sub>Dox\<psi>: vertical_composite D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D\<close> D.map
+ \<open>\<lambda>f. f \<otimes>\<^sub>D \<psi>\<close> D.\<rho> ..
+ interpret \<rho>\<^sub>Dox\<psi>: natural_isomorphism D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> D.map \<rho>\<^sub>Dox\<psi>.map
using x\<psi>.natural_isomorphism_axioms D.\<rho>.natural_isomorphism_axioms
natural_isomorphisms_compose by blast
- interpret R: equivalence_functor D D "\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)"
+ interpret R: equivalence_functor D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close>
using R.isomorphic_to_identity_is_equivalence \<rho>\<^sub>Dox\<psi>.natural_isomorphism_axioms
by simp
show "equivalence_functor D D (\<lambda>f. f \<otimes>\<^sub>D (D.cod \<iota>\<^sub>1))"
using R.equivalence_functor_axioms C.\<iota>_in_hom by auto
qed
show "monoidal_category_with_alternate_unit D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<iota>\<^sub>1"
using D.pentagon C.\<iota>_is_iso C.\<iota>_in_hom preserves_hom \<iota>\<^sub>1_is_iso \<iota>\<^sub>1_in_hom
by (unfold_locales, auto)
qed
no_notation D.tensor (infixr "\<otimes>\<^sub>D" 53)
notation D.C\<^sub>1.tensor (infixr "\<otimes>\<^sub>D" 53) (* equal to D.tensor *)
no_notation D.assoc ("\<a>\<^sub>D[_, _, _]")
notation D.C\<^sub>1.assoc ("\<a>\<^sub>D[_, _, _]") (* equal to D.assoc *)
no_notation D.assoc' ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]")
notation D.C\<^sub>1.assoc' ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]") (* equal to D.assoc' *)
notation D.C\<^sub>1.unity ("\<I>\<^sub>1")
notation D.C\<^sub>1.lunit ("\<l>\<^sub>1[_]")
notation D.C\<^sub>1.runit ("\<r>\<^sub>1[_]")
lemma \<I>\<^sub>1_char [simp]:
shows "\<I>\<^sub>1 = F \<I>\<^sub>C"
using D.C\<^sub>1.unity_def \<iota>\<^sub>1_in_hom by auto
definition \<psi>
where "\<psi> \<equiv> THE \<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
lemma \<psi>_char:
shows "\<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>" and "D.iso \<psi>" and "\<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
and "\<exists>!\<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
proof -
show "\<exists>!\<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
using D.unit_unique_upto_unique_iso \<iota>\<^sub>1_in_hom D.C\<^sub>1.\<iota>_in_hom
by (elim D.in_homE, auto)
hence 1: "\<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
unfolding \<psi>_def
using theI' [of "\<lambda>\<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"]
by fast
show "\<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>" using 1 by simp
show "D.iso \<psi>" using 1 by simp
show "\<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)" using 1 by simp
qed
lemma \<psi>_eqI:
assumes "\<guillemotleft>f: \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>" and "D.iso f" and "f \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (f \<otimes>\<^sub>D f)"
shows "f = \<psi>"
using assms \<psi>_def \<psi>_char
the1_equality [of "\<lambda>f. \<guillemotleft>f: \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso f \<and> f \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (f \<otimes>\<^sub>D f)" f]
by simp
lemma lunit_coherence1:
assumes "C.ide a"
shows "\<l>\<^sub>1[F a] \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a) = \<l>\<^sub>D[F a]"
proof -
have "D.par (\<l>\<^sub>1[F a] \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)) \<l>\<^sub>D[F a]"
using assms D.C\<^sub>1.lunit_in_hom D.tensor_in_hom D.lunit_in_hom \<psi>_char(1) C.\<iota>_in_hom
by auto
text \<open>
The upper left triangle in the following diagram commutes.
\<close>
text \<open>
\newcommand\xIc{{\cal I}}
\newcommand\xId{{\cal I}}
\newcommand\xac[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xad[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xlc[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xld[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xldp[1]{{\scriptsize \<open>\<l>\<close>}_1[{#1}]}
$$\xymatrix{
{\xId\otimes F a}
\ar[rrr]^{\psi\otimes F a}
& & &
{F\xIc\otimes F a}
\\
&
{\xId\otimes(F\xIc \otimes F a)}
\ar[ul]_{\xId\otimes\xldp{F a}}
\ar[ddr]^{\psi\otimes(F\xIc\otimes F a)}
\\ \\
&
{\xId\otimes(\xId \otimes F a)}
\ar[r]_{\psi\otimes(\psi\otimes F a)}
\ar[uuul]^{\xId\otimes\xld{F a}}
\ar[uu]_{\xId\otimes(\psi\otimes F a)}
&
{F\xIc\otimes (F\xIc\otimes F a)}
\ar[uuur]^{F\xIc\otimes\xldp{F a}}
\\ \\
{(\xId\otimes\xId)\otimes F a}
\ar[uuuuu]^{\iota\otimes F a}
\ar[uur]_{\xad{\xId}{\xId}{F a}}
\ar[rrr]^{(\psi\otimes\psi)\otimes F a}
& & &
{(F\xIc\otimes F\xIc)\otimes F a}
\ar[uuuuu]_{\iota_1\otimes F a}
\ar[uul]^{\xad{F\xIc}{F\xIc}{F a}}
}$$
\<close>
moreover have "(\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (\<I>\<^sub>D \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a) = \<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>D[F a]"
proof -
have "(\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (\<I>\<^sub>D \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)
= (\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (D.inv \<psi> \<otimes>\<^sub>D F \<I>\<^sub>C \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)"
using assms \<psi>_char(1-2) D.interchange [of "D.inv \<psi>"] D.comp_cod_arr
D.inv_is_inverse D.comp_inv_arr
by (elim D.in_homE, simp)
also have "... = (D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)"
proof -
have "(\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (D.inv \<psi> \<otimes>\<^sub>D F \<I>\<^sub>C \<otimes>\<^sub>D F a) =
(D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
using assms \<psi>_char(1-2) D.interchange [of "\<I>\<^sub>D"] D.interchange [of "D.inv \<psi>"]
D.comp_arr_dom D.comp_cod_arr
by (elim D.in_homE, auto)
thus ?thesis
using assms \<psi>_char(1-2) D.inv_in_hom
D.comp_permute [of "\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]" "D.inv \<psi> \<otimes>\<^sub>D F \<I>\<^sub>C \<otimes>\<^sub>D F a"
"D.inv \<psi> \<otimes>\<^sub>D F a" "F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"]
by (elim D.in_homE, auto)
qed
also have "... = (D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a] \<cdot>\<^sub>D
(\<psi> \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)"
using assms \<psi>_char(1-2) D.C\<^sub>1.lunit_char(2) D.comp_assoc by auto
also have "... = ((D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D ((\<psi> \<otimes>\<^sub>D \<psi>) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D
D.inv \<a>\<^sub>D[\<I>\<^sub>D, \<I>\<^sub>D, F a]"
using assms \<psi>_char(1-2) D.assoc'_naturality [of \<psi> \<psi> "F a"] D.comp_assoc by auto
also have "... = (\<iota>\<^sub>D \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[\<I>\<^sub>D, \<I>\<^sub>D, F a]"
proof -
have "(D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D ((\<psi> \<otimes>\<^sub>D \<psi>) \<otimes>\<^sub>D F a) = \<iota>\<^sub>D \<otimes>\<^sub>D F a"
proof -
have "(D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D ((\<psi> \<otimes>\<^sub>D \<psi>) \<otimes>\<^sub>D F a) =
D.inv \<psi> \<cdot>\<^sub>D \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D \<otimes>\<^sub>D F a"
using assms \<psi>_char(1-3) D.\<iota>_in_hom \<iota>\<^sub>1_in_hom D.interchange
by (elim D.in_homE, auto)
also have "... = \<iota>\<^sub>D \<otimes>\<^sub>D F a"
using assms \<psi>_char(1-2) D.inv_is_inverse D.comp_inv_arr D.comp_cod_arr
D.comp_reduce D.\<iota>_in_hom
by (elim D.in_homE, auto)
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = \<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>D[F a]"
using assms D.lunit_char by simp
finally show ?thesis by blast
qed
ultimately show ?thesis
using D.L.is_faithful [of "\<l>\<^sub>1[F a] \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)" "\<l>\<^sub>D[F a]"] D.\<iota>_in_hom by force
qed
lemma lunit_coherence2:
assumes "C.ide a"
shows "F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) = \<l>\<^sub>1[F a]"
proof -
text \<open>
We show that the lower left triangle in the following diagram commutes.
\<close>
text \<open>
\newcommand\xIc{{\cal I}}
\newcommand\xId{{\cal I}}
\newcommand\xac[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xad[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xlc[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xld[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xldp[1]{{\scriptsize \<open>\<l>\<close>}_1[{#1}]}
$$\xymatrix{
{(F\xIc\otimes F\xIc)\otimes F a}
\ar[rrrrr]^{\phi(\xIc,\xIc)\otimes F a}
\ar[ddd]_{\xad{F\xIc}{F\xIc}{Fa}}
\ar[dddrr]^{\iota_1\otimes F a}
&&&&&{F(\xIc\otimes\xIc)\otimes F a}
\ar[ddd]^{\phi(\xIc\otimes\xIc, a)}
\ar[dddlll]_{F\iota\otimes F a}
\\ \\ \\
{F\xIc\otimes(F\xIc\otimes F a)}
\ar[ddd]_{F\xIc\otimes\phi(\xIc, a)}
\ar[rr]_{F\xIc\otimes\xldp{Fa}}
&&{F\xIc\otimes F a}
\ar[r]_{\phi(\xIc, a)}
&{F(\xIc\otimes a)}
&&{F((\xIc\otimes\xIc)\otimes a)}
\ar[ddd]^{F\xac{\xIc}{\xIc}{a}}
\ar[ll]^{F(\iota\otimes a)}
\\ \\ \\
{F\xIc\otimes F (\xIc\otimes a)}
\ar[rrrrr]_{\phi(\xIc, \xIc\otimes a)}
\ar[uuurr]_{F\xIc\otimes F\xlc{a}}
&&&&&{F(\xIc\otimes (\xIc \otimes a))}
\ar[uuull]^{F(\xIc\otimes\xlc{a})}
}$$
\<close>
have "(F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a)) = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
proof -
have "(F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a))
= (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D
\<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
proof -
have "D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D
(\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a)
= (F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
using assms \<phi>_in_hom assoc_coherence D.invert_side_of_triangle(1) by simp
hence "F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a)
= (D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D
(\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
using assms \<phi>_in_hom D.invert_side_of_triangle(2) by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
(D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D F (\<iota>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
\<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D
D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
proof -
have 1: "F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a]) = F (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a])"
using assms C.lunit_char(1-2) C.\<iota>_in_hom preserves_inv by auto
hence "F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] = D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D F (\<iota>\<^sub>C \<otimes>\<^sub>C a)"
proof -
have "F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D D.inv (F (\<iota>\<^sub>C \<otimes>\<^sub>C a))
= D.inv (F (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C ,a]))"
using assms 1 preserves_iso C.ide_is_iso C.\<iota>_is_iso C.ide_unity C.iso_assoc
C.iso_lunit C.tensor_preserves_iso D.inv_comp D.inv_inv
D.iso_inv_iso D.iso_is_arr
by metis
thus ?thesis
using assms 1 preserves_iso C.ide_is_iso C.\<iota>_is_iso C.ide_unity C.iso_assoc
C.iso_lunit C.tensor_preserves_iso D.inv_comp D.inv_inv
D.iso_inv_iso D.iso_is_arr D.invert_side_of_triangle(2)
by metis
qed
thus ?thesis by argo
qed
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D (F (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a)) \<cdot>\<^sub>D
(\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
using D.comp_assoc by auto
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (F \<iota>\<^sub>C \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D
(\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
using assms \<phi>.naturality [of "(\<iota>\<^sub>C, a)"] C.\<iota>_in_hom by auto
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D
((F \<iota>\<^sub>C \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D
D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
using D.comp_assoc by auto
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D
D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
using assms D.interchange C.\<iota>_in_hom by auto
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D
((F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]) \<cdot>\<^sub>D
D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
proof -
have "(\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F \<I>\<^sub>C, F \<I>\<^sub>C, F a] = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
using assms D.C\<^sub>1.lunit_char [of "F a"] by auto
thus ?thesis
using assms D.inv_is_inverse \<iota>\<^sub>1_in_hom \<phi>_in_hom D.invert_side_of_triangle(2)
by simp
qed
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D
(D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D
(F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
using assms D.comp_arr_dom [of "F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"] D.comp_assoc by auto
also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
proof -
have "D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a])
= D.inv (D.inv (\<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a]) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a))"
using assms \<phi>.naturality [of "(\<I>\<^sub>C, \<l>\<^sub>C[a])"] D.invert_side_of_triangle(1) by simp
also have "... = D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
using assms D.inv_comp D.iso_inv_iso D.inv_is_inverse D.isos_compose D.comp_assoc
by simp
finally have "D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a])
= D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
by blast
thus ?thesis by argo
qed
also have "... = ((F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a])) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
using assms D.tensor_preserves_iso D.comp_assoc by simp
also have "... = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
using assms D.tensor_preserves_iso D.comp_arr_inv D.inv_is_inverse D.comp_cod_arr
D.interchange
by simp
finally show ?thesis by blast
qed
hence "F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
using assms \<phi>_in_hom D.interchange by simp
moreover have "D.par (F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<l>\<^sub>1[F a]"
using assms \<phi>_in_hom by simp
ultimately show ?thesis
using D.C\<^sub>1.L.is_faithful [of "F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)" "\<l>\<^sub>1[F a]"] D.C\<^sub>1.unity_def by simp
qed
text \<open>
Combining the two previous lemmas yields the coherence result we seek.
This is the condition that is traditionally taken as part of the definition
of monoidal functor.
\<close>
lemma lunit_coherence:
assumes "C.ide a"
shows "\<l>\<^sub>D[F a] = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)"
proof -
have "\<l>\<^sub>D[F a] \<cdot>\<^sub>D D.inv (\<psi> \<otimes>\<^sub>D F a) = \<l>\<^sub>1[F a]"
using assms lunit_coherence1 \<psi>_char(2)
D.invert_side_of_triangle(2) [of "\<l>\<^sub>D[F a]" "\<l>\<^sub>1[F a]" "\<psi> \<otimes>\<^sub>D F a"]
by auto
also have "... = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
using assms lunit_coherence2 by simp
finally have "\<l>\<^sub>D[F a] \<cdot>\<^sub>D D.inv (\<psi> \<otimes>\<^sub>D F a) = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
by blast
hence "\<l>\<^sub>D[F a] = (F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)"
using assms \<psi>_char(2) D.iso_inv_iso \<phi>_in_hom
D.invert_side_of_triangle(2) [of "F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)" "\<l>\<^sub>D[F a]" "D.inv (\<psi> \<otimes>\<^sub>D F a)"]
by simp
thus ?thesis
using assms \<psi>_char(1) D.comp_assoc by auto
qed
text \<open>
We now want to obtain the corresponding result for the right unitor.
To avoid a repetition of what would amount to essentially the same tedious diagram chases
that were carried out above, we instead show here that @{term F} becomes a monoidal functor
from the opposite of \<open>C\<close> to the opposite of \<open>D\<close>,
with @{term "\<lambda>f. \<phi> (snd f, fst f)"} as the structure map.
The fact that in the opposite monoidal categories the left and right unitors are exchanged
then permits us to obtain the result for the right unitor from the result already proved
for the left unitor.
\<close>
interpretation C': opposite_monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C ..
interpretation D': opposite_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D ..
interpretation T\<^sub>D'oFF: composite_functor C.CC.comp D.CC.comp D FF.map D'.T ..
interpretation FoT\<^sub>C': composite_functor C.CC.comp C D C'.T F ..
interpretation \<phi>': natural_transformation C.CC.comp D T\<^sub>D'oFF.map FoT\<^sub>C'.map
- "\<lambda>f. \<phi> (snd f, fst f)"
+ \<open>\<lambda>f. \<phi> (snd f, fst f)\<close>
using \<phi>.is_natural_1 \<phi>.is_natural_2 \<phi>.is_extensional by (unfold_locales, auto)
interpretation \<phi>': natural_isomorphism C.CC.comp D T\<^sub>D'oFF.map FoT\<^sub>C'.map
- "\<lambda>f. \<phi> (snd f, fst f)"
+ \<open>\<lambda>f. \<phi> (snd f, fst f)\<close>
by (unfold_locales, simp)
- interpretation F': monoidal_functor C C'.T C'.\<alpha> \<iota>\<^sub>C D D'.T D'.\<alpha> \<iota>\<^sub>D F "\<lambda>f. \<phi> (snd f, fst f)"
+ interpretation F': monoidal_functor C C'.T C'.\<alpha> \<iota>\<^sub>C D D'.T D'.\<alpha> \<iota>\<^sub>D F \<open>\<lambda>f. \<phi> (snd f, fst f)\<close>
using preserves_unity apply (unfold_locales; simp)
proof -
fix a b c
assume a: "C.ide a" and b: "C.ide b" and c: "C.ide c"
have "(\<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F c, F b, F a] =
F (C.assoc' c b a) \<cdot>\<^sub>D \<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a))"
proof -
have "D.seq (F \<a>\<^sub>C[c, b, a]) (\<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a))"
using a b c \<phi>_in_hom by simp
moreover have "D.seq (\<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a))) \<a>\<^sub>D[F c, F b, F a]"
using a b c \<phi>_in_hom by simp
moreover have
"F \<a>\<^sub>C[c, b, a] \<cdot>\<^sub>D \<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a) =
(\<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a))) \<cdot>\<^sub>D \<a>\<^sub>D[F c, F b, F a]"
using a b c assoc_coherence D.comp_assoc by simp
moreover have "D.iso (F \<a>\<^sub>C[c,b,a])"
using a b c by simp
moreover have "D.iso \<a>\<^sub>D[F c, F b, F a]"
using a b c by simp
moreover have "D.inv (F \<a>\<^sub>C[c,b,a]) = F (C.assoc' c b a)"
using a b c preserves_inv by simp
ultimately show ?thesis
using D.invert_opposite_sides_of_square by simp
qed
thus "F (C.assoc' c b a) \<cdot>\<^sub>D \<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a)) =
\<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F c, F b, F a]"
using D.comp_assoc by simp
qed
lemma induces_monoidal_functor_between_opposites:
shows "monoidal_functor C C'.T C'.\<alpha> \<iota>\<^sub>C D D'.T D'.\<alpha> \<iota>\<^sub>D F (\<lambda>f. \<phi> (snd f, fst f))"
..
lemma runit_coherence:
assumes "C.ide a"
shows "\<r>\<^sub>D[F a] = F \<r>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (a, \<I>\<^sub>C) \<cdot>\<^sub>D (F a \<otimes>\<^sub>D \<psi>)"
proof -
have "C'.lunit a = \<r>\<^sub>C[a]"
using assms C'.lunit_simp by simp
moreover have "D'.lunit (F a) = \<r>\<^sub>D[F a]"
using assms D'.lunit_simp by simp
moreover have "F'.\<psi> = \<psi>"
proof (intro \<psi>_eqI)
show "\<guillemotleft>F'.\<psi> : D'.unity \<rightarrow>\<^sub>D F C'.unity\<guillemotright>" using F'.\<psi>_char(1) by simp
show "D.iso F'.\<psi>" using F'.\<psi>_char(2) by simp
show "F'.\<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (F'.\<psi> \<otimes>\<^sub>D F'.\<psi>)" using F'.\<psi>_char(3) by simp
qed
moreover have "D'.lunit (F a) = F (C'.lunit a) \<cdot>\<^sub>D \<phi> (a, C'.unity) \<cdot>\<^sub>D (F a \<otimes>\<^sub>D F'.\<psi>)"
using assms F'.lunit_coherence by simp
ultimately show ?thesis by simp
qed
end
section "Strict Monoidal Functor"
text \<open>
A strict monoidal functor preserves the monoidal structure ``on the nose''.
\<close>
locale strict_monoidal_functor =
C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
"functor" C D F
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
and \<iota>\<^sub>C :: "'c"
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and F :: "'c \<Rightarrow> 'd" +
assumes strictly_preserves_\<iota>: "F \<iota>\<^sub>C = \<iota>\<^sub>D"
and strictly_preserves_T: "\<lbrakk> C.arr f; C.arr g \<rbrakk> \<Longrightarrow> F (T\<^sub>C (f, g)) = T\<^sub>D (F f, F g)"
and strictly_preserves_\<alpha>_ide: "\<lbrakk> C.ide a; C.ide b; C.ide c \<rbrakk> \<Longrightarrow>
F (\<alpha>\<^sub>C (a, b, c)) = \<alpha>\<^sub>D (F a, F b, F c)"
begin
notation C.tensor (infixr "\<otimes>\<^sub>C" 53)
and C.unity ("\<I>\<^sub>C")
and C.lunit ("\<l>\<^sub>C[_]")
and C.runit ("\<r>\<^sub>C[_]")
and C.assoc ("\<a>\<^sub>C[_, _, _]")
and D.tensor (infixr "\<otimes>\<^sub>D" 53)
and D.unity ("\<I>\<^sub>D")
and D.lunit ("\<l>\<^sub>D[_]")
and D.runit ("\<r>\<^sub>D[_]")
and D.assoc ("\<a>\<^sub>D[_, _, _]")
lemma strictly_preserves_tensor:
assumes "C.arr f" and "C.arr g"
shows "F (f \<otimes>\<^sub>C g) = F f \<otimes>\<^sub>D F g"
using assms strictly_preserves_T by blast
lemma strictly_preserves_\<alpha>:
assumes "C.arr f" and "C.arr g" and "C.arr h"
shows "F (\<alpha>\<^sub>C (f, g, h)) = \<alpha>\<^sub>D (F f, F g, F h)"
proof -
have "F (\<alpha>\<^sub>C (f, g, h)) = F ((f \<otimes>\<^sub>C g \<otimes>\<^sub>C h) \<cdot>\<^sub>C \<alpha>\<^sub>C (C.dom f, C.dom g, C.dom h))"
using assms C.\<alpha>.is_natural_1 [of "(f, g, h)"] C.T.ToCT_simp by force
also have "... = (F f \<otimes>\<^sub>D F g \<otimes>\<^sub>D F h) \<cdot>\<^sub>D \<alpha>\<^sub>D (D.dom (F f), D.dom (F g), D.dom (F h))"
using assms strictly_preserves_\<alpha>_ide strictly_preserves_tensor by simp
also have "... = \<alpha>\<^sub>D (F f, F g, F h)"
using assms D.\<alpha>.is_natural_1 [of "(F f, F g, F h)"] by simp
finally show ?thesis by blast
qed
lemma strictly_preserves_unity:
shows "F \<I>\<^sub>C = \<I>\<^sub>D"
using C.\<iota>_in_hom strictly_preserves_\<iota> C.unity_def D.unity_def by auto
lemma strictly_preserves_assoc:
assumes "C.arr a" and "C.arr b" and "C.arr c"
shows "F \<a>\<^sub>C[a, b, c] = \<a>\<^sub>D[F a, F b, F c] "
using assms strictly_preserves_\<alpha> by simp
lemma strictly_preserves_lunit:
assumes "C.ide a"
shows "F \<l>\<^sub>C[a] = \<l>\<^sub>D[F a]"
proof -
let ?P = "\<lambda>f. f \<in> C.hom (\<I>\<^sub>C \<otimes>\<^sub>C a) a \<and> \<I>\<^sub>C \<otimes>\<^sub>C f = (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>C C.assoc' \<I>\<^sub>C \<I>\<^sub>C a"
let ?Q = "\<lambda>f. f \<in> D.hom (\<I>\<^sub>D \<otimes>\<^sub>D F a) (F a) \<and>
\<I>\<^sub>D \<otimes>\<^sub>D f = (\<iota>\<^sub>D \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.assoc' \<I>\<^sub>D \<I>\<^sub>D (F a)"
have 1: "?P \<l>\<^sub>C[a]" using assms C.lunit_char by simp
hence "?Q (F \<l>\<^sub>C[a])"
proof -
have "F \<l>\<^sub>C[a] \<in> D.hom (\<I>\<^sub>D \<otimes>\<^sub>D F a) (F a)"
using assms 1 strictly_preserves_unity strictly_preserves_tensor by auto
moreover have
"F ((\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>C C.assoc' \<I>\<^sub>C \<I>\<^sub>C a) = (\<iota>\<^sub>D \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.assoc' \<I>\<^sub>D \<I>\<^sub>D (F a)"
using assms 1 strictly_preserves_\<iota> strictly_preserves_assoc strictly_preserves_unity
strictly_preserves_tensor preserves_inv C.\<iota>_in_hom
by auto
moreover have "\<I>\<^sub>D \<otimes>\<^sub>D F \<l>\<^sub>C[a] = F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])"
using assms strictly_preserves_unity strictly_preserves_tensor by simp
ultimately show ?thesis
using assms C.lunit_char(2) by simp
qed
thus ?thesis using assms D.lunit_eqI by simp
qed
lemma strictly_preserves_runit:
assumes "C.ide a"
shows "F \<r>\<^sub>C[a] = \<r>\<^sub>D[F a]"
proof -
let ?P = "\<lambda>f. f \<in> C.hom (a \<otimes>\<^sub>C \<I>\<^sub>C) a \<and> f \<otimes>\<^sub>C \<I>\<^sub>C = (a \<otimes>\<^sub>C \<iota>\<^sub>C) \<cdot>\<^sub>C C.assoc a \<I>\<^sub>C \<I>\<^sub>C"
let ?Q = "\<lambda>f. f \<in> D.hom (F a \<otimes>\<^sub>D \<I>\<^sub>D) (F a) \<and>
f \<otimes>\<^sub>D \<I>\<^sub>D = (F a \<otimes>\<^sub>D \<iota>\<^sub>D) \<cdot>\<^sub>D D.assoc (F a) \<I>\<^sub>D \<I>\<^sub>D"
have 1: "?P \<r>\<^sub>C[a]" using assms C.runit_char by simp
hence "?Q (F \<r>\<^sub>C[a])"
proof -
have "F \<r>\<^sub>C[a] \<in> D.hom (F a \<otimes>\<^sub>D \<I>\<^sub>D) (F a)"
using assms 1 strictly_preserves_unity strictly_preserves_tensor by auto
moreover have "F ((a \<otimes>\<^sub>C \<iota>\<^sub>C) \<cdot>\<^sub>C C.assoc a \<I>\<^sub>C \<I>\<^sub>C)
= (F a \<otimes>\<^sub>D \<iota>\<^sub>D) \<cdot>\<^sub>D D.assoc (F a) \<I>\<^sub>D \<I>\<^sub>D"
using assms 1 strictly_preserves_\<iota> strictly_preserves_assoc strictly_preserves_unity
strictly_preserves_tensor preserves_inv C.\<iota>_in_hom
by auto
moreover have "F \<r>\<^sub>C[a] \<otimes>\<^sub>D \<I>\<^sub>D = F (\<r>\<^sub>C[a] \<otimes>\<^sub>C \<I>\<^sub>C)"
using assms strictly_preserves_unity strictly_preserves_tensor by simp
ultimately show ?thesis
using assms C.runit_char(2) by simp
qed
thus ?thesis using assms D.runit_eqI by simp
qed
text \<open>
The following are used to simplify the expression of the sublocale relationship between
@{locale strict_monoidal_functor} and @{locale monoidal_functor}, as the definition of
the latter mentions the structure map @{term \<phi>}. For a strict monoidal functor,
this is an identity transformation.
\<close>
interpretation FF: product_functor C C D D F F ..
interpretation FoT\<^sub>C: composite_functor C.CC.comp C D T\<^sub>C F ..
interpretation T\<^sub>DoFF: composite_functor C.CC.comp D.CC.comp D FF.map T\<^sub>D ..
lemma structure_is_trivial:
shows "T\<^sub>DoFF.map = FoT\<^sub>C.map"
proof
fix x
have "C.CC.arr x \<Longrightarrow> T\<^sub>DoFF.map x = FoT\<^sub>C.map x"
proof -
assume x: "C.CC.arr x"
have "T\<^sub>DoFF.map x = F (fst x) \<otimes>\<^sub>D F (snd x)"
using x by simp
also have "... = FoT\<^sub>C.map x"
using x strictly_preserves_tensor [of "fst x" "snd x"] by simp
finally show "T\<^sub>DoFF.map x = FoT\<^sub>C.map x" by simp
qed
moreover have "\<not> C.CC.arr x \<Longrightarrow> T\<^sub>DoFF.map x = FoT\<^sub>C.map x"
using T\<^sub>DoFF.is_extensional FoT\<^sub>C.is_extensional by simp
ultimately show "T\<^sub>DoFF.map x = FoT\<^sub>C.map x" by blast
qed
abbreviation \<phi> where "\<phi> \<equiv> T\<^sub>DoFF.map"
lemma structure_is_natural_isomorphism:
shows "natural_isomorphism C.CC.comp D T\<^sub>DoFF.map FoT\<^sub>C.map \<phi>"
using T\<^sub>DoFF.natural_isomorphism_axioms structure_is_trivial by force
end
text \<open>
A strict monoidal functor is a monoidal functor.
\<close>
sublocale strict_monoidal_functor \<subseteq> monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F \<phi>
proof -
interpret FF: product_functor C C D D F F ..
interpret FoT\<^sub>C: composite_functor C.CC.comp C D T\<^sub>C F ..
interpret T\<^sub>DoFF: composite_functor C.CC.comp D.CC.comp D FF.map T\<^sub>D ..
interpret \<phi>: natural_isomorphism C.CC.comp D T\<^sub>DoFF.map FoT\<^sub>C.map \<phi>
using structure_is_natural_isomorphism by simp
show "monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F \<phi>"
proof
show "D.isomorphic \<I>\<^sub>D (F \<I>\<^sub>C)"
proof (unfold D.isomorphic_def)
have "\<guillemotleft>\<I>\<^sub>D : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<I>\<^sub>D"
using strictly_preserves_unity by auto
thus "\<exists>f. \<guillemotleft>f : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso f" by blast
qed
fix a b c
assume a: "C.ide a"
assume b: "C.ide b"
assume c: "C.ide c"
show "F \<a>\<^sub>C[a, b, c] \<cdot>\<^sub>D \<phi> (a \<otimes>\<^sub>C b, c) \<cdot>\<^sub>D (\<phi> (a, b) \<otimes>\<^sub>D F c) =
\<phi> (a, b \<otimes>\<^sub>C c) \<cdot>\<^sub>D (F a \<otimes>\<^sub>D \<phi> (b, c)) \<cdot>\<^sub>D \<a>\<^sub>D[F a, F b, F c]"
using a b c strictly_preserves_tensor strictly_preserves_assoc
D.comp_arr_dom D.comp_cod_arr
by simp
qed
qed
lemma strict_monoidal_functors_compose:
assumes "strict_monoidal_functor B T\<^sub>B \<alpha>\<^sub>B \<iota>\<^sub>B C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C F"
and "strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D G"
shows "strict_monoidal_functor B T\<^sub>B \<alpha>\<^sub>B \<iota>\<^sub>B D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D (G o F)"
proof -
interpret F: strict_monoidal_functor B T\<^sub>B \<alpha>\<^sub>B \<iota>\<^sub>B C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C F
using assms(1) by auto
interpret G: strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D G
using assms(2) by auto
interpret GoF: composite_functor B C D F G ..
show ?thesis
using F.strictly_preserves_T F.strictly_preserves_\<iota> F.strictly_preserves_\<alpha>
G.strictly_preserves_T G.strictly_preserves_\<iota> G.strictly_preserves_\<alpha>
by (unfold_locales, simp_all)
qed
text \<open>
An equivalence of monoidal categories is a monoidal functor whose underlying
ordinary functor is also part of an ordinary equivalence of categories.
\<close>
locale equivalence_of_monoidal_categories =
C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
equivalence_of_categories C D F G \<eta> \<epsilon> +
monoidal_functor D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C F \<phi>
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
and \<iota>\<^sub>C :: "'c"
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
and \<iota>\<^sub>D :: "'d"
and F :: "'d \<Rightarrow> 'c"
and \<phi> :: "'d * 'd \<Rightarrow> 'c"
and \<iota> :: 'c
and G :: "'c \<Rightarrow> 'd"
and \<eta> :: "'d \<Rightarrow> 'd"
and \<epsilon> :: "'c \<Rightarrow> 'c"
end

File Metadata

Mime Type
application/octet-stream
Expires
Tue, Apr 30, 2:23 PM (2 d)
Storage Engine
chunks
Storage Format
Chunks
Storage Handle
R2wupApyD9SB
Default Alt Text
(4 MB)

Event Timeline