Page MenuHomeIsabelle/Phabricator
Files F1569012

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,2468 @@
(* 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
+ 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
+ using assms 0 1 \<phi> ide_in_hom(2) targetsD(1)
+ apply (intro conjI hcomp_in_vhom) 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'
+ using assms interchange [of g g "(\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]" "\<a>[?b, ?b, f]"]
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
+ using assms comp_arr_dom comp_assoc_assoc' 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
+ using assms interchange [of "g \<star> \<i>[?b]" "\<a>[g, ?b, ?b]" f f] comp_assoc 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
+ using assms 1 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
+ using assms comp_cod_arr 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'
+ whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"]
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
+ using assms comp_arr_dom 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
+ interchange [of ?b ?b "\<l>\<^sup>-\<^sup>1[f]" "\<l>[f]"] 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'
+ using assms triangle interchange [of "f \<star> \<l>[g]" "\<a>[f, trg g, g]" h h] comp_assoc
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
+ using assms iso_assoc isos_compose by simp
ultimately show ?thesis
- using assms iso_is_retraction retraction_is_epi hseqI'
+ using assms iso_is_retraction retraction_is_epi
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
+ using assms L.is_faithful [of "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]" "\<l>[f] \<star> g"] 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
+ using assms 1 invert_side_of_triangle(2) 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')
+ using assms inv_comp iso_inv_iso by simp
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'
+ using assms assoc_naturality [of f g "\<l>[h]"] invert_side_of_triangle(1)
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'
+ using assms interchange [of f f] triangle comp_assoc
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"]
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'
+ using assms interchange [of "f \<star> \<r>[g]" "\<a>[f, g, src g]" "src g" "src g"]
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
+ using assms 1 inv_comp inv_hcomp by auto
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
+ using assms 1 comp_arr_dom comp_cod_arr comp_assoc hseqI' comp_assoc_assoc' by auto
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
+ using assms inv_comp iso_inv_iso 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'
+ using assms comp_arr_dom comp_assoc 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
+ using assms comp_assoc_assoc'(2) comp_cod_arr 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
+ using assms comp_assoc_assoc'(1) comp_arr_dom 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
+ using assms triangle by auto
also have "... = (f \<star> \<l>[g])"
- using assms comp_arr_dom comp_assoc hseqI' comp_assoc_assoc' by auto
+ using assms comp_arr_dom comp_assoc 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
+ using assms inv_comp [of "\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)" "f \<star> \<a>[g, h, k]"]
+ by force
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
+ using assms iso_assoc inv_comp 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,14776 +1,14758 @@
(* 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 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))
+ by (metis C.ideD(1) C.isomorphic_implies_hpar(4) C.isomorphic_implies_ide(2)
+ C.trg_hcomp D.ideD(1) G.G_props(1) C.in_hhomE)
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))
+ by (metis C.ideD(1) C.isomorphic_implies_hpar(2-3) C.src_hcomp D.ideD(1) G.G_props(1)
+ C.right_adjoint_simps(2) C.in_hhomE)
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')"]
+ D.src_hcomp 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)
+ proof -
+ have "D.ide (F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r'))"
+ using f' D.isomorphic_implies_ide by auto
+ moreover have "src\<^sub>D (F g) = trg\<^sub>D (F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r'))"
+ using fg r' f' 2 D.hseqE D.ideD(1) D.isomorphic_implies_ide D.trg_hcomp
+ by metis
+ ultimately show ?thesis
+ using fg r' trg_g C.left_adjoint_is_ide D.assoc'_in_hom(2) by simp
+ qed
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'
+ 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
+ using f g r' \<phi> 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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
+ using \<gamma> src_def trg_def arrI fw.composable 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
+ using \<gamma> src_def trg_def fw.composable gw.are_arrows(1) 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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))
+ by (metis assms(3) iso_runit ideD(1) isomorphic_def left_adjoint_is_ide
+ runit_in_hom(2) src_hcomp)
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)
+ 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')
+ 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')
+ 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')
+ 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)
+ 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)
+ 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 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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"
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 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
+ using assms(1-2) 0 trg_dom trg_cod 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))
+ 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'
+ 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'
+ using assms 1 k.antipar cospan \<chi> seqI'
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)
+ 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
+ using assms 4 k.antipar cospan assoc'_naturality [of k "k\<^sup>*" "h \<star> \<theta>"]
+ by fastforce
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 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
+ using assms 1 k.antipar cospan interchange comp_arr_dom comp_cod_arr
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'
+ using assms 4 k.antipar cospan whisker_left comp_arr_dom comp_cod_arr
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 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')
+ by (metis hcomp_simps(3-4) h.ide_left hseqI' ide_char in_homE trg_hcomp)
thus ?thesis
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 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 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 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 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 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 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')
+ using assms k.antipar 0 comp_cod_arr by simp
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 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 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
+ using assms 0 k.antipar cospan comp_assoc 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
+ by force
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
+ using assms k.antipar cospan k.adjoint_transpose_left(4) assoc_in_hom 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 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 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
+ apply (intro comp_in_homI) 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
+ apply (intro comp_in_homI) 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
+ using assms k.antipar cospan tab_in_hom by fastforce
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
+ using assms \<beta> k.antipar cospan tab_in_hom by fastforce
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)
+ 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)
+ 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)
+ 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)
+ 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 \<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 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 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 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)
+ 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)
+ composable tab_def
+ by 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)
+ 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)
+ 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 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 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
+ using composable \<rho>.T0.antipar(1) 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
+ composable 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')
+ by (intro seqI hseqI, auto)
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 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)
+ using \<rho>.T0.antipar(1) iso_inv_iso 1 by fastforce
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 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 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')
+ by (simp add: composable)
thus ?thesis
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 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
+ using assms(3) arrI \<rho>.T0.antipar(1) 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
+ using \<rho>.T0.antipar(1) 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)
+ using u \<omega> by fastforce
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))
+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<omega> 1 comp_arr_dom in_homE seqE hcomp_simps(1) vseq_implies_hpar(1)
+ by (metis src_hcomp)
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))
+ by (metis \<open>src w\<^sub>r = src u\<close> \<sigma>.leg1_simps(4) arr_dom in_hhomI in_homE r\<^sub>0s\<^sub>1.cospan
+ src_hcomp trg_hcomp vconn_implies_hpar(1) vconn_implies_hpar(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)
+ by (metis \<open>src w\<^sub>r = src u\<close> \<rho>.leg1_simps(4) arr_cod in_hhomI in_homE
+ src_hcomp trg_hcomp vconn_implies_hpar(3) vconn_implies_hpar(4))
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))
+ by (metis \<sigma>.leg0_simps(2) \<sigma>.tab_simps(2) \<theta>\<^sub>r_in_hom arrI hseqI' ideD(1) seqE
+ seq_if_composable src_hcomp vconn_implies_hpar(3))
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))
+ by (metis \<theta>\<^sub>r_in_hom arrI hseqE in_hhom_def seqE vconn_implies_hpar(1)
+ vconn_implies_hpar(3) w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
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))
+ by (metis \<nu>\<^sub>s_in_hom \<open>src \<nu>\<^sub>s = src u\<close> arrI seqE src_hcomp 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
+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<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 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 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 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)
+ apply (intro seqI' comp_in_homI) by 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 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')
+ 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 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
+ using \<theta>_def \<theta> whisker_left
+ by (metis (full_types) arrI cod_comp ide_base seqE seqI)
finally show ?thesis by simp
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> \<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 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
+ using r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t 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
+ using \<open>trg w = src p\<^sub>0\<close> by simp
thus ?thesis
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 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 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 blast
then show ?thesis
- using hseqI' assoc_naturality [of r "\<sigma> \<star> p\<^sub>0" w] composable by auto
+ using assoc_naturality [of r "\<sigma> \<star> p\<^sub>0" w] composable by auto
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> \<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
+ using w \<rho>.T0.antipar(1) composable 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')
+ using comp_cod_arr by (simp add: composable)
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')
+ by (simp add: composable)
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 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
+ using w \<rho>.T0.antipar(1) composable 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 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 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)
+ 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)
+ using \<rho>.T0.antipar(1) by fastforce
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)
+ using \<rho>.T0.antipar(1) by fastforce
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)
+ using \<rho>.T0.antipar(1) by force
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 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
+ proof -
+ have "(\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta> = \<beta>"
+ using comp_cod_arr \<rho>.T0.antipar(1) \<beta> comp_assoc_assoc' by simp
+ thus ?thesis by argo
+ qed
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 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 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
+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) 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')
+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_assoc_assoc' comp_cod_arr by simp
(* 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 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 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'
+ 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 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')
+ 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 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
+ by (metis \<sigma>.tab_simps(1) \<sigma>.tab_simps(4) hcomp_simps(4) in_homE
+ r\<^sub>0s\<^sub>1.leg0_simps(5))
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
+ by (metis \<sigma>.tab_simps(1) \<sigma>.tab_simps(5) hcomp_simps(3) in_homE
+ r\<^sub>0s\<^sub>1.leg0_simps(4))
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 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
+ using \<gamma>' assoc_naturality [of s s\<^sub>0 "p\<^sub>0 \<star> \<gamma>'"] \<open>hseq p\<^sub>0 \<gamma>'\<close> by force
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 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 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 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 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 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 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'
+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) 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
+ by (metis \<sigma>.ide_leg1 assoc'_simps(1) hseqE ideD(1) in_homE r\<^sub>0s\<^sub>1.ide_leg0
+ r\<^sub>0s\<^sub>1.p\<^sub>0_simps w w\<^sub>s)
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)
+ 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))
+ 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
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 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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))
+ by (metis B.hseqE B.ideD(1) B.in_hhom_def B.isomorphic_implies_hpar(3)
+ B.isomorphic_implies_ide(1) B.src_hcomp)
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)
+ 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 (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 (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 (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 (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 (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 (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 (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 (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 argo
have 2: "ide s\<^sub>1"
by simp
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
+ using in_hom \<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
+ using w in_hom 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)
+ 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
+ using assms in_hom 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>"
- using \<phi> w.the_\<theta>_props \<sigma>.leg0_in_hom(2) assms(2) comp_in_hom_simp' hcomp_in_vhom
+ using \<phi> w.the_\<theta>_props \<sigma>.leg0_in_hom(2) assms(2) comp_in_homI 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
+ 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
+ using w'.arrow_of_spans_of_maps_axioms 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 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)
+ 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 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 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'
+ using \<mu> assoc_naturality [of \<mu> "tab\<^sub>0 r" "(tab\<^sub>0 r)\<^sup>*"]
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 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
+ using \<mu> whisker_right \<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
+ using \<theta> by blast
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
+ using \<nu> \<mu>.the_\<nu>_props \<mu>.the_\<theta>_props \<pi>.the_\<nu>_props \<pi>.the_\<theta>_props
+ isos_compose [of "\<mu>.the_\<nu>" "\<pi>.the_\<nu>"] \<mu>.is_ide \<nu> \<open>ide (\<pi>.chine \<star> \<mu>.chine)\<close>
+ \<pi>.uw\<theta> \<pi>.w_simps(4) \<tau>.ide_leg1 \<tau>.leg1_simps(3) arrI hseq_char ideD(1)
+ ide_is_iso iso_assoc iso_hcomp isos_compose seqE
+ by metis
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
+ by (metis in_homE)
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
+ by (metis in_homE)
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 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 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 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)
+ using A f g pentagon 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 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 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)
+ using \<rho>\<sigma>.composable \<omega>.in_hom \<chi>.in_hom
+ 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)
+ by (intro comp_in_homI, 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
+ 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 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 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 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 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 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 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
+ using \<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
+ using \<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 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 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
+ using whisker_left \<rho>.T0.antipar(1) \<rho>\<sigma>.composable \<chi>.in_hom 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
+ using \<omega>.in_hom \<chi>.in_hom by force
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 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
+ using \<chi>.in_hom by force
thus ?thesis
- using comp_arr_dom comp_cod_arr \<omega>.in_hom \<chi>.in_hom hseqI' interchange
+ using comp_arr_dom comp_cod_arr \<omega>.in_hom \<chi>.in_hom interchange
by (metis in_homE)
qed
thus ?thesis
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 presburger
qed
also have "... = \<Delta>"
- using whisker_left hseqI' \<rho>\<sigma>.tab_def comp_assoc by simp
+ using whisker_left \<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
+ using comp_cod_arr \<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 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)
+ \<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 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
+ using pentagon t\<^sub>0u\<^sub>1.p\<^sub>1_simps uw\<theta> \<tau>.T0.antipar(1) 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 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 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')
+ by (simp add: \<tau>\<mu>.composable)
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>
\<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'
+ \<tau>\<mu>.composable 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
+ using comp_cod_arr \<tau>\<mu>.composable 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'
+ using comp_inv_arr' comp_cod_arr \<tau>\<mu>.composable 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 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'
+ using uw\<theta> whisker_right [of chine]
by (metis \<tau>\<mu>.tab_def \<tau>\<mu>.tab_in_vhom' arrI seqE)
thus ?thesis
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
+ monoE \<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
+ using epiE LHS RHS iso_is_retraction retraction_is_epi \<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 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
+ 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 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)
+ 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 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 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)
+ by 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
+ 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 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 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 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
+ using comp_inv_arr' comp_cod_arr 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)
+ using \<chi>.\<theta>_simps(3) by simp
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
+ using whisker_right 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 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 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
+ using comp_inv_arr' \<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
+ using comp_cod_arr 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
+ using comp_arr_inv' \<tau>.T0.antipar(1) 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
+ using comp_cod_arr \<tau>.T0.antipar(1) 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
+ ide_hcomp 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> =
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> =
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> =
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> =
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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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 \<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)
+ 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 (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 (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>) =
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 "... = 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 (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 (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 "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 "... = 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)
+ 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 = "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 = "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 = 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 = "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)
+ 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 = "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 = "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 = 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 = "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)
+ 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)
+ 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)
+ 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)
+ 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> 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 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 (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 (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 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)
+ 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')
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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 = 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>
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>)) =
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>)) =
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 "... = 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 =
"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 =
"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>"
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 "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 "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 "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
(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
(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
(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
(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 (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>)"
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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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')
+ 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 = 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)
+ 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)
+ 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)
+ 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 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]
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
+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps Tgh.composable 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
+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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 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
+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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
+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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
+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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'
+ 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
\<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'
+ 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
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'
+ 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
\<a>'_def \<alpha>_def
by simp
finally show ?thesis by blast
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>
((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'
+ 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
assoc_naturality [of f f\<^sub>0g\<^sub>1.\<phi> TTfgh.p\<^sub>1]
by simp
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>
((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'
+ 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
assoc_naturality [of f "g.tab \<star> Tfg.p\<^sub>0" TTfgh.p\<^sub>1]
by simp
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>
((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'
+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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 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'
+ using fg fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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 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'
+ 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
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'
+ 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
\<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'
+ 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
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'
+ 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
\<a>'_def \<alpha>_def
by simp
finally show ?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 \<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'
+ 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
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 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
+ using fg gh whisker_right whisker_left by simp
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>
((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)
+ using fg gh
+ 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 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'
+ 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
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'
+ 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
assoc'_naturality [of f.tab TfTgh.p\<^sub>1 TTfgh_TfTgh.chine]
by simp
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>
((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'
+ 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
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'
+ 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
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 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'
+ 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
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]
+ 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
+ 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 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'
+ 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
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 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'
+ 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
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 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'
+ 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
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 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'
+ 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
\<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'
+ 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
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'
+ 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
\<a>'_def \<alpha>_def
by simp
finally show ?thesis
using comp_assoc by presburger
qed
finally show ?thesis
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
+ using fg gh
+ apply (intro seqI) 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
+ using whisker_left f.ide_base by presburger
qed
thus ?thesis
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 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
+ using fg gh assoc_naturality [of f g "h \<star> TTfgh_TfTgh.the_\<theta>"] comp_assoc
by simp
finally show ?thesis
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 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'
+ using fg gh
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 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 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+
+ apply (intro comp_in_homI) 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 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
+ 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 (intro hcomp_in_vhom) 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
+ using f\<^sub>0gh\<^sub>1.\<phi>_in_hom
+ by (intro hcomp_in_vhom) 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
+ 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 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
+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr 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 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
+ 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 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 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
+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_uniqueness 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 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 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 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
+ using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps 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'
+ using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 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'
+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 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
+ using 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
+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps 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
+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps 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
+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps 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
+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps comp_cod_arr 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 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'
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 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'
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 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'
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 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'
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 presburger
qed
finally show ?thesis by simp
qed
thus ?thesis
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
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps 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
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps 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
+ using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps \<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
+ using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps \<a>'_def \<alpha>_def by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
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'
+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
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 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)
+ using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
+ 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
+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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
+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps 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
+ using comp_arr_dom fg\<^sub>0h\<^sub>1.p\<^sub>0_simps 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 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
+ using comp_cod_arr 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
+ using comp_cod_arr 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 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 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)
+ 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)
+ 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)
+ 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)
+ 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)
+ 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
+ using calculation(1) SPN_def [of ?f] REP_leg0.antipar 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')
+ 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')
+ 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'
+ using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom
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'
+ using w\<theta>\<nu> equivalence_is_adjoint Maps.REP_in_hhom
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'
+ using w\<theta>\<nu> Maps.CLS_eqI equivalence_is_adjoint
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'
+ using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom
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
+ using w\<theta>\<nu> equivalence_is_adjoint 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 = 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)
+ 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)
+ 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"]
+ using s 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)
+ 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/CanonicalIsos.thy b/thys/Bicategory/CanonicalIsos.thy
--- a/thys/Bicategory/CanonicalIsos.thy
+++ b/thys/Bicategory/CanonicalIsos.thy
@@ -1,693 +1,693 @@
(* Title: CanonicalIsomorphisms
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Canonical Isomorphisms"
text \<open>
In this section we develop some technology for working with canonical isomorphisms in a bicategory,
which permits them to be specified simply by giving syntactic terms that evaluate to the
domain and codomain, rather than often-cumbersome formulas expressed in terms of unitors and
associators.
\<close>
theory CanonicalIsos
imports Coherence
begin
context bicategory
begin
interpretation bicategorical_language ..
interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
notation E.eval ("\<lbrace>_\<rbrace>")
text \<open>
The next definition defines \<open>can u t\<close>, which denotes the unique canonical isomorphism
from \<open>\<lbrace>t\<rbrace>\<close> to \<open>\<lbrace>u\<rbrace>\<close>. The ordering of the arguments of \<open>can\<close> has been chosen to be the
opposite of what was used for \<open>hom\<close>. Having the arguments to \<open>can\<close> this way makes it easier
to see at a glance when canonical isomorphisms are composable. It could probably be argued
that \<open>hom\<close> should have been defined this way as well, but that choice is somewhat
well-entrenched by now and the argument for \<open>can\<close> is stronger, as it denotes an arrow and
therefore appears in expressions composed with other arrows, rather than just as a hypothesis
or conclusion.
\<close>
definition can
where "can u t \<equiv> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
subsection "Basic Properties"
text \<open>
The following develop basic properties of \<open>can\<close>.
\<close>
lemma can_in_hom [intro]:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "\<guillemotleft>can u t : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>u\<rbrace>\<guillemotright>"
proof -
let ?v = "Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>"
have 1: "Can ?v \<and> Dom ?v = t \<and> Cod ?v = u"
using assms red_in_Hom Can_red Inv_in_Hom Can_Inv(1) by simp
show "\<guillemotleft>can u t : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>u\<rbrace>\<guillemotright>"
unfolding can_def using 1 E.eval_in_hom Can_implies_Arr
by (metis (no_types, lifting))
qed
lemma can_simps [simp]:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "arr (can u t)" and "dom (can u t) = \<lbrace>t\<rbrace>" and "cod (can u t) = \<lbrace>u\<rbrace>"
using assms can_in_hom by auto
lemma inverse_arrows_can:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "iso (can u t)" and "inverse_arrows (can u t) (can t u)"
proof -
let ?v = "Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>"
have 1: "Can ?v \<and> Dom ?v = t \<and> Cod ?v = u"
using assms red_in_Hom Can_red Inv_in_Hom Can_Inv(1) by simp
show "iso (can u t)"
unfolding can_def using 1 E.iso_eval_Can by blast
show "inverse_arrows (can u t) (can t u)"
proof (unfold can_def)
show "inverse_arrows \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace>"
proof
show "ide (\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace>)"
proof -
have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)\<rbrace>"
by simp
also have "... = \<lbrace>u\<rbrace>"
proof (intro E.eval_eqI)
show 2: "VPar ((Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) u"
using assms 1 red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_implies_Arr
Can_red(1)
by (simp add: Dom_Ide Cod_Ide)
show "\<^bold>\<lfloor>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
proof -
have 3: "Can (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
using Arr.simps(4) Can.simps(4) Can_Inv(1) Can_red(1) 2 assms(1) assms(2)
by presburger
have "VSeq (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
using 2 Arr.simps(4) by blast
hence "Can (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<and> Can (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<and>
Dom (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) = Cod (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
using 3 1 by metis
thus ?thesis
by (metis (no_types) 2 Can.simps(4) Nmlize_Dom Dom_Ide Ide_Nmlize_Can
assms(2))
qed
qed
finally have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> = \<lbrace>u\<rbrace>"
by blast
moreover have "ide \<lbrace>u\<rbrace>"
using assms E.ide_eval_Ide by simp
ultimately show ?thesis by simp
qed
show "ide (\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>)"
proof -
have "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<rbrace>"
by simp
also have "... = \<lbrace>t\<rbrace>"
proof (intro E.eval_eqI)
show 2: "VPar ((Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t"
using assms 1 red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_implies_Arr
Can_red(1)
by (simp add: Dom_Ide Cod_Ide)
show "\<^bold>\<lfloor>(Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms 1 2
by (metis (full_types) Arr.simps(4) Can.simps(4) Can_Inv(1) Can_red(1)
Nml_Nmlize(4) Dom_Ide Ide_Nmlize_Can)
qed
finally have "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>t\<rbrace>"
by blast
moreover have "ide \<lbrace>t\<rbrace>"
using assms E.ide_eval_Ide by simp
ultimately show ?thesis by simp
qed
qed
qed
qed
lemma inv_can [simp]:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
shows "inv (can u t) = can t u"
using assms inverse_arrows_can by (simp add: inverse_unique)
lemma vcomp_can [simp]:
assumes "Ide t" and "Ide u" and "Ide v" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "\<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>v\<^bold>\<rfloor>"
shows "can v u \<cdot> can u t = can v t"
proof (unfold can_def)
have "\<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<rbrace>"
using assms by simp
also have "... = \<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
proof (intro E.eval_eqI)
show "VPar ((Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)"
using assms red_in_Hom Inv_in_Hom Ide_implies_Can
by (simp add: Can_red(1))
show "\<^bold>\<lfloor>(Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor>"
using assms Can_red(1) Nml_Nmlize(1) Nmlize_Inv Ide_Nmlize_Can
Ide_implies_Can \<open>VPar ((Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<close>
apply simp
by (metis red_simps(4) Nmlize_red Dom_Cod VcompNml_Nml_Dom)
qed
finally show "\<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
by blast
qed
lemma hcomp_can [simp]:
assumes "Ide t" and "Ide u" and "Ide v" and "Ide w" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "\<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>w\<^bold>\<rfloor>"
and "Src t = Trg v" and "Src u = Trg w"
shows "can u t \<star> can w v = can (u \<^bold>\<star> w) (t \<^bold>\<star> v)"
proof (unfold can_def)
have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<star> (Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>)\<rbrace>"
using assms by simp
also have "... = \<lbrace>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<rbrace>"
proof (intro E.eval_eqI)
show "VPar (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
proof -
have "Arr (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
proof -
have "Ide (u \<^bold>\<star> w)"
using assms by simp
hence "Can ((u \<^bold>\<star> w)\<^bold>\<down>)"
using assms Can_red by blast
thus ?thesis
using assms Can.simps(4) Can_Inv(1) Dom_Inv Can_implies_Arr Can_red(1)
red_simps(4) Nmlize.simps(3) Ide.simps(3)
by presburger
qed
moreover have "Arr (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>)"
using assms red_in_Hom Inv_in_Hom Ide_implies_Can
by (simp add: Can_red(1))
moreover have "Dom (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) =
Dom (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
using assms red_in_Hom Inv_in_Hom Ide_implies_Can
by (metis (no_types, lifting) Nml_HcompD(3-4) Dom.simps(3-4) red.simps(3)
red_Nml)
moreover have "Cod (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) =
Cod (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
using assms red_in_Hom Inv_in_Hom Ide_implies_Can red_Nml
by (simp add: Can_red(1) Cod_Ide)
ultimately show ?thesis by simp
qed
show "\<^bold>\<lfloor>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<^bold>\<rfloor>"
using assms Inv_in_Hom Ide_implies_Can Nmlize_Inv Ide_Nmlize_Can Can_red
red2_Nml
apply auto
using VcompNml_HcompNml [of u w u w]
apply (metis red_simps(4) Nml_HcompD(3-4) Nmlize_Nml red_simps(3) red_Nml)
apply (metis Nml_HcompD(3-4) Nmlize.simps(3) Nmlize_Nml
red_simps(3) Ide.simps(3) VcompNml_Nml_Dom red_Nml)
apply (metis Can_red2(1) red_simps(4) Nml_HcompD(3-4) Nmlize.simps(3)
Nmlize_Nml VcompNml_Cod_Nml red_Nml)
using red2_Nml Nmlize_red2 Can_red2(1) Nmlize_Hcomp Dom_Ide Ide_implies_Arr
VcompNml_Nml_Dom Nml_Nmlize(1) Nml_Nmlize(2) Nml_Nmlize(3)
Nmlize.simps(3)
by metis
qed
finally show "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<rbrace> = \<lbrace>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<rbrace>"
by blast
qed
subsection "Introduction Rules"
text \<open>
To make the \<open>can\<close> notation useful, we need a way to introduce it.
This is a bit tedious, because in general there can multiple \<open>can\<close>
notations for the same isomorphism, and we have to use the right ones in the
right contexts, otherwise we won't be able to compose them properly.
Thankfully, we don't need the inverse versions of the theorems below,
as they are easily provable from the non-inverse versions using \<open>inv_can\<close>.
\<close>
lemma canI_unitor_0:
assumes "ide f"
shows "\<l>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
and "\<r>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
proof -
have "can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) = \<lbrace>\<^bold>\<l>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus 1: "\<l>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
using assms by (simp add: \<ll>_ide_simp)
have "can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus "\<r>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
using assms by (simp add: \<rr>_ide_simp)
qed
lemma canI_unitor_1:
assumes "obj a"
shows "\<l>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
and "\<r>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
proof -
have "can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<l>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus 1: "\<l>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
using assms by (auto simp add: \<ll>_ide_simp)
have "can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus "\<r>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
using assms by (auto simp add: \<rr>_ide_simp)
qed
lemma canI_associator_0:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "\<a>[f, g, h] = 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>)"
proof -
have "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>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus "\<a>[f, g, h] = 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>)"
using assms by (simp add: \<alpha>_def)
qed
lemma canI_associator_1:
assumes "ide f" and "ide g" and "src f = trg g"
shows "\<a>[trg f, f, g] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
and "\<a>[f, src f, g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
and "\<a>[f, g, src g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0)"
proof -
show "\<a>[trg f, f, g] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
proof -
have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by simp
qed
show "\<a>[f, src f, g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
proof -
have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>g\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by simp
qed
show "\<a>[f, g, src g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0)"
proof -
have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by simp
qed
qed
lemma canI_associator_2:
assumes "ide f"
shows "\<a>[trg f, trg f, f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
and "\<a>[trg f, f, src f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
and "\<a>[f, src f, src f] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
proof -
show "\<a>[trg f, trg f, f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
proof -
have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by simp
qed
show "\<a>[trg f, f, src f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
proof -
have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by simp
qed
show "\<a>[f, src f, src f] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
proof -
have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) =
\<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by simp
qed
qed
lemma canI_associator_3:
assumes "obj a"
shows "\<a>[a, a, a] = can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
proof -
have "can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
unfolding can_def using assms by (intro E.eval_eqI, simp_all)
thus ?thesis
using assms \<alpha>_def by auto
qed
lemma canI_associator_hcomp:
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>[f \<star> g, h, k] = can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^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>k\<^bold>\<rangle>)"
and "\<a>[f, g \<star> h, k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^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>k\<^bold>\<rangle>)"
and "\<a>[f, g, h \<star> k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^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>k\<^bold>\<rangle>)"
proof -
show "\<a>[f \<star> g, h, k] = can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^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>k\<^bold>\<rangle>)"
proof -
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>k\<^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>k\<^bold>\<rangle>) =
(((f \<star> g) \<star> h \<star> k) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, h \<star> k] \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot>
((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> (g \<star> h \<star> k) \<cdot> (g \<star> h \<star> k) \<cdot> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k]) \<cdot>
(((f \<star> g \<star> h) \<cdot> (f \<star> g \<star> h) \<cdot> \<a>[f, g, h]) \<cdot> ((f \<star> g) \<star> h) \<star> k)"
unfolding can_def using assms \<alpha>_def \<a>'_def \<alpha>'.map_ide_simp by simp
also have "... = \<a>\<^sup>-\<^sup>1[f, g, h \<star> k] \<cdot> (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)"
- using assms comp_arr_dom comp_cod_arr comp_assoc hseqI' by simp
+ using assms comp_arr_dom comp_cod_arr comp_assoc by simp
also have "... = \<a>[f \<star> g, h, k]"
using assms pentagon [of f g h k] invert_side_of_triangle(1) \<alpha>_def \<alpha>'.map_ide_simp
- assoc_simps(1) assoc_simps(4) assoc_simps(5) ideD(1) iso_assoc preserves_ide seqI
+ assoc_simps(1,4-5) ideD(1) iso_assoc preserves_ide seqI
by simp
finally show ?thesis by simp
qed
show "\<a>[f, g \<star> h, k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^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>k\<^bold>\<rangle>)"
proof -
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>k\<^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>k\<^bold>\<rangle>) =
((f \<star> ((g \<star> h) \<star> k) \<cdot> (\<a>\<^sup>-\<^sup>1[g, h, k] \<cdot> (g \<star> h \<star> k)) \<cdot> (g \<star> h \<star> k)) \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot>
((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> (g \<star> h \<star> k) \<cdot> (g \<star> h \<star> k) \<cdot> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k]) \<cdot>
((f \<star> g \<star> h) \<star> k)"
unfolding can_def using assms \<alpha>_def \<alpha>'.map_ide_simp \<a>'_def by simp
also have "... = ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, k]) \<cdot> (f \<star> \<a>[g, h, k])) \<cdot> \<a>[f, g \<star> h, k]"
- using assms comp_arr_dom comp_cod_arr comp_assoc hseqI' by simp
+ using assms comp_arr_dom comp_cod_arr comp_assoc by simp
also have "... = \<a>[f, g \<star> h, k]"
using assms comp_cod_arr whisker_left [of f "\<a>\<^sup>-\<^sup>1[g, h, k]" "\<a>[g, h, k]"]
comp_assoc_assoc'
by simp
finally show ?thesis by simp
qed
show "\<a>[f, g, h \<star> k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^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>k\<^bold>\<rangle>)"
proof -
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>k\<^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>k\<^bold>\<rangle>) =
(f \<star> g \<star> h \<star> k) \<cdot> ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> g \<star> h \<star> k) \<cdot> \<a>[f, g, h \<star> k]) \<cdot> ((f \<star> g) \<star> h \<star> k)"
unfolding can_def using assms \<alpha>_def \<alpha>'.map_ide_simp by simp
also have "... = \<a>[f, g, h \<star> k]"
using assms comp_arr_dom comp_cod_arr by simp
finally show ?thesis by simp
qed
qed
subsection "Rules for Eliminating `can'"
text \<open>
The following rules are used for replacing \<open>can\<close> in an expression by terms expressed
using unit and associativity isomorphisms. They are not really expressed in the form
of elimination rules, so the names are perhaps a bit misleading. They are typically
applied as simplifications.
\<close>
lemma canE_unitor:
assumes "Ide f"
shows "can f (f \<^bold>\<star> Src f) = \<r>[\<lbrace>f\<rbrace>]"
and "can f (Trg f \<^bold>\<star> f) = \<l>[\<lbrace>f\<rbrace>]"
and "can (f \<^bold>\<star> Src f) f = \<r>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
and "can (Trg f \<^bold>\<star> f) f = \<l>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
proof -
show 1: "can f (f \<^bold>\<star> Src f) = \<r>[\<lbrace>f\<rbrace>]"
proof -
have f: "\<not>Nml (f \<^bold>\<star> Src f)"
using assms Nml_HcompD(5) is_Prim0_Src by blast
have "can f (f \<^bold>\<star> Src f) = \<lbrace>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)\<rbrace>"
using assms f can_def by simp
also have "... = \<lbrace>\<^bold>\<r>\<^bold>[f\<^bold>]\<rbrace>"
proof (intro E.eval_eqI)
show "VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)) \<^bold>\<r>\<^bold>[f\<^bold>]"
using assms Nmlize_in_Hom red_in_Hom red2_in_Hom Inv_in_Hom Can_red Can_implies_Arr
Nml_Nmlize(1) Ide_implies_Can Nml_Src Nml_implies_Arr
HcompNml_Nml_Src Ide_Cod
apply (simp add: Dom_Ide Cod_Ide)
apply (intro conjI)
proof -
assume f: "Ide f"
have 1: "Nml (Src f)"
proof -
have "Ide (Src f)"
using f by simp
thus ?thesis
using f Obj_Src Nml_Nmlize(1) Nmlize_Src(2) Ide_implies_Arr
by metis
qed
show "Arr (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>)"
using f 1 Can_red2 Ide_Nmlize_Ide Nml_Nmlize by simp
show "Dom (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) = \<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>"
using f 1 Nml_Nmlize red2_in_Hom Ide_Nmlize_Ide by auto
show "\<^bold>\<lfloor>f\<^bold>\<rfloor> = Cod (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>)"
proof -
have "Src \<^bold>\<lfloor>f\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>Src f\<^bold>\<rfloor>"
using f Nml_Nmlize by simp
moreover have "\<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
using f 1 Nml_Nmlize Nmlize_Src HcompNml_Nml_Src Nml_Src
by (auto simp add: HcompNml_Nml_Obj)
thus ?thesis
using f 1 Obj_Src red2_in_Hom [of "\<^bold>\<lfloor>f\<^bold>\<rfloor>" "\<^bold>\<lfloor>Src f\<^bold>\<rfloor>"] HcompNml_Nml_Src
Nml_Nmlize Ide_Nmlize_Ide
by auto
qed
qed
show "\<^bold>\<lfloor>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<r>\<^bold>[f\<^bold>]\<^bold>\<rfloor>"
using assms f HcompNml_Nml_Src Nml_Nmlize Can_red Nmlize_Hcomp
Nmlize_Inv Nmlize_Src(1) Nmlize_red Nmlize_red2
Ide_Nmlize_Can VcompNml_Nml_Ide red_Src
apply (simp add: HcompNml_Nml_Obj)
proof -
assume f: "Ide f"
have "\<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> Src f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
proof -
have "Obj (Src f)"
using f Obj_Src by simp
thus ?thesis
using f apply (cases "Src f")
by (simp_all add: Nml_Nmlize(1) Nml_Nmlize(2) Ide_Nmlize_Ide)
qed
thus "\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> Src f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
by (metis Cod_Inv Can_red(1) Cod.simps(4) Nmlize.simps(4)
Nmlize.simps(7) Nmlize_Vcomp_Cod_Arr red_simps(3)
\<open>VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)) \<^bold>\<r>\<^bold>[f\<^bold>]\<close> f)
qed
qed
also have "... = \<r>[\<lbrace>f\<rbrace>]"
using assms E.eval_Runit_Ide by blast
finally show ?thesis by simp
qed
show 2: "can f (Trg f \<^bold>\<star> f) = \<l>[\<lbrace>f\<rbrace>]"
proof -
have f: "\<not>Nml (Trg f \<^bold>\<star> f)"
using assms by (metis Nml.simps(4) Nml_HcompD(6))
have "can f (Trg f \<^bold>\<star> f) = \<lbrace>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)\<rbrace>"
using assms f can_def by simp
also have "... = \<lbrace>\<^bold>\<l>\<^bold>[f\<^bold>]\<rbrace>"
proof (intro E.eval_eqI)
show "VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)) \<^bold>\<l>\<^bold>[f\<^bold>]"
using assms Nmlize_in_Hom red_in_Hom red2_in_Hom Inv_in_Hom Can_red Can_implies_Arr
Nml_Nmlize(1) Ide_implies_Can Nml_Trg Nml_implies_Arr
HcompNml_Trg_Nml Ide_Cod Nmlize_Trg(1)
apply (simp add: Dom_Ide Cod_Ide)
apply (intro conjI)
proof -
assume f: "Ide f"
have 1: "Nml (Trg f)"
proof -
have "Ide (Trg f)"
using f by simp
thus ?thesis
using f Obj_Trg Nml_Nmlize(1) Nmlize_Trg(2) Ide_implies_Arr
by metis
qed
show "Arr (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>)"
using f 1 Can_red2 Ide_Nmlize_Ide Nml_Nmlize(1,3) by simp
show "Dom (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) = Trg f \<^bold>\<star> \<^bold>\<lfloor>f\<^bold>\<rfloor>"
using f Obj_Trg 1 Nml_Nmlize(1,3) red2_in_Hom Ide_Nmlize_Ide by auto
show "\<^bold>\<lfloor>f\<^bold>\<rfloor> = Cod (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>)"
proof -
have "Src (Trg f) = Trg \<^bold>\<lfloor>f\<^bold>\<rfloor>"
using f Nml_Nmlize(3) by simp
thus ?thesis
using f 1 Obj_Trg HcompNml_Trg_Nml Nml_Nmlize(1) Ide_Nmlize_Ide by auto
qed
qed
show "\<^bold>\<lfloor>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<l>\<^bold>[f\<^bold>]\<^bold>\<rfloor>"
using assms f HcompNml_Nml_Src Nml_Nmlize Can_red Nmlize_Hcomp
Nmlize_Inv Nmlize_Trg(1) Nmlize_red Nmlize_red2
Ide_Nmlize_Can VcompNml_Nml_Ide red_Trg
apply (simp add: HcompNml_Obj_Nml)
proof -
assume f: "Ide f"
have "\<^bold>\<lfloor>Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
proof -
have "Obj (Trg f)"
using f Obj_Trg by simp
thus ?thesis
using f apply (cases "Trg f")
by (simp_all add: Nml_Nmlize(1) Nml_Nmlize(2) Ide_Nmlize_Ide)
qed
thus "\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
by (metis Cod_Inv Can_red(1) Cod.simps(4) Nmlize.simps(4)
Nmlize.simps(5) Nmlize_Vcomp_Cod_Arr red_simps(3)
\<open>VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)) \<^bold>\<l>\<^bold>[f\<^bold>]\<close> f)
qed
qed
also have "... = \<l>[\<lbrace>f\<rbrace>]"
using assms E.eval_Lunit_Ide by blast
finally show ?thesis by simp
qed
show "can (f \<^bold>\<star> Src f) f = \<r>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
using assms 1 inv_can inv_inv
by (metis (no_types, lifting) Nml_Nmlize(1) Nmlize.simps(3)
Nmlize_Src(1) HcompNml_Nml_Src Ide.simps(3) Ide_implies_Arr
Obj_Src Obj_implies_Ide Trg_Src)
show "can (Trg f \<^bold>\<star> f) f = \<l>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
using assms 2 inv_can inv_inv
by (metis (no_types, lifting) Nml_Nmlize(1) Nmlize.simps(3)
Nmlize_Trg(1) HcompNml_Trg_Nml Ide.simps(3) Ide_implies_Arr
Obj_Trg Obj_implies_Ide Src_Trg)
qed
lemma canE_associator:
assumes "Ide f" and "Ide g" and "Ide h" and "Src f = Trg g" and "Src g = Trg h"
shows "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
and "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
proof -
show "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
proof -
have "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<lbrace>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<rbrace>"
using can_def by simp
also have "... = \<lbrace>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<rbrace>"
proof (intro E.eval_eqI)
have 1: "Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down> \<in> VHom ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h)"
using assms Inv_in_Hom [of "(f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>"] Can_red [of "f \<^bold>\<star> g \<^bold>\<star> h"]
red_in_Hom [of "f \<^bold>\<star> g \<^bold>\<star> h"] red_in_Hom [of "(f \<^bold>\<star> g) \<^bold>\<star> h"]
Nmlize_Hcomp_Hcomp Nmlize_Hcomp_Hcomp'
Ide_implies_Arr Nml_HcompNml Nmlize_Nml Ide_HcompNml
by auto
show par: "VPar (Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<a>\<^bold>[f, g, h\<^bold>]"
using assms 1 Inv_in_Hom red_in_Hom Ide_in_Hom by simp
show "\<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
proof -
have "Can (Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>)"
(* Here presburger depends on par being at the end, not after assms. *)
using assms Nmlize_Inv Can_Inv
Arr.simps(10) Arr.simps(4) Can.simps(4) Can_red(1) Ide.simps(3)
Src.simps(3) Trg.simps(3) par
by presburger
hence "Ide \<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
using Ide_Nmlize_Can by blast
thus ?thesis
using Ide_in_Hom Dom_Ide by presburger
qed
also have 6: "... = \<^bold>\<lfloor>(f \<^bold>\<star> g) \<^bold>\<star> h\<^bold>\<rfloor>"
using 1 Nmlize_Dom [of "Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>"]
by (metis (mono_tags, lifting) mem_Collect_eq)
also have 5: "... = Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
using assms 6 par Nmlize_Dom Nml_Nmlize(4) by metis
also have "... = \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
using assms 5 Ide_in_Hom by auto
finally show ?thesis by simp
qed
qed
also have "... = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
using assms E.eval_Assoc_Ide \<alpha>_def by fastforce
finally show ?thesis by simp
qed
show "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
proof -
have "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<lbrace>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<rbrace>"
using can_def by simp
also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<rbrace>"
proof (intro E.eval_eqI)
have 1: "Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down> \<in> VHom (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h)"
using assms Inv_in_Hom [of "((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>"] Can_red [of "(f \<^bold>\<star> g) \<^bold>\<star> h"]
red_in_Hom [of "(f \<^bold>\<star> g) \<^bold>\<star> h"] red_in_Hom [of "f \<^bold>\<star> g \<^bold>\<star> h"]
Nmlize_Hcomp_Hcomp Nmlize_Hcomp_Hcomp'
Ide_implies_Arr Nml_HcompNml Nmlize_Nml Ide_HcompNml
by auto
show par: "VPar (Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]"
using assms 1 Inv_in_Hom red_in_Hom Ide_in_Hom by simp
show "\<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
proof -
have "\<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
proof -
have "Can (Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>)"
using assms Nmlize_Inv Can_Inv
Arr.simps(10) Arr.simps(4) Can.simps(4) Can_red(1) Ide.simps(3)
Src.simps(3) Trg.simps(3) par
by presburger
hence "Ide \<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
using Ide_Nmlize_Can by blast
thus ?thesis
using Ide_in_Hom Dom_Ide by presburger
qed
also have 6: "... = \<^bold>\<lfloor>f \<^bold>\<star> g \<^bold>\<star> h\<^bold>\<rfloor>"
using 1 Nmlize_Dom [of "Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>"]
by (metis (mono_tags, lifting) mem_Collect_eq)
also have 5: "... = Dom \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
using assms 6 par Nmlize_Dom Nml_Nmlize(4) by metis
also have "... = \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
using assms 5 Ide_in_Hom by auto
finally show ?thesis by simp
qed
qed
also have "... = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
using assms E.eval_Assoc'_Ide by fastforce
finally show ?thesis by simp
qed
qed
lemma can_Ide_self:
assumes "Ide t"
shows "can t t = \<lbrace>t\<rbrace>"
proof (unfold can_def)
show "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>t\<rbrace>"
proof (intro E.eval_eqI)
show "VPar (Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t"
using assms red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_red(1) Ide_in_Hom(2)
by auto
show "\<^bold>\<lfloor>Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
using assms red_in_Hom Inv_in_Hom Ide_implies_Can Cod_Inv
by (metis (mono_tags, lifting) Can_red(1) Nml_Nmlize(1) Nmlize.simps(4)
Nmlize_Inv Ide_Nmlize_Ide Nmlize_red Inv_Ide VcompNml_Ide_Nml
\<open>VPar (Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t\<close>)
qed
qed
subsection "Rules for Whiskering"
lemma whisker_can_right_0:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "ide f" and "Src t = \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0"
shows "can u t \<star> f = can (u \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) (t \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
proof -
have "f = can \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<langle>f\<^bold>\<rangle>"
using assms can_Ide_self by simp
thus ?thesis
using assms Ide_implies_Arr hcomp_can
by (metis Nml_Nmlize(2) Ide.simps(2) Trg.simps(2))
qed
lemma whisker_can_right_1:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "obj a" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
shows "can u t \<star> a = can (u \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) (t \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
proof -
have "a = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
using assms can_Ide_self by auto
thus ?thesis
using assms Ide_implies_Arr hcomp_can
by (metis Nml_Nmlize(2) Ide.simps(1) Trg.simps(1))
qed
lemma whisker_can_left_0:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "ide g" and "Trg t = \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0"
shows "g \<star> can u t = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> u) (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> t)"
proof -
have "g = can \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<langle>g\<^bold>\<rangle>"
using assms can_Ide_self by simp
thus ?thesis
using assms Ide_implies_Arr hcomp_can
by (metis Nml_Nmlize(3) Ide.simps(2) Src.simps(2))
qed
lemma whisker_can_left_1:
assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "obj b" and "Trg t = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
shows "b \<star> can u t = can (\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> u) (\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> t)"
proof -
have "b = can \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
using assms can_Ide_self by auto
thus ?thesis
using assms Ide_implies_Arr hcomp_can
by (metis Nml_Nmlize(3) Ide.simps(1) Src.simps(1))
qed
end
end
diff --git a/thys/Bicategory/Coherence.thy b/thys/Bicategory/Coherence.thy
--- a/thys/Bicategory/Coherence.thy
+++ b/thys/Bicategory/Coherence.thy
@@ -1,3957 +1,3960 @@
(* 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)
+ apply (cases w) by 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>)"
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
+ using 4 VVV.arr_char VV.arr_char 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
+ using 4 VVV.arr_char VV.arr_char 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
+ using 4 VVV.arr_char VV.arr_char 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'
+ using tuv iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3) \<alpha>_def
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)
+ by (simp add: eval_simps'(2) eval_simps'(3) 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'
+ using t 1 lunit_in_hom Nmlize_in_Hom ide_eval_Ide red_in_Hom comp_cod_arr
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')
+ using t red_in_Hom red_Src Obj_Src eval_simps'
+ by (simp add: ide_eval_Ide ide_in_hom(2))
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))
+ using assms runit_naturality [of "\<lbrace>a \<^bold>\<Down> b\<rbrace>"] arr_dom in_homE src_dom src_hcomp
+ hcomp_simps(1)
+ by (elim in_homE, metis)
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')
+ by (auto simp add: eval_simps')
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')
+ by (simp add: eval_simps')
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')
+ by (simp add: eval_simps')
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')
+ by (auto 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>
((\<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')
+ by (simp add: eval_simps')
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')
+ by (simp add: eval_simps')
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')
+ apply (simp add: eval_simps')
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')
+ by (simp_all add: eval_simps')
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')
+ by (simp add: eval_simps')
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>)"
+ moreover have "\<guillemotleft>E f \<star> \<lbrace>u\<rbrace> : E (C.dom f) \<star> \<lbrace>Dom u\<rbrace> \<Rightarrow> E (C.cod f) \<star> \<lbrace>Cod u\<rbrace>\<guillemotright>"
using f u fu Nml_implies_Arr
- by (auto simp add: eval_simps' hseqI')
+ apply (intro hcomp_in_vhom)
+ apply auto
+ by (metis C.src_dom eval_simps(4) preserves_src trg_dom u)
ultimately show ?thesis
using f u comp_arr_dom comp_cod_arr
- by (simp add: fu hseqI')
+ by (simp add: fu)
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')
+ by (simp add: eval_simps')
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/InternalAdjunction.thy b/thys/Bicategory/InternalAdjunction.thy
--- a/thys/Bicategory/InternalAdjunction.thy
+++ b/thys/Bicategory/InternalAdjunction.thy
@@ -1,3454 +1,3435 @@
(* 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
+ using E.antipar whisker_left 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
+ using E.antipar 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
+ using E.antipar whisker_right 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
+ using assms \<mu> antipar whisker_left comp_assoc 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
+ using assms \<mu> antipar whisker_right 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
+ using assms \<nu> antipar interchange [of g "g \<cdot> g \<cdot> g"] comp_assoc 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
+ using assms antipar comp_arr_dom comp_assoc 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
+ using assms antipar comp_cod_arr 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
+ using assms antipar whisker_right 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
+ using assms \<mu> antipar whisker_right comp_assoc 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
+ proof -
+ have "arr v \<and> dom v = v \<and> cod v = v"
+ using assms(2) ide_char by blast
+ moreover have "arr g \<and> dom g = g \<and> cod g = g"
+ using ide_right ide_char by blast
+ ultimately show ?thesis
+ by (metis (no_types) antipar(2) assms(3-4) assoc_naturality
+ counit_simps(1,3,5) hcomp_reassoc(1) comp_assoc)
+ qed
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
+ using assms antipar comp_cod_arr 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
+ using assms antipar whisker_left 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
+ using assms \<nu> antipar whisker_right comp_assoc 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
+ using assms antipar whisker_left 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'
+ using assms antipar strict_runit' comp_arr_ide [of "\<r>\<^sup>-\<^sup>1[v]" "v \<star> \<eta>"] hcomp_arr_obj
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
+ using assms antipar strict_runit comp_ide_arr hcomp_arr_obj 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
+ using assms trnl\<^sub>\<eta>_def antipar strict_lunit comp_arr_dom hcomp_obj_arr 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
+ using assms trnl\<^sub>\<epsilon>_def antipar strict_lunit comp_cod_arr hcomp_obj_arr 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
+ using assms antipar 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
+ using assms antipar unit_in_hom by simp
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
+ using assms antipar unit_in_hom by simp
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
+ using assms A.antipar whisker_right whisker_left 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
+ using assms A.antipar comp_inv_arr inv_is_inverse 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
+ using assms A.antipar comp_cod_arr 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
+ using assms 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'
+ using assms A.antipar comp_arr_dom comp_cod_arr
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'
+ interchange [of "\<phi> \<star> f" "g \<star> f" g "inv \<phi>"]
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
+ using assms A.antipar whisker_left whisker_right 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
+ using assms A.antipar comp_inv_arr inv_is_inverse 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
+ using assms A.antipar comp_cod_arr 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
+ using assms 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>) = (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'
+ using assms(2-3) A.antipar comp_arr_dom comp_cod_arr
interchange [of "inv \<phi>" f' "g \<star> f'" "g \<star> \<phi>"]
interchange [of f "inv \<phi>" "g \<star> \<phi>" "g \<star> f"]
by auto
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
+ by (metis A.counit_simps(1) A.counit_simps(2) A.counit_simps(3) in_homE)
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'
+ using antipar D.isos_compose C.VV.ide_char C.VV.arr_char \<Phi>_simps(4)
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.arr_char \<Phi>_simps(4) D.hseqI'
+ using antipar D.isos_compose C.VV.arr_char \<Phi>_simps(4)
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'
+ using antipar D.inv_comp C.VV.ide_char C.VV.arr_char \<Phi>_simps(4)
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'
+ using antipar \<Phi>.naturality [of "(\<epsilon>, f)"] C.VV.arr_char FF_def
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'
+ using antipar \<Phi>.naturality [of "(f, \<eta>)"] C.VV.arr_char FF_def
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
+ using antipar D.comp_arr_inv' D.comp_cod_arr 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
+ using antipar 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'
+ using \<Psi>_char(2)
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)
+ apply (intro D.isos_compose, auto)
+ by (metis C.iso_assoc D.comp_assoc D.seqE ide_left ide_right
+ preserves_assoc(1) preserves_iso)
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
+ using antipar C.VV.arr_char 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
+ by (metis C.iso_assoc D.comp_assoc D.iso_is_arr D.seqE
+ \<open>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]\<close>
+ antipar(1) antipar(2) ide_left ide_right preserves_assoc(1) preserves_iso)
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)
+ using antipar D.iso_is_arr
+ apply (intro D.seqI) by 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
+ using antipar D.comp_cod_arr D.whisker_right 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'
+ using antipar C.VV.arr_char \<Phi>.naturality [of "(g, \<epsilon>)"] FF_def
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)
+ using preserves_iso \<Psi>_char(2) D.arrI D.seqE ide_right runit_coherence
+ by (intro D.isos_compose D.seqI, 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
+ using assms A.antipar 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'
+ FF_def
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
+ using assms A.antipar 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'
+ using assms A.antipar \<Phi>_components_are_iso C.VV.arr_char FF_def
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))
+ apply (intro hcomp_in_vhom) by auto
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')
+ by simp
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
+ by (metis fg.counit_simps(1) fg.counit_simps(2) fg.counit_simps(3)
+ hk.unit_simps(1) hk.unit_simps(2) hk.unit_simps(3))
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')
+ by simp
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')
+ by simp
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')
+ by simp
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
+ by (metis fg.counit_simps(1) fg.counit_simps(2) fg.counit_simps(3)
+ hk.unit_simps(1) hk.unit_simps(2) hk.unit_simps(3))
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')
+ by simp
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')
+ by simp
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
+ using antipar inv_comp iso_inv_iso isos_compose comp_assoc 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
+ using 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
+ using antipar inv_comp iso_inv_iso isos_compose comp_assoc 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
+ using 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
+ using f_in_hhom g_in_hhom b hcomp_obj_arr [of ?b "f \<star> g"] 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
+ iso_inv_iso isos_compose
+ by (metis \<epsilon>_in_hom arrI hseqE ide_is_iso iso_hcomp seqE)
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
+ using b \<eta>_in_hhom hcomp_obj_arr [of ?b "f \<star> \<eta>"] 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'
+ using f_in_hhom ide_f g_in_hhom ide_g \<eta>_in_hhom \<eta>_in_hom iso_\<eta>
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
+ using \<xi>_in_hhom iso_\<xi> hcomp_assoc 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)
+ using E.antipar
+ by (intro seqI, 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'
+ using ide_f ide_g E.antipar triangle_right strict_assoc' comp_ide_arr
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)
+ using E.antipar
+ by (intro seqI, 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'
+ using ide_f ide_g E.antipar triangle_right strict_assoc comp_ide_arr
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(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
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(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 (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
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 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.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 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.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 "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
+ using UP.\<Psi>_char UP.\<Phi>_components_are_iso VV.arr_char S.UP_map\<^sub>0_obj
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))"]
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'
+ hcomp_arr_obj
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')
+ 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'
+ whisker_left comp_arr_dom comp_cod_arr
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')
+ by (simp add: hcomp_assoc)
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')
+ by (simp add: hcomp_assoc)
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')
+ by (simp add: A.triangle_left)
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)
+ by (metis A'.ide_right A'.triangle_in_hom(2) A.ide_left arrI assoc_is_natural_2
+ ide_char seqE strict_assoc)
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')
+ by (simp add: hcomp_assoc)
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')
+ by (simp add: hcomp_assoc)
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')
+ by (simp add: A'.triangle_left)
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)
+ by (metis A.ide_left A.ide_right A.triangle_in_hom(2) arrI assoc_is_natural_2
+ ide_char seqE strict_assoc)
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 \<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/InternalEquivalence.thy b/thys/Bicategory/InternalEquivalence.thy
--- a/thys/Bicategory/InternalEquivalence.thy
+++ b/thys/Bicategory/InternalEquivalence.thy
@@ -1,1108 +1,1116 @@
(* Title: InternalEquivalence
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Internal Equivalences"
theory InternalEquivalence
imports Bicategory
begin
text \<open>
An \emph{internal equivalence} in a bicategory consists of antiparallel 1-cells \<open>f\<close> and \<open>g\<close>
together with invertible 2-cells \<open>\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>\<close>.
Objects in a bicategory are said to be \emph{equivalent} if they are connected by an
internal equivalence.
In this section we formalize the definition of internal equivalence and the related notions
``equivalence map'' and ``equivalent objects'', and we establish some basic facts about
these notions.
\<close>
subsection "Definition of Equivalence"
text \<open>
The following locale is defined to prove some basic facts about an equivalence
(or an adjunction) in a bicategory that are ``syntactic'' in the sense that they depend
only on the configuration (source, target, domain, codomain) of the arrows
involved and not on further properties such as the triangle identities (for adjunctions)
or assumptions about invertibility (for equivalences). Proofs about adjunctions and
equivalences become more automatic once we have introduction and simplification rules in
place about this syntax.
\<close>
locale adjunction_data_in_bicategory =
bicategory +
fixes f :: 'a
and g :: 'a
and \<eta> :: 'a
and \<epsilon> :: 'a
assumes ide_left [simp]: "ide f"
and ide_right [simp]: "ide g"
and unit_in_vhom: "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>"
and counit_in_vhom: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>"
begin
(*
* TODO: It is difficult to orient the following equations to make them useful as
* default simplifications, so they have to be cited explicitly where they are used.
*)
lemma antipar (*[simp]*):
shows "trg g = src f" and "src g = trg f"
apply (metis counit_in_vhom ideD(1) ide_right iso_is_arr not_arr_null
seq_if_composable src.components_are_iso trg.is_extensional trg_src
vconn_implies_hpar(4))
by (metis horizontal_homs.vconn_implies_hpar(4) horizontal_homs_axioms ideD(1)
ide_left iso_is_arr not_arr_null seq_if_composable src.components_are_iso
trg.is_extensional trg_src unit_in_vhom)
lemma counit_in_hom [intro]:
shows "\<guillemotleft>\<epsilon> : trg f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> trg f\<guillemotright>"
using counit_in_vhom vconn_implies_hpar antipar by auto
lemma unit_in_hom [intro]:
shows "\<guillemotleft>\<eta> : src f \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>"
using unit_in_vhom vconn_implies_hpar antipar by auto
lemma unit_simps [simp]:
shows "arr \<eta>" and "dom \<eta> = src f" and "cod \<eta> = g \<star> f"
and "src \<eta> = src f" and "trg \<eta> = src f"
using unit_in_hom antipar by auto
lemma counit_simps [simp]:
shows "arr \<epsilon>" and "dom \<epsilon> = f \<star> g" and "cod \<epsilon> = trg f"
and "src \<epsilon> = trg f" and "trg \<epsilon> = trg f"
using counit_in_hom antipar by auto
text \<open>
The expressions found in the triangle identities for an adjunction come up
relatively frequently, so it is useful to have established some basic facts
about them, even if the triangle identities themselves have not actually been
introduced as assumptions in the current context.
\<close>
lemma triangle_in_hom:
shows "\<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>"
and "\<guillemotleft>(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) : trg g \<star> g \<Rightarrow> g \<star> src g\<guillemotright>"
and "\<guillemotleft>\<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 \<Rightarrow> f\<guillemotright>"
and "\<guillemotleft>\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g\<guillemotright>"
- using antipar hseqI' by auto
+ using antipar by auto
lemma triangle_equiv_form:
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>
\<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"
and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<longleftrightarrow>
\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
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] \<longleftrightarrow>
\<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"
proof
assume 1: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
have "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] =
\<l>[f] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<r>\<^sup>-\<^sup>1[f]"
using comp_assoc by simp
also have "... = \<l>[f] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<r>\<^sup>-\<^sup>1[f]"
using 1 by simp
also have "... = f"
using comp_assoc comp_arr_inv' comp_inv_arr' iso_lunit iso_runit
comp_arr_dom comp_cod_arr
by simp
finally show "\<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"
by simp
next
assume 2: "\<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"
have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = \<l>\<^sup>-\<^sup>1[f] \<cdot> f \<cdot> \<r>[f]"
using comp_cod_arr by simp
also have "... = (\<l>\<^sup>-\<^sup>1[f] \<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] \<cdot> \<r>[f])"
using 2 comp_assoc by (metis (no_types, lifting))
also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)"
using comp_arr_inv' comp_inv_arr' iso_lunit iso_runit comp_arr_dom comp_cod_arr
hseqI' antipar
by (metis ide_left in_homE lunit_simps(4) runit_simps(4) triangle_in_hom(1))
finally show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
by simp
qed
show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<longleftrightarrow>
\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
proof
assume 1: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
have "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] =
\<r>[g] \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> \<l>\<^sup>-\<^sup>1[g]"
using comp_assoc by simp
also have "... = \<r>[g] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<l>\<^sup>-\<^sup>1[g]"
using 1 by simp
also have "... = g"
using comp_assoc comp_arr_inv' comp_inv_arr' iso_lunit iso_runit
comp_arr_dom comp_cod_arr
by simp
finally show "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
by simp
next
assume 2: "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = \<r>\<^sup>-\<^sup>1[g] \<cdot> g \<cdot> \<l>[g]"
using comp_cod_arr by simp
also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> (\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g]) \<cdot> \<l>[g]"
using 2 by simp
also have "... = (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]) \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> (\<l>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g])"
using comp_assoc by simp
also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)"
using comp_arr_inv' comp_inv_arr' iso_lunit iso_runit comp_arr_dom comp_cod_arr
hseqI' antipar
by (metis ide_right in_homE lunit_simps(4) runit_simps(4) triangle_in_hom(2))
finally show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
by simp
qed
qed
end
locale equivalence_in_bicategory =
adjunction_data_in_bicategory +
assumes unit_is_iso [simp]: "iso \<eta>"
and counit_is_iso [simp]: "iso \<epsilon>"
begin
lemma dual_equivalence:
shows "equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
using iso_inv_iso antipar
apply unfold_locales by auto
end
subsection "Equivalence Maps"
text \<open>
We will use the term \emph{equivalence pair} to refer to 1-cells \<open>f\<close> and \<open>g\<close> that are
part of an internal equivalence, and the term \emph{equivalence map} to refer to a 1-cell
that is part of an equivalence pair.
\<close>
context bicategory
begin
definition equivalence_pair
where "equivalence_pair f g \<equiv> \<exists>\<phi> \<psi>. equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
lemma equivalence_pair_symmetric:
assumes "equivalence_pair f g"
shows "equivalence_pair g f"
using assms equivalence_in_bicategory.dual_equivalence equivalence_pair_def by fastforce
definition equivalence_map
where "equivalence_map f \<equiv> \<exists>g \<eta> \<epsilon>. equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
lemma equivalence_mapI:
assumes "ide f" and "ide g" and "src g = trg f" and "trg g = src f"
and "isomorphic (src f) (g \<star> f)" and "isomorphic (f \<star> g) (trg f)"
shows "equivalence_map f"
proof -
obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright> \<and> iso \<eta>"
using assms isomorphic_def by auto
obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> trg f\<guillemotright> \<and> iso \<epsilon>"
using assms isomorphic_def by auto
have "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using assms \<eta> \<epsilon> by (unfold_locales, auto)
thus ?thesis
using equivalence_map_def by auto
qed
lemma equivalence_map_is_ide:
assumes "equivalence_map f"
shows "ide f"
using assms adjunction_data_in_bicategory.ide_left equivalence_in_bicategory_def
equivalence_map_def
by fastforce
lemma obj_is_equivalence_map:
assumes "obj a"
shows "equivalence_map a"
using assms
by (metis equivalence_mapI isomorphic_symmetric objE obj_self_composable(2))
lemma equivalence_respects_iso:
assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>" and "\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<psi>"
shows "equivalence_in_bicategory V H \<a> \<i> src trg f' g'
((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>))"
proof -
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using assms by auto
show ?thesis
proof
show f': "ide f'" using assms by auto
show g': "ide g'" using assms by auto
show 1: "\<guillemotleft>(g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta> : src f' \<Rightarrow> g' \<star> f'\<guillemotright>"
- using assms f' g' E.unit_in_hom E.antipar(2) vconn_implies_hpar(3) hseqI'
- apply (intro comp_in_homI, auto)
+ using assms f' g' E.unit_in_hom E.antipar(2) vconn_implies_hpar(3)
+ apply (intro comp_in_homI, auto)
by (intro hcomp_in_vhom, auto)
show "iso ((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>)"
using assms 1 g' vconn_implies_hpar(3) E.antipar(2) iso_hcomp
by (intro isos_compose, auto)
show 1: "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>) : f' \<star> g' \<Rightarrow> src g'\<guillemotright>"
using assms f' ide_in_hom(2) vconn_implies_hpar(3-4) E.antipar(1-2)
by (intro comp_in_homI, auto)
show "iso (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>))"
using assms 1 isos_compose
by (metis E.counit_is_iso E.ide_right arrI f' hseqE ide_is_iso iso_hcomp
iso_inv_iso seqE)
qed
qed
lemma equivalence_map_preserved_by_iso:
assumes "equivalence_map f" and "f \<cong> f'"
shows "equivalence_map f'"
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 \<phi> where \<phi>: "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright> \<and> iso \<phi>"
using assms isomorphic_def isomorphic_symmetric by blast
have "equivalence_in_bicategory V H \<a> \<i> src trg f' g
((g \<star> \<phi>) \<cdot> (g \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv g))"
using E \<phi> equivalence_respects_iso [of f g \<eta> \<epsilon> \<phi> f' g g] by fastforce
thus ?thesis
using equivalence_map_def by auto
qed
lemma equivalence_preserved_by_iso_right:
assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
shows "equivalence_in_bicategory V H \<a> \<i> src trg f g' ((\<phi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
proof
interpret E: equivalence_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
- apply (intro comp_in_homI)
- apply auto[1]
- using E.antipar(2) E.ide_left by blast
+ using assms E.antipar(2) E.ide_left by blast
show "\<guillemotleft>\<epsilon> \<cdot> (f \<star> inv \<phi>) : f \<star> g' \<Rightarrow> src g'\<guillemotright>"
using assms vconn_implies_hpar(3-4) E.counit_in_vhom E.antipar(1) ide_in_hom(2)
by (intro comp_in_homI, auto)
show "iso ((\<phi> \<star> f) \<cdot> \<eta>)"
- using assms E.antipar hseqI' isos_compose by auto
+ using assms E.antipar isos_compose by auto
show "iso (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
- using assms E.antipar hseqI' isos_compose iso_inv_iso by auto
+ using assms E.antipar isos_compose iso_inv_iso by auto
qed
lemma equivalence_preserved_by_iso_left:
assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
shows "equivalence_in_bicategory V H \<a> \<i> src trg f' g ((g \<star> \<phi>) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
proof
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using assms by auto
show "ide f'"
using assms by auto
show "ide g"
by simp
show "\<guillemotleft>(g \<star> \<phi>) \<cdot> \<eta> : src f' \<Rightarrow> g \<star> f'\<guillemotright>"
- using assms E.unit_in_hom E.antipar hseqI'
- apply (intro comp_in_homI, auto)
- by (intro hcomp_in_vhom, auto)
+ using assms E.unit_in_hom E.antipar by auto
show "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) : f' \<star> g \<Rightarrow> src g\<guillemotright>"
- using assms E.counit_in_hom E.antipar ide_in_hom(2) vconn_implies_hpar(3)
- by (intro comp_in_homI, auto)
+ using assms E.counit_in_hom E.antipar ide_in_hom(2) vconn_implies_hpar(3) by auto
show "iso ((g \<star> \<phi>) \<cdot> \<eta>)"
- using assms E.antipar hseqI' isos_compose by auto
+ using assms E.antipar isos_compose by auto
show "iso (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
- using assms E.antipar hseqI' isos_compose iso_inv_iso by auto
+ using assms E.antipar isos_compose iso_inv_iso by auto
qed
end
subsection "Composing Equivalences"
locale composite_equivalence_in_bicategory =
bicategory V H \<a> \<i> src trg +
fg: equivalence_in_bicategory V H \<a> \<i> src trg f g \<zeta> \<xi> +
hk: equivalence_in_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> \<a>\<^sup>-\<^sup>1[g, k, h \<star> f] \<cdot> (g \<star> \<a>[k, h, f]) \<cdot> (g \<star> \<sigma> \<star> f) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[f]) \<cdot> \<zeta>"
abbreviation \<epsilon>
where "\<epsilon> \<equiv> \<tau> \<cdot> (h \<star> \<l>[k]) \<cdot> (h \<star> \<xi> \<star> k) \<cdot> (h \<star> \<a>\<^sup>-\<^sup>1[f, g, k]) \<cdot> \<a>[h, f, g \<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>"
using fg.antipar hk.antipar composable by fastforce
show "\<guillemotleft>\<epsilon> : (h \<star> f) \<star> g \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
using fg.antipar hk.antipar composable by fastforce
qed
interpretation equivalence_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
proof
show "iso \<eta>"
using fg.antipar hk.antipar composable fg.unit_is_iso hk.unit_is_iso iso_hcomp
iso_lunit' hseq_char iso_inv_iso
by (intro isos_compose, auto)
show "iso \<epsilon>"
using fg.antipar hk.antipar composable fg.counit_is_iso hk.counit_is_iso iso_hcomp
iso_lunit hseq_char iso_inv_iso
by (intro isos_compose, auto)
qed
lemma is_equivalence:
shows "equivalence_in_bicategory V H \<a> \<i> src trg (h \<star> f) (g \<star> k) \<eta> \<epsilon>"
..
end
sublocale composite_equivalence_in_bicategory \<subseteq>
equivalence_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
using is_equivalence by simp
context bicategory
begin
lemma equivalence_maps_compose:
assumes "equivalence_map f" and "equivalence_map f'" and "src f' = trg f"
shows "equivalence_map (f' \<star> f)"
proof -
obtain g \<phi> \<psi> where fg: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
using assms(1) equivalence_map_def by auto
interpret fg: equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>
using fg by auto
obtain g' \<phi>' \<psi>' where f'g': "equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'"
using assms(2) equivalence_map_def by auto
interpret f'g': equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'
using f'g' by auto
interpret composite_equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi> f' g' \<phi>' \<psi>'
using assms(3) by (unfold_locales, auto)
show ?thesis
using equivalence_map_def equivalence_in_bicategory_axioms by auto
qed
end
subsection "Equivalent Objects"
context bicategory
begin
definition equivalent_objects
where "equivalent_objects a b \<equiv> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
lemma equivalent_objects_reflexive:
assumes "obj a"
shows "equivalent_objects a a"
using assms
by (metis equivalent_objects_def ide_in_hom(1) objE obj_is_equivalence_map)
lemma equivalent_objects_symmetric:
assumes "equivalent_objects a b"
shows "equivalent_objects b a"
proof -
obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
using assms equivalent_objects_def by auto
obtain g \<eta> \<epsilon> where E: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using f equivalence_map_def by blast
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using E by auto
have E': "equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
using E.unit_in_hom E.unit_is_iso E.counit_in_hom E.counit_is_iso iso_inv_iso E.antipar
by (unfold_locales, auto)
moreover have "\<guillemotleft>g : b \<rightarrow> a\<guillemotright>"
using E E.antipar by auto
ultimately show ?thesis
using assms E' equivalent_objects_def equivalence_map_def by auto
qed
lemma equivalent_objects_transitive [trans]:
assumes "equivalent_objects a b" and "equivalent_objects b c"
shows "equivalent_objects a c"
proof -
obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
using assms equivalent_objects_def by auto
obtain g \<eta> \<epsilon> where E: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
using f equivalence_map_def by blast
interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
using E by auto
obtain h where h: "\<guillemotleft>h : b \<rightarrow> c\<guillemotright> \<and> equivalence_map h"
using assms equivalent_objects_def by auto
obtain k \<mu> \<nu> where E': "\<guillemotleft>h : b \<rightarrow> c\<guillemotright> \<and> equivalence_in_bicategory V H \<a> \<i> src trg h k \<mu> \<nu>"
using h equivalence_map_def by blast
interpret E': equivalence_in_bicategory V H \<a> \<i> src trg h k \<mu> \<nu>
using E' by auto
interpret EE': composite_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon> h k \<mu> \<nu>
using E E' by (unfold_locales, blast)
show ?thesis
using E E' EE'.is_equivalence equivalent_objects_def equivalence_map_def by auto
qed
end
subsection "Transporting Arrows along Equivalences"
text \<open>
We show in this section that transporting the arrows of one hom-category to another
along connecting equivalence maps yields an equivalence of categories.
This is useful, because it seems otherwise hard to establish that the transporting
functor is full.
\<close>
locale two_equivalences_in_bicategory =
bicategory V H \<a> \<i> src trg +
e\<^sub>0: equivalence_in_bicategory V H \<a> \<i> src trg e\<^sub>0 d\<^sub>0 \<eta>\<^sub>0 \<epsilon>\<^sub>0 +
e\<^sub>1: equivalence_in_bicategory V H \<a> \<i> src trg e\<^sub>1 d\<^sub>1 \<eta>\<^sub>1 \<epsilon>\<^sub>1
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 e\<^sub>0 :: "'a"
and d\<^sub>0 :: "'a"
and \<eta>\<^sub>0 :: "'a"
and \<epsilon>\<^sub>0 :: "'a"
and e\<^sub>1 :: "'a"
and d\<^sub>1 :: "'a"
and \<eta>\<^sub>1 :: "'a"
and \<epsilon>\<^sub>1 :: "'a"
begin
interpretation hom: subcategory V \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>\<close>
using hhom_is_subcategory by simp
(* TODO: The preceding interpretation somehow brings in unwanted notation. *)
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
interpretation hom': subcategory V \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>\<close>
using hhom_is_subcategory by simp
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
abbreviation (input) F
where "F \<equiv> \<lambda>\<mu>. e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0"
interpretation F: "functor" hom.comp hom'.comp F
proof
show 1: "\<And>f. hom.arr f \<Longrightarrow> hom'.arr (e\<^sub>1 \<star> f \<star> d\<^sub>0)"
- using hom.arr_char hom'.arr_char hseqI' in_hhom_def e\<^sub>0.antipar(1) e\<^sub>0.antipar(2)
- by simp
+ using hom.arr_char hom'.arr_char in_hhom_def e\<^sub>0.antipar(1-2) by simp
show "\<And>f. \<not> hom.arr f \<Longrightarrow> e\<^sub>1 \<star> f \<star> d\<^sub>0 = hom'.null"
using 1 hom.arr_char hom'.null_char in_hhom_def
by (metis e\<^sub>0.antipar(1) hseqE hseq_char' hcomp_simps(2))
show "\<And>f. hom.arr f \<Longrightarrow> hom'.dom (e\<^sub>1 \<star> f \<star> d\<^sub>0) = e\<^sub>1 \<star> hom.dom f \<star> d\<^sub>0"
- using hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char hseqI'
+ using hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char
by (metis 1 hcomp_simps(3) e\<^sub>0.ide_right e\<^sub>1.ide_left hom'.inclusion hseq_char ide_char)
show "\<And>f. hom.arr f \<Longrightarrow> hom'.cod (e\<^sub>1 \<star> f \<star> d\<^sub>0) = e\<^sub>1 \<star> hom.cod f \<star> d\<^sub>0"
- using hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char hseqI'
+ using hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char
by (metis 1 hcomp_simps(4) e\<^sub>0.ide_right e\<^sub>1.ide_left hom'.inclusion hseq_char ide_char)
show "\<And>g f. hom.seq g f \<Longrightarrow>
e\<^sub>1 \<star> hom.comp g f \<star> d\<^sub>0 = hom'.comp (e\<^sub>1 \<star> g \<star> d\<^sub>0) (e\<^sub>1 \<star> f \<star> d\<^sub>0)"
- using 1 hom.seq_char hom.arr_char hom.comp_char hom'.arr_char hom'.comp_char hseqI'
+ using 1 hom.seq_char hom.arr_char hom.comp_char hom'.arr_char hom'.comp_char
whisker_left [of e\<^sub>1] whisker_right [of d\<^sub>0]
apply auto
apply (metis hseq_char seqE src_vcomp)
by (metis hseq_char hseq_char')
qed
abbreviation (input) G
where "G \<equiv> \<lambda>\<mu>'. d\<^sub>1 \<star> \<mu>' \<star> e\<^sub>0"
interpretation G: "functor" hom'.comp hom.comp G
proof
show 1: "\<And>f. hom'.arr f \<Longrightarrow> hom.arr (d\<^sub>1 \<star> f \<star> e\<^sub>0)"
- using hom.arr_char hom'.arr_char hseqI' in_hhom_def e\<^sub>1.antipar(1) e\<^sub>1.antipar(2)
+ using hom.arr_char hom'.arr_char in_hhom_def e\<^sub>1.antipar(1) e\<^sub>1.antipar(2)
by simp
show "\<And>f. \<not> hom'.arr f \<Longrightarrow> d\<^sub>1 \<star> f \<star> e\<^sub>0 = hom.null"
using 1 hom.arr_char hom'.null_char in_hhom_def
by (metis e\<^sub>1.antipar(2) hom'.arrI hom.null_char hseqE hseq_char' hcomp_simps(2))
show "\<And>f. hom'.arr f \<Longrightarrow> hom.dom (d\<^sub>1 \<star> f \<star> e\<^sub>0) = d\<^sub>1 \<star> hom'.dom f \<star> e\<^sub>0"
- using 1 hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char hseqI'
+ using 1 hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char
by (metis hcomp_simps(3) e\<^sub>0.ide_left e\<^sub>1.ide_right hom.inclusion hseq_char ide_char)
show "\<And>f. hom'.arr f \<Longrightarrow> hom.cod (d\<^sub>1 \<star> f \<star> e\<^sub>0) = d\<^sub>1 \<star> hom'.cod f \<star> e\<^sub>0"
- using 1 hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char hseqI'
+ using 1 hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char
by (metis hcomp_simps(4) e\<^sub>0.ide_left e\<^sub>1.ide_right hom.inclusion hseq_char ide_char)
show "\<And>g f. hom'.seq g f \<Longrightarrow>
d\<^sub>1 \<star> hom'.comp g f \<star> e\<^sub>0 = hom.comp (d\<^sub>1 \<star> g \<star> e\<^sub>0) (d\<^sub>1 \<star> f \<star> e\<^sub>0)"
- using 1 hom'.seq_char hom'.arr_char hom'.comp_char hom.arr_char hom.comp_char hseqI'
+ using 1 hom'.seq_char hom'.arr_char hom'.comp_char hom.arr_char hom.comp_char
whisker_left [of d\<^sub>1] whisker_right [of e\<^sub>0]
apply auto
apply (metis hseq_char seqE src_vcomp)
by (metis hseq_char hseq_char')
qed
interpretation GF: composite_functor hom.comp hom'.comp hom.comp F G ..
interpretation FG: composite_functor hom'.comp hom.comp hom'.comp G F ..
abbreviation (input) \<phi>\<^sub>0
where "\<phi>\<^sub>0 f \<equiv> (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, f \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (f \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> f \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[f]"
lemma \<phi>\<^sub>0_in_hom:
assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
shows "\<guillemotleft>\<phi>\<^sub>0 f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
and "\<guillemotleft>\<phi>\<^sub>0 f : f \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> f \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
proof -
show "\<guillemotleft>\<phi>\<^sub>0 f : f \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> f \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
- using assms e\<^sub>0.antipar e\<^sub>1.antipar
- by (intro comp_in_homI, fastforce+)
+ using assms e\<^sub>0.antipar e\<^sub>1.antipar by fastforce
thus "\<guillemotleft>\<phi>\<^sub>0 f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
using assms src_dom [of "\<phi>\<^sub>0 f"] trg_dom [of "\<phi>\<^sub>0 f"]
by (metis arrI dom_comp in_hhom_def runit'_simps(4) seqE)
qed
lemma iso_\<phi>\<^sub>0:
assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
shows "iso (\<phi>\<^sub>0 f)"
- using assms iso_lunit' iso_runit' e\<^sub>0.antipar e\<^sub>1.antipar hseqI'
+ using assms iso_lunit' iso_runit' e\<^sub>0.antipar e\<^sub>1.antipar
apply (intro isos_compose)
apply auto
- apply (metis assoc'_simps(3) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right
- iso_hcomp ideD(1) ide_is_iso in_hhomE iso_assoc' hcomp_simps(1))
- by (metis assoc'_simps(3) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right iso_hcomp
- ide_hcomp ideD(1) ide_is_iso in_hhomE iso_assoc' hcomp_simps(1-2))
+ by fastforce+
interpretation \<phi>: transformation_by_components hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>\<^sub>0
proof
fix f
assume f: "hom.ide f"
show "hom.in_hom (\<phi>\<^sub>0 f) (hom.map f) (GF.map f)"
proof (unfold hom.in_hom_char, intro conjI)
show "hom.arr (hom.map f)"
using f by simp
show "hom.arr (GF.map f)"
using f by simp
show "hom.arr (\<phi>\<^sub>0 f)"
using f hom.ide_char hom.arr_char \<phi>\<^sub>0_in_hom by simp
show "\<guillemotleft>\<phi>\<^sub>0 f : hom.map f \<Rightarrow> GF.map f\<guillemotright>"
using f hom.ide_char hom.arr_char hom'.ide_char hom'.arr_char F.preserves_arr
\<phi>\<^sub>0_in_hom
by auto
qed
next
fix \<mu>
assume \<mu>: "hom.arr \<mu>"
show "hom.comp (\<phi>\<^sub>0 (hom.cod \<mu>)) (hom.map \<mu>) =
hom.comp (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
proof -
have "hom.comp (\<phi>\<^sub>0 (hom.cod \<mu>)) (hom.map \<mu>) = \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu>"
proof -
have "hom.map \<mu> = \<mu>"
using \<mu> by simp
moreover have "\<phi>\<^sub>0 (hom.cod \<mu>) = \<phi>\<^sub>0 (cod \<mu>)"
using \<mu> hom.arr_char hom.cod_char by simp
moreover have "hom.arr (\<phi>\<^sub>0 (cod \<mu>))"
using \<mu> hom.arr_char \<phi>\<^sub>0_in_hom [of "cod \<mu>"]
by (metis hom.arr_cod hom.cod_simp ide_cod in_hhom_def)
moreover have "seq (\<phi>\<^sub>0 (cod \<mu>)) \<mu>"
proof
show 1: "\<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
using \<mu> hom.arr_char by auto
show "\<guillemotleft>\<phi>\<^sub>0 (cod \<mu>) : cod \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
using \<mu> hom.arr_char \<phi>\<^sub>0_in_hom
by (metis 1 arrI hom.arr_cod hom.cod_simp ide_cod)
qed
ultimately show ?thesis
using \<mu> hom.comp_char by simp
qed
also have "... = (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
\<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
using \<mu> hom.arr_char comp_assoc by auto
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
\<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] \<cdot> (\<mu> \<star> src e\<^sub>0)) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
using \<mu> hom.arr_char runit'_naturality [of \<mu>] comp_assoc by auto
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
(src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0]) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
using \<mu> hom.arr_char lunit'_naturality [of "\<mu> \<star> src e\<^sub>0"] by force
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
(src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0)) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
using comp_assoc by simp
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0)) \<cdot>
(\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
proof -
have "(\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot> (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) = \<eta>\<^sub>1 \<star> \<mu> \<star> \<eta>\<^sub>0"
using \<mu> hom.arr_char comp_arr_dom comp_cod_arr
interchange [of \<eta>\<^sub>1 "src e\<^sub>1" "cod \<mu> \<star> \<eta>\<^sub>0" "\<mu> \<star> src e\<^sub>0"]
interchange [of "cod \<mu>" \<mu> \<eta>\<^sub>0 "src e\<^sub>0"]
by (metis e\<^sub>0.unit_in_hom(1) e\<^sub>0.unit_simps(2) e\<^sub>1.unit_simps(1) e\<^sub>1.unit_simps(2)
hseqI' in_hhom_def)
also have "... = ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
proof -
have "\<eta>\<^sub>1 \<star> \<mu> \<star> \<eta>\<^sub>0 = (d\<^sub>1 \<star> e\<^sub>1) \<cdot> \<eta>\<^sub>1 \<star> \<mu> \<cdot> dom \<mu> \<star> (d\<^sub>0 \<star> e\<^sub>0) \<cdot> \<eta>\<^sub>0"
using \<mu> hom.arr_char comp_arr_dom comp_cod_arr by auto
also have "... = (d\<^sub>1 \<star> e\<^sub>1) \<cdot> \<eta>\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (dom \<mu> \<star> \<eta>\<^sub>0)"
using \<mu> hom.arr_char comp_cod_arr
interchange [of \<mu> "dom \<mu>" "d\<^sub>0 \<star> e\<^sub>0" \<eta>\<^sub>0]
by auto
also have "... = ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
- using \<mu> hom.arr_char comp_arr_dom comp_cod_arr hseqI'
+ using \<mu> hom.arr_char comp_arr_dom comp_cod_arr
interchange [of "d\<^sub>1 \<star> e\<^sub>1" \<eta>\<^sub>1 "\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0" "dom \<mu> \<star> \<eta>\<^sub>0"]
interchange [of \<mu> "dom \<mu>" "d\<^sub>0 \<star> e\<^sub>0" \<eta>\<^sub>0]
by (metis e\<^sub>0.unit_in_hom(1) e\<^sub>0.unit_simps(1) e\<^sub>0.unit_simps(3) e\<^sub>1.unit_simps(1)
e\<^sub>1.unit_simps(3) hom.inclusion hseqI)
finally show ?thesis by simp
qed
finally have "(\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot> (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) =
((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0])) \<cdot>
(\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
- using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar hseqI' assoc'_naturality [of \<mu> d\<^sub>0 e\<^sub>0]
+ using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar assoc'_naturality [of \<mu> d\<^sub>0 e\<^sub>0]
whisker_left [of "d\<^sub>1 \<star> e\<^sub>1" "\<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]" "\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0"]
whisker_left [of "d\<^sub>1 \<star> e\<^sub>1" "(\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0" "\<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]"]
by auto
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
((d\<^sub>1 \<star> e\<^sub>1) \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0)) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
(\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
using comp_assoc by simp
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> (d\<^sub>1 \<star> e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot>
\<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0]) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
(\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
- using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar hseqI'
+ using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar
assoc_naturality [of d\<^sub>1 e\<^sub>1 "(\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"]
by auto
also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> (d\<^sub>1 \<star> e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0)) \<cdot>
\<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
(\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
using comp_assoc by simp
also have "... = ((d\<^sub>1 \<star> (e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot> (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, dom \<mu> \<star> d\<^sub>0, e\<^sub>0])) \<cdot>
\<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
(\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
- using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar hseqI'
+ using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar
assoc'_naturality [of e\<^sub>1 "\<mu> \<star> d\<^sub>0" e\<^sub>0]
whisker_left [of d\<^sub>1 "\<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]" "e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"]
whisker_left [of d\<^sub>1 "(e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0" "\<a>\<^sup>-\<^sup>1[e\<^sub>1, dom \<mu> \<star> d\<^sub>0, e\<^sub>0]"]
by auto
also have "... = hom.comp (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
proof -
have "hom.arr (GF.map \<mu>)"
using \<mu> by blast
moreover have "hom.arr (\<phi>\<^sub>0 (hom.dom \<mu>))"
using \<mu> hom.arr_char hom.in_hom_char \<phi>\<^sub>0_in_hom(1) hom.dom_closed hom.dom_simp
hom.inclusion ide_dom
by metis
moreover have "seq (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
proof
show "\<guillemotleft>\<phi>\<^sub>0 (hom.dom \<mu>) : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
using \<mu> hom.arr_char hom.dom_char hom.in_hom_char \<phi>\<^sub>0_in_hom hom.dom_closed
hom.dom_simp hom.inclusion ide_dom
by metis
show "\<guillemotleft>GF.map \<mu> : d\<^sub>1 \<star> (e\<^sub>1 \<star> dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
using \<mu> hom.arr_char hom'.arr_char F.preserves_arr
apply simp
apply (intro hcomp_in_vhom)
by (auto simp add: e\<^sub>0.antipar e\<^sub>1.antipar in_hhom_def)
qed
ultimately show ?thesis
using \<mu> hom.comp_char comp_assoc by auto
qed
finally show ?thesis by blast
qed
qed
lemma transformation_by_components_\<phi>\<^sub>0:
shows "transformation_by_components hom.comp hom.comp hom.map (G o F) \<phi>\<^sub>0"
..
interpretation \<phi>: natural_isomorphism hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>.map
proof
fix f
assume "hom.ide f"
hence f: "ide f \<and> \<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
using hom.ide_char hom.arr_char by simp
show "hom.iso (\<phi>.map f)"
proof (unfold hom.iso_char hom.arr_char, intro conjI)
show "iso (\<phi>.map f)"
using f iso_\<phi>\<^sub>0 \<phi>.map_simp_ide hom.ide_char hom.arr_char by simp
moreover show "\<guillemotleft>\<phi>.map f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
using f hom.ide_char hom.arr_char by blast
ultimately show "\<guillemotleft>inv (\<phi>.map f) : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
by auto
qed
qed
lemma natural_isomorphism_\<phi>:
shows "natural_isomorphism hom.comp hom.comp hom.map (G o F) \<phi>.map"
..
definition \<phi>
where "\<phi> \<equiv> \<phi>.map"
lemma \<phi>_ide_simp:
assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
shows "\<phi> f = \<phi>\<^sub>0 f"
unfolding \<phi>_def
using assms hom.ide_char hom.arr_char by simp
lemma \<phi>_components_are_iso:
assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
shows "iso (\<phi> f)"
using assms \<phi>_def \<phi>.components_are_iso hom.ide_char hom.arr_char hom.iso_char
by simp
lemma \<phi>_eq:
shows "\<phi> = (\<lambda>\<mu>. if \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> then \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu> else null)"
proof
fix \<mu>
have "\<not> \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> \<Longrightarrow> \<phi>.map \<mu> = null"
using hom.comp_char hom.null_char hom.arr_char
by (simp add: \<phi>.is_extensional)
moreover have "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> \<Longrightarrow> \<phi>.map \<mu> = \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu>"
unfolding \<phi>.map_def
apply auto
using hom.comp_char hom.arr_char
apply simp
by (metis (no_types, lifting) \<phi>\<^sub>0_in_hom(1) hom.cod_closed hom.inclusion ide_cod local.ext)
ultimately show "\<phi> \<mu> = (if \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> then \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu> else null)"
unfolding \<phi>_def by auto
qed
lemma \<phi>_in_hom [intro]:
assumes "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
shows "\<guillemotleft>\<phi> \<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
and "\<guillemotleft>\<phi> \<mu> : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
proof -
show "\<guillemotleft>\<phi> \<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
using assms \<phi>_eq \<phi>_def hom.arr_char \<phi>.preserves_reflects_arr by presburger
show "\<guillemotleft>\<phi> \<mu> : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
unfolding \<phi>_eq
- using \<phi>\<^sub>0_in_hom(2) arr_iff_in_hom assms comp_in_hom_simp hom.cod_closed hom.inclusion
- ide_cod
- by presburger
+ using assms apply simp
+ apply (intro comp_in_homI)
+ apply auto
+ proof -
+ show "\<guillemotleft>\<r>\<^sup>-\<^sup>1[cod \<mu>] : cod \<mu> \<Rightarrow> cod \<mu> \<star> src e\<^sub>0\<guillemotright>"
+ using assms by auto
+ show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] : cod \<mu> \<star> src e\<^sub>0 \<Rightarrow> src e\<^sub>1 \<star> cod \<mu> \<star> src e\<^sub>0\<guillemotright>"
+ using assms by auto
+ show "\<guillemotleft>\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0 : src e\<^sub>1 \<star> cod \<mu> \<star> src e\<^sub>0 \<Rightarrow> (d\<^sub>1 \<star> e\<^sub>1) \<star> cod \<mu> \<star> (d\<^sub>0 \<star> e\<^sub>0)\<guillemotright>"
+ using assms e\<^sub>0.unit_in_hom(2) e\<^sub>1.unit_in_hom(2)
+ apply (intro hcomp_in_vhom)
+ apply auto
+ by fastforce
+ show "\<guillemotleft>(d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0] :
+ (d\<^sub>1 \<star> e\<^sub>1) \<star> cod \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0 \<Rightarrow> (d\<^sub>1 \<star> e\<^sub>1) \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
+ using assms assoc'_in_hom e\<^sub>0.antipar(1-2) e\<^sub>1.antipar(2)
+ apply (intro hcomp_in_vhom) by auto
+ show "\<guillemotleft>\<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] :
+ (d\<^sub>1 \<star> e\<^sub>1) \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> e\<^sub>1 \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
+ using assms assoc_in_hom e\<^sub>0.antipar(1-2) e\<^sub>1.antipar(2) by auto
+ show "\<guillemotleft>d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0] :
+ d\<^sub>1 \<star> e\<^sub>1 \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
+ using assms assoc'_in_hom [of "d\<^sub>1" "e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0" "e\<^sub>0"]
+ e\<^sub>0.antipar(1-2) e\<^sub>1.antipar(1-2)
+ apply (intro hcomp_in_vhom)
+ apply auto
+ by fastforce
+ qed
qed
lemma \<phi>_simps [simp]:
assumes "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
shows "arr (\<phi> \<mu>)"
and "src (\<phi> \<mu>) = src e\<^sub>0" and "trg (\<phi> \<mu>) = src e\<^sub>1"
and "dom (\<phi> \<mu>) = dom \<mu>" and "cod (\<phi> \<mu>) = d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"
using assms \<phi>_in_hom by auto
interpretation d\<^sub>0: equivalence_in_bicategory V H \<a> \<i> src trg d\<^sub>0 e\<^sub>0 \<open>inv \<epsilon>\<^sub>0\<close> \<open>inv \<eta>\<^sub>0\<close>
using e\<^sub>0.dual_equivalence by simp
interpretation d\<^sub>1: equivalence_in_bicategory V H \<a> \<i> src trg d\<^sub>1 e\<^sub>1 \<open>inv \<epsilon>\<^sub>1\<close> \<open>inv \<eta>\<^sub>1\<close>
using e\<^sub>1.dual_equivalence by simp
interpretation d\<^sub>0e\<^sub>0: two_equivalences_in_bicategory V H \<a> \<i> src trg
d\<^sub>0 e\<^sub>0 \<open>inv \<epsilon>\<^sub>0\<close> \<open>inv \<eta>\<^sub>0\<close> d\<^sub>1 e\<^sub>1 \<open>inv \<epsilon>\<^sub>1\<close> \<open>inv \<eta>\<^sub>1\<close>
..
interpretation \<psi>: inverse_transformation hom'.comp hom'.comp hom'.map \<open>F o G\<close> d\<^sub>0e\<^sub>0.\<phi>
proof -
interpret \<psi>': natural_isomorphism hom'.comp hom'.comp hom'.map \<open>F o G\<close> d\<^sub>0e\<^sub>0.\<phi>
using d\<^sub>0e\<^sub>0.natural_isomorphism_\<phi> e\<^sub>0.antipar e\<^sub>1.antipar d\<^sub>0e\<^sub>0.\<phi>_eq d\<^sub>0e\<^sub>0.\<phi>_def by metis
show "inverse_transformation hom'.comp hom'.comp hom'.map (F o G) d\<^sub>0e\<^sub>0.\<phi>"
..
qed
definition \<psi>
where "\<psi> \<equiv> \<psi>.map"
lemma \<psi>_ide_simp:
assumes "\<guillemotleft>f': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>" and "ide f'"
shows "\<psi> f' = \<r>[f'] \<cdot> \<l>[f' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0) \<cdot> ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]) \<cdot>
\<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot> (e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
proof -
have "hom'.ide f'"
using assms hom'.ide_char hom'.arr_char by simp
hence "\<psi>.map f' = hom'.inv (d\<^sub>0e\<^sub>0.\<phi> f')"
using assms by simp
also have "... = inv (d\<^sub>0e\<^sub>0.\<phi> f')"
using hom'.inv_char \<open>hom'.ide f'\<close> by simp
also have "... = inv (d\<^sub>0e\<^sub>0.\<phi>\<^sub>0 f')"
using assms e\<^sub>0.antipar e\<^sub>1.antipar d\<^sub>0e\<^sub>0.\<phi>_eq d\<^sub>0e\<^sub>0.\<phi>_ide_simp [of f'] by simp
also have "... = ((((inv \<r>\<^sup>-\<^sup>1[f'] \<cdot> inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]) \<cdot> inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0)) \<cdot>
inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0])) \<cdot> inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]) \<cdot>
inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
proof -
text \<open>There has to be a better way to do this.\<close>
have 1: "\<And>A B C D E F.
\<lbrakk> iso A; iso B; iso C; iso D; iso E; iso F;
arr (((((A \<cdot> B) \<cdot> C) \<cdot> D) \<cdot> E) \<cdot> F) \<rbrakk> \<Longrightarrow>
inv (((((A \<cdot> B) \<cdot> C) \<cdot> D) \<cdot> E) \<cdot> F) =
inv F \<cdot> inv E \<cdot> inv D \<cdot> inv C \<cdot> inv B \<cdot> inv A"
using inv_comp isos_compose seqE by metis
have "arr (d\<^sub>0e\<^sub>0.\<phi>\<^sub>0 f')"
using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) d\<^sub>0e\<^sub>0.iso_\<phi>\<^sub>0 [of f'] iso_is_arr by simp
moreover have "iso \<r>\<^sup>-\<^sup>1[f']"
using assms iso_runit' by simp
moreover have "iso \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]"
using assms iso_lunit' by auto
moreover have "iso (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0)"
- using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) hseqI' in_hhom_def by simp
+ using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) in_hhom_def by simp
moreover have "iso ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0])"
using assms e\<^sub>0.antipar e\<^sub>1.antipar(1) e\<^sub>1.antipar(2) in_hhom_def iso_hcomp
by (metis calculation(1) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right hseqE
ide_is_iso iso_assoc' seqE)
moreover have "iso \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
using assms e\<^sub>0.antipar e\<^sub>1.antipar by auto
moreover have "iso (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
using assms e\<^sub>0.antipar e\<^sub>1.antipar
by (metis calculation(1) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right
iso_hcomp ide_hcomp hseqE ideD(1) ide_is_iso in_hhomE iso_assoc'
seqE hcomp_simps(1-2))
ultimately show ?thesis
using 1 [of "e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]" "\<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
"(e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]" "inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0" "\<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]" "\<r>\<^sup>-\<^sup>1[f']"]
comp_assoc
by (metis e\<^sub>0.antipar(2))
qed
also have "... = inv \<r>\<^sup>-\<^sup>1[f'] \<cdot> inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0] \<cdot> inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0) \<cdot>
inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]) \<cdot> inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
using comp_assoc by simp
also have "... = \<r>[f'] \<cdot> \<l>[f' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0) \<cdot> ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]) \<cdot>
\<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot> (e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
proof -
have "inv \<r>\<^sup>-\<^sup>1[f'] = \<r>[f']"
using assms inv_inv iso_runit by blast
moreover have "inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0] = \<l>[f' \<star> trg e\<^sub>0]"
using assms inv_inv iso_lunit by auto
moreover have "inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0) = \<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0"
proof -
have "src (inv \<epsilon>\<^sub>1) = trg f'"
using assms(1) e\<^sub>1.antipar(2) by auto
moreover have "src f' = trg (inv \<epsilon>\<^sub>0)"
using assms(1) e\<^sub>0.antipar(2) by auto
ultimately show ?thesis
- using assms(2) e\<^sub>0.counit_is_iso e\<^sub>1.counit_is_iso hseqI' by simp
+ using assms(2) e\<^sub>0.counit_is_iso e\<^sub>1.counit_is_iso by simp
qed
- moreover have "inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]) = (e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]"
- using assms e\<^sub>0.antipar e\<^sub>1.antipar hseqI' iso_inv_iso by auto
- moreover have "inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] = \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
- using assms e\<^sub>0.antipar e\<^sub>1.antipar hseqI' by auto
- moreover have "inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]) = e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]"
- using assms e\<^sub>0.antipar e\<^sub>1.antipar iso_assoc hseqI' iso_inv_iso
- by auto
- ultimately show ?thesis by simp
+ ultimately show ?thesis
+ using assms e\<^sub>0.antipar e\<^sub>1.antipar iso_inv_iso by auto
qed
finally show ?thesis
using \<psi>_def by simp
qed
lemma \<psi>_components_are_iso:
assumes "\<guillemotleft>f' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>" and "ide f'"
shows "iso (\<psi> f')"
using assms \<psi>_def \<psi>.components_are_iso hom'.ide_char hom'.arr_char hom'.iso_char
by simp
lemma \<psi>_eq:
shows "\<psi> = (\<lambda>\<mu>'. if \<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> then
\<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot> \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
(e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])
else null)"
proof
fix \<mu>'
have "\<not> \<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> \<Longrightarrow> \<psi>.map \<mu>' = null"
using \<psi>.is_extensional hom'.arr_char hom'.null_char by simp
moreover have "\<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> \<Longrightarrow>
\<psi>.map \<mu>' = \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot> \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
(e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])"
proof -
assume \<mu>': "\<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
have "\<guillemotleft>\<psi>.map (dom \<mu>') : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
using \<mu>' hom'.arr_char hom'.dom_closed by auto
moreover have "seq \<mu>' (\<psi>.map (dom \<mu>'))"
proof -
have "hom'.seq \<mu>' (\<psi>.map (dom \<mu>'))"
using \<mu>' \<psi>.preserves_cod hom'.arrI
apply (intro hom'.seqI) by auto
thus ?thesis
using hom'.seq_char by blast
qed
ultimately show ?thesis
using \<mu>' \<psi>.is_natural_1 [of \<mu>'] hom'.comp_char hom'.arr_char hom'.dom_closed
\<psi>_ide_simp [of "dom \<mu>'"]
apply auto
by (metis \<psi>_def hom'.inclusion ide_dom)
qed
ultimately show "\<psi> \<mu>' = (if \<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> then
\<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot>
\<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
(e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])
else null)"
unfolding \<psi>_def by argo
qed
lemma \<psi>_in_hom [intro]:
assumes "\<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
shows "\<guillemotleft>\<psi> \<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
and "\<guillemotleft>\<psi> \<mu>' : e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0 \<Rightarrow> cod \<mu>'\<guillemotright>"
proof -
have 0: "\<psi> \<mu>' = \<psi>.map \<mu>'"
using \<psi>_def by auto
hence 1: "hom'.arr (\<psi> \<mu>')"
using assms hom'.arr_char \<psi>.preserves_reflects_arr by auto
show "\<guillemotleft>\<psi> \<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
using 1 hom'.arr_char by blast
show "\<guillemotleft>\<psi> \<mu>' : e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0 \<Rightarrow> cod \<mu>'\<guillemotright>"
- using assms 0 1 \<psi>.preserves_hom hom'.in_hom_char hom'.arr_char hseqI'
+ using assms 0 1 \<psi>.preserves_hom hom'.in_hom_char hom'.arr_char
e\<^sub>0.antipar e\<^sub>1.antipar \<psi>.preserves_dom \<psi>.preserves_cod hom'.dom_char
apply (intro in_homI)
apply auto[1]
proof -
show "dom (\<psi> \<mu>') = e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0"
proof -
have "hom'.dom (\<psi> \<mu>') = FG.map (hom'.dom \<mu>')"
using assms 0 \<psi>.preserves_dom hom'.arr_char
by (metis (no_types, lifting))
thus ?thesis
using assms 0 1 hom.arr_char hom'.arr_char hom'.dom_char G.preserves_arr
hom'.dom_closed
by auto
qed
show "cod (\<psi> \<mu>') = cod \<mu>'"
proof -
have "hom'.cod (\<psi> \<mu>') = cod \<mu>'"
using assms 0 \<psi>.preserves_cod hom'.arr_char by auto
thus ?thesis
using assms 0 1 hom'.arr_char hom'.cod_char G.preserves_arr hom'.cod_closed by auto
qed
qed
qed
lemma \<psi>_simps [simp]:
assumes "\<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
shows "arr (\<psi> \<mu>')"
and "src (\<psi> \<mu>') = trg e\<^sub>0" and "trg (\<psi> \<mu>') = trg e\<^sub>1"
and "dom (\<psi> \<mu>') = e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0" and "cod (\<psi> \<mu>') = cod \<mu>'"
using assms \<psi>_in_hom by auto
interpretation equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>
proof -
interpret \<phi>: natural_isomorphism hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>
using \<phi>.natural_isomorphism_axioms \<phi>_def by simp
interpret \<psi>: natural_isomorphism hom'.comp hom'.comp \<open>F o G\<close> hom'.map \<psi>
using \<psi>.natural_isomorphism_axioms \<psi>_def by simp
show "equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>"
..
qed
lemma induces_equivalence_of_hom_categories:
shows "equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>"
..
lemma equivalence_functor_F:
shows "equivalence_functor hom.comp hom'.comp F"
proof -
interpret \<phi>': inverse_transformation hom.comp hom.comp hom.map \<open>G o F\<close> \<phi> ..
interpret \<psi>': inverse_transformation hom'.comp hom'.comp \<open>F o G\<close> hom'.map \<psi> ..
interpret E: equivalence_of_categories hom.comp hom'.comp G F \<psi>'.map \<phi>'.map ..
show ?thesis
using E.equivalence_functor_axioms by simp
qed
lemma equivalence_functor_G:
shows "equivalence_functor hom'.comp hom.comp G"
using equivalence_functor_axioms by simp
end
context bicategory
begin
text \<open>
We now use the just-established equivalence of hom-categories to prove some cancellation
laws for equivalence maps. It is relatively straightforward to prove these results
directly, without using the just-established equivalence, but the proofs are somewhat
longer that way.
\<close>
lemma equivalence_cancel_left:
assumes "equivalence_map e"
and "par \<mu> \<mu>'" and "src e = trg \<mu>" and "e \<star> \<mu> = e \<star> \<mu>'"
shows "\<mu> = \<mu>'"
proof -
obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
using assms equivalence_map_def by auto
interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
using d\<eta>\<epsilon> by simp
interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
\<open>src \<mu>\<close> \<open>src \<mu>\<close> \<open>inv \<i>[src \<mu>]\<close> \<open>\<i>[src \<mu>]\<close>
using assms iso_inv_iso iso_unit obj_src
apply unfold_locales by simp_all
interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
\<open>src \<mu>\<close> \<open>src \<mu>\<close> \<open>inv \<i>[src \<mu>]\<close> \<open>\<i>[src \<mu>]\<close> e d \<eta> \<epsilon>
..
interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src (src \<mu>)) (src e)\<close>
using hhom_is_subcategory by blast
interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg (src \<mu>)) (trg e)\<close>
using hhom_is_subcategory by blast
interpret F: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. e \<star> \<mu>' \<star> src \<mu>\<close>
using equivalence_functor_F by simp
have "F \<mu> = F \<mu>'"
using assms hom.arr_char
apply simp
by (metis e.ide_left hcomp_reassoc(2) i.ide_right ideD(1) src_dom trg_dom trg_src)
moreover have "hom.par \<mu> \<mu>'"
using assms hom.arr_char hom.dom_char hom.cod_char
by (metis (no_types, lifting) in_hhomI src_dom src_src trg_dom)
ultimately show "\<mu> = \<mu>'"
using F.is_faithful by blast
qed
lemma equivalence_cancel_right:
assumes "equivalence_map e"
and "par \<mu> \<mu>'" and "src \<mu> = trg e" and "\<mu> \<star> e = \<mu>' \<star> e"
shows "\<mu> = \<mu>'"
proof -
obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
using assms equivalence_map_def by auto
interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
using d\<eta>\<epsilon> by simp
interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
\<open>trg \<mu>\<close> \<open>trg \<mu>\<close> \<open>inv \<i>[trg \<mu>]\<close> \<open>\<i>[trg \<mu>]\<close>
using assms iso_inv_iso iso_unit obj_src
apply unfold_locales by simp_all
interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
e d \<eta> \<epsilon> \<open>trg \<mu>\<close> \<open>trg \<mu>\<close> \<open>inv \<i>[trg \<mu>]\<close> \<open>\<i>[trg \<mu>]\<close>
..
interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg e) (trg (trg \<mu>))\<close>
using hhom_is_subcategory by blast
interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src e) (src (trg \<mu>))\<close>
using hhom_is_subcategory by blast
interpret G: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. trg \<mu> \<star> \<mu>' \<star> e\<close>
using equivalence_functor_G by simp
have "G \<mu> = G \<mu>'"
using assms hom.arr_char by simp
moreover have "hom.par \<mu> \<mu>'"
using assms hom.arr_char hom.dom_char hom.cod_char
by (metis (no_types, lifting) in_hhomI src_dom trg_dom trg_trg)
ultimately show "\<mu> = \<mu>'"
using G.is_faithful 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,3330 @@
(* 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
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 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>"
+ 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] *):
+ 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 src_hcomp apply blast
+ using assms VV.arr_char trg_hcomp apply blast
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]:
+ lemma hcomp_in_vhom [intro]:
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
+ using assms by fastforce
+
+ lemma hcomp_in_vhom' [simp]:
+ assumes "hseq \<nu> \<mu>"
+ and "dom \<mu> = f" and "dom \<nu> = h" and "cod \<mu> = g" and "cod \<nu> = k"
+ 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 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')
+ 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'
+ using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char HoHV_def
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'
+ HoHV_def HoVH_def
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
+ using 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
+ using vseq_implies_hpar(1) whisker_right
by (unfold_locales, auto)
end
end
diff --git a/thys/Bicategory/Pseudofunctor.thy b/thys/Bicategory/Pseudofunctor.thy
--- a/thys/Bicategory/Pseudofunctor.thy
+++ b/thys/Bicategory/Pseudofunctor.thy
@@ -1,5544 +1,5447 @@
(* Title: Pseudofunctor
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Pseudofunctors"
theory Pseudofunctor
imports MonoidalCategory.MonoidalFunctor Bicategory Subbicategory InternalEquivalence
Coherence
begin
text \<open>
The traditional definition of a pseudofunctor \<open>F : C \<rightarrow> D\<close> between bicategories \<open>C\<close> and \<open>D\<close>
is in terms of two maps: an ``object map'' \<open>F\<^sub>o\<close> that takes objects of \<open>C\<close> to objects of \<open>D\<close>
and an ``arrow map'' \<open>F\<^sub>a\<close> that assigns to each pair of objects \<open>a\<close> and \<open>b\<close> of \<open>C\<close>
a functor \<open>F\<^sub>a a b\<close> from the hom-category \<open>hom\<^sub>C a b\<close> to the hom-category \<open>hom\<^sub>D (F\<^sub>o a) (F\<^sub>o b)\<close>.
In addition, there is assigned to each object \<open>a\<close> of \<open>C\<close> an invertible 2-cell
\<open>\<guillemotleft>\<Psi> a : F\<^sub>o a \<Rightarrow>\<^sub>D (F\<^sub>a a a) a\<guillemotright>\<close>, and to each pair \<open>(f, g)\<close> of composable 1-cells of C there
is assigned an invertible 2-cell \<open>\<guillemotleft>\<Phi> (f, g) : F g \<star> F f \<Rightarrow> F (g \<star> f)\<guillemotright>\<close>, all subject to
naturality and coherence conditions.
In keeping with the ``object-free'' style in which we have been working, we do not wish
to adopt a definition of pseudofunctor that distinguishes between objects and other
arrows. Instead, we would like to understand a pseudofunctor as an ordinary functor between
(vertical) categories that weakly preserves horizontal composition in a suitable sense.
So, we take as a starting point that a pseudofunctor \<open>F : C \<rightarrow> D\<close> is a functor from
\<open>C\<close> to \<open>D\<close>, when these are regarded as ordinary categories with respect to vertical
composition. Next, \<open>F\<close> should preserve source and target, but only ``weakly''
(up to isomorphism, rather than ``on the nose'').
Weak preservation of horizontal composition is expressed by specifying, for each horizontally
composable pair of vertical identities \<open>(f, g)\<close> of \<open>C\<close>, a ``compositor''
\<open>\<guillemotleft>\<Phi> (f, g) : F g \<star> F f \<Rightarrow> F (g \<star> f)\<guillemotright>\<close> in \<open>D\<close>, such that the \<open>\<Phi> (f, g)\<close> are the components
of a natural isomorphism.
Associators must also be weakly preserved by F; this is expressed by a coherence
condition that relates an associator \<open>\<a>\<^sub>C[f, g, h]\<close> in \<open>C\<close>, its image \<open>F \<a>\<^sub>C[f, g, h]\<close>,
the associator \<open>\<a>\<^sub>D[F f, F g, F h]\<close> in \<open>D\<close> and compositors involving \<open>f\<close>, \<open>g\<close>, and \<open>h\<close>.
As regards the weak preservation of unitors, just as for monoidal functors,
which are in fact pseudofunctors between one-object bicategories, it is only necessary
to assume that \<open>F \<i>\<^sub>C[a]\<close> and \<open>\<i>\<^sub>D[F a]\<close> are isomorphic in \<open>D\<close> for each object \<open>a\<close> of \<open>C\<close>,
for there is then a canonical way to obtain, for each \<open>a\<close>, an isomorphism
\<open>\<guillemotleft>\<Psi> a : src (F a) \<rightarrow> F a\<guillemotright>\<close> that satisfies the usual coherence conditions relating the
unitors and the associators. Note that the map \<open>a \<mapsto> src (F a)\<close> amounts to the traditional
``object map'' \<open>F\<^sub>o\<close>, so that this becomes a derived notion, rather than a primitive one.
\<close>
subsection "Weak Arrows of Homs"
text \<open>
We begin with a locale that defines a functor between ``horizontal homs'' that preserves
source and target up to isomorphism.
\<close>
locale weak_arrow_of_homs =
C: horizontal_homs C src\<^sub>C trg\<^sub>C +
D: horizontal_homs D src\<^sub>D trg\<^sub>D +
"functor" C D F
for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and src\<^sub>C :: "'c \<Rightarrow> 'c"
and trg\<^sub>C :: "'c \<Rightarrow> 'c"
and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and src\<^sub>D :: "'d \<Rightarrow> 'd"
and trg\<^sub>D :: "'d \<Rightarrow> 'd"
and F :: "'c \<Rightarrow> 'd" +
assumes weakly_preserves_src: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D.isomorphic (F (src\<^sub>C \<mu>)) (src\<^sub>D (F \<mu>))"
and weakly_preserves_trg: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D.isomorphic (F (trg\<^sub>C \<mu>)) (trg\<^sub>D (F \<mu>))"
begin
lemma isomorphic_src:
assumes "C.obj a"
shows "D.isomorphic (src\<^sub>D (F a)) (F a)"
using assms weakly_preserves_src C.obj_def D.isomorphic_symmetric by force
lemma isomorphic_trg:
assumes "C.obj a"
shows "D.isomorphic (trg\<^sub>D (F a)) (F a)"
using assms weakly_preserves_trg C.objE
by (metis C.obj_def D.isomorphic_symmetric)
abbreviation (input) hseq\<^sub>C
where "hseq\<^sub>C \<mu> \<nu> \<equiv> C.arr \<mu> \<and> C.arr \<nu> \<and> src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
abbreviation (input) hseq\<^sub>D
where "hseq\<^sub>D \<mu> \<nu> \<equiv> D.arr \<mu> \<and> D.arr \<nu> \<and> src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
lemma preserves_hseq:
assumes "hseq\<^sub>C \<mu> \<nu>"
shows "hseq\<^sub>D (F \<mu>) (F \<nu>)"
proof -
have "src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
using assms by auto
hence "D.isomorphic (F (src\<^sub>C \<mu>)) (trg\<^sub>D (F \<nu>))"
using assms weakly_preserves_trg by auto
moreover have "D.isomorphic (src\<^sub>D (F \<mu>)) (F (src\<^sub>C \<mu>))"
using assms weakly_preserves_src D.isomorphic_symmetric by blast
ultimately have "D.isomorphic (src\<^sub>D (F \<mu>)) (trg\<^sub>D (F \<nu>))"
using D.isomorphic_transitive by blast
hence "src\<^sub>D (F \<mu>) = trg\<^sub>D (F \<nu>)"
using assms D.isomorphic_objects_are_equal by auto
thus ?thesis
using assms by auto
qed
text \<open>
Though \<open>F\<close> does not preserve objects ``on the nose'', we can recover from it the
usual ``object map'', which does.
It is slightly confusing at first to get used to the idea that applying the
object map of a weak arrow of homs to an object does not give the same thing
as applying the underlying functor, but rather only something isomorphic to it.
The following defines the object map associated with \<open>F\<close>.
\<close>
definition map\<^sub>0
where "map\<^sub>0 a \<equiv> src\<^sub>D (F a)"
lemma map\<^sub>0_simps [simp]:
assumes "C.obj a"
shows "D.obj (map\<^sub>0 a)"
and "src\<^sub>D (map\<^sub>0 a) = map\<^sub>0 a" and "trg\<^sub>D (map\<^sub>0 a) = map\<^sub>0 a"
and "D.dom (map\<^sub>0 a) = map\<^sub>0 a" and "D.cod (map\<^sub>0 a) = map\<^sub>0 a"
using assms map\<^sub>0_def by auto
lemma preserves_src [simp]:
assumes "C.arr \<mu>"
shows "src\<^sub>D (F \<mu>) = map\<^sub>0 (src\<^sub>C \<mu>)"
using assms
by (metis C.src.preserves_arr C.src_src C.trg_src map\<^sub>0_def preserves_hseq)
lemma preserves_trg [simp]:
assumes "C.arr \<mu>"
shows "trg\<^sub>D (F \<mu>) = map\<^sub>0 (trg\<^sub>C \<mu>)"
using assms map\<^sub>0_def preserves_hseq C.src_trg C.trg.preserves_arr by presburger
lemma preserves_hhom [intro]:
assumes "C.arr \<mu>"
shows "D.in_hhom (F \<mu>) (map\<^sub>0 (src\<^sub>C \<mu>)) (map\<^sub>0 (trg\<^sub>C \<mu>))"
using assms by simp
interpretation CxC: product_category C C ..
interpretation CC: subcategory CxC.comp
\<open>\<lambda>\<mu>\<nu>. C.arr (fst \<mu>\<nu>) \<and> C.arr (snd \<mu>\<nu>) \<and> src\<^sub>C (fst \<mu>\<nu>) = trg\<^sub>C (snd \<mu>\<nu>)\<close>
by (unfold_locales, auto)
interpretation DxD: product_category D D ..
interpretation DD: subcategory DxD.comp
\<open>\<lambda>\<mu>\<nu>. D.arr (fst \<mu>\<nu>) \<and> D.arr (snd \<mu>\<nu>) \<and> src\<^sub>D (fst \<mu>\<nu>) = trg\<^sub>D (snd \<mu>\<nu>)\<close>
by (unfold_locales, auto)
text \<open>
We define here the lifting of \<open>F\<close> to a functor \<open>FF: CC \<rightarrow> DD\<close>.
We need this to define the domains and codomains of the compositors.
\<close>
definition FF
where "FF \<equiv> \<lambda>\<mu>\<nu>. if CC.arr \<mu>\<nu> then (F (fst \<mu>\<nu>), F (snd \<mu>\<nu>)) else DD.null"
interpretation FF: "functor" CC.comp DD.comp FF
proof -
have 1: "\<And>\<mu>\<nu>. CC.arr \<mu>\<nu> \<Longrightarrow> DD.arr (FF \<mu>\<nu>)"
unfolding FF_def using CC.arr_char DD.arr_char preserves_hseq by simp
show "functor CC.comp DD.comp FF"
proof
fix \<mu>\<nu>
show "\<not> CC.arr \<mu>\<nu> \<Longrightarrow> FF \<mu>\<nu> = DD.null"
using FF_def by simp
show "CC.arr \<mu>\<nu> \<Longrightarrow> DD.arr (FF \<mu>\<nu>)"
using 1 by simp
assume \<mu>\<nu>: "CC.arr \<mu>\<nu>"
show "DD.dom (FF \<mu>\<nu>) = FF (CC.dom \<mu>\<nu>)"
using \<mu>\<nu> 1 FF_def CC.arr_char DD.arr_char by simp
show "DD.cod (FF \<mu>\<nu>) = FF (CC.cod \<mu>\<nu>)"
using \<mu>\<nu> 1 FF_def CC.arr_char DD.arr_char by simp
next
fix \<mu>\<nu> \<tau>\<pi>
assume 2: "CC.seq \<mu>\<nu> \<tau>\<pi>"
show "FF (CC.comp \<mu>\<nu> \<tau>\<pi>) = DD.comp (FF \<mu>\<nu>) (FF \<tau>\<pi>)"
proof -
have "FF (CC.comp \<mu>\<nu> \<tau>\<pi>) = (F (fst \<mu>\<nu>) \<cdot>\<^sub>D F (fst \<tau>\<pi>), F (snd \<mu>\<nu>) \<cdot>\<^sub>D F (snd \<tau>\<pi>))"
using 1 2 FF_def CC.comp_char CxC.comp_char CC.arr_char
by (metis (no_types, lifting) CC.seq_char CxC.seqE fst_conv preserves_comp_2 snd_conv)
also have "... = DD.comp (FF \<mu>\<nu>) (FF \<tau>\<pi>)"
using 1 2 FF_def DD.comp_char DxD.comp_char CC.arr_char DD.arr_char
CC.seq_char CxC.seqE preserves_seq
by (simp, meson)
finally show ?thesis by simp
qed
qed
qed
lemma functor_FF:
shows "functor CC.comp DD.comp FF"
..
end
subsection "Definition of Pseudofunctors"
text \<open>
I don't much like the term "pseudofunctor", which is suggestive of something that
is ``not really'' a functor. In the development here we can see that a pseudofunctor
is really a \emph{bona fide} functor with respect to vertical composition,
which happens to have in addition a weak preservation property with respect to
horizontal composition.
This weak preservation of horizontal composition is captured by extra structure,
the ``compositors'', which are the components of a natural transformation.
So ``pseudofunctor'' is really a misnomer; it's an actual functor that has been equipped
with additional structure relating to horizontal composition. I would use the term
``bifunctor'' for such a thing, but it seems to not be generally accepted and also tends
to conflict with the usage of that term to refer to an ordinary functor of two
arguments; which I have called a ``binary functor''. Sadly, there seem to be no other
plausible choices of terminology, other than simply ``functor''
(recommended on n-Lab @{url \<open>https://ncatlab.org/nlab/show/pseudofunctor\<close>}),
but that is not workable here because we need a name that does not clash with that
used for an ordinary functor between categories.
\<close>
locale pseudofunctor =
C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
weak_arrow_of_homs V\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D src\<^sub>D trg\<^sub>D F +
FoH\<^sub>C: composite_functor C.VV.comp V\<^sub>C V\<^sub>D \<open>\<lambda>\<mu>\<nu>. H\<^sub>C (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> F +
H\<^sub>DoFF: composite_functor C.VV.comp D.VV.comp V\<^sub>D
FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>D (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> +
\<Phi>: natural_isomorphism C.VV.comp V\<^sub>D H\<^sub>DoFF.map FoH\<^sub>C.map \<Phi>
for V\<^sub>C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and H\<^sub>C :: "'c comp" (infixr "\<star>\<^sub>C" 53)
and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c" ("\<a>\<^sub>C[_, _, _]")
and \<i>\<^sub>C :: "'c \<Rightarrow> 'c" ("\<i>\<^sub>C[_]")
and src\<^sub>C :: "'c \<Rightarrow> 'c"
and trg\<^sub>C :: "'c \<Rightarrow> 'c"
and V\<^sub>D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and H\<^sub>D :: "'d comp" (infixr "\<star>\<^sub>D" 53)
and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" ("\<a>\<^sub>D[_, _, _]")
and \<i>\<^sub>D :: "'d \<Rightarrow> 'd" ("\<i>\<^sub>D[_]")
and src\<^sub>D :: "'d \<Rightarrow> 'd"
and trg\<^sub>D :: "'d \<Rightarrow> 'd"
and F :: "'c \<Rightarrow> 'd"
and \<Phi> :: "'c * 'c \<Rightarrow> 'd" +
assumes assoc_coherence:
"\<lbrakk> C.ide f; C.ide g; C.ide h; src\<^sub>C f = trg\<^sub>C g; src\<^sub>C g = trg\<^sub>C h \<rbrakk> \<Longrightarrow>
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]"
begin
no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
no_notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
notation C.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
notation C.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>C _\<guillemotright>")
notation D.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
notation D.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>D _\<guillemotright>")
notation C.lunit ("\<l>\<^sub>C[_]")
notation C.runit ("\<r>\<^sub>C[_]")
notation C.lunit' ("\<l>\<^sub>C\<^sup>-\<^sup>1[_]")
notation C.runit' ("\<r>\<^sub>C\<^sup>-\<^sup>1[_]")
notation C.\<a>' ("\<a>\<^sub>C\<^sup>-\<^sup>1[_, _, _]")
notation D.lunit ("\<l>\<^sub>D[_]")
notation D.runit ("\<r>\<^sub>D[_]")
notation D.lunit' ("\<l>\<^sub>D\<^sup>-\<^sup>1[_]")
notation D.runit' ("\<r>\<^sub>D\<^sup>-\<^sup>1[_]")
notation D.\<a>' ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]")
lemma weakly_preserves_objects:
assumes "C.obj a"
shows "D.isomorphic (map\<^sub>0 a) (F a)"
using assms weakly_preserves_src [of a] D.isomorphic_symmetric by auto
lemma \<Phi>_in_hom [intro]:
assumes "C.ide a" and "C.ide b" and "src\<^sub>C a = trg\<^sub>C b"
shows "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
and "\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>"
proof -
show "\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>"
proof -
have "H\<^sub>DoFF.map (a, b) = F a \<star>\<^sub>D F b"
using assms C.VV.ide_char FF_def by auto
moreover have "FoH\<^sub>C.map (a, b) = F (a \<star>\<^sub>C b)"
using assms C.VV.ide_char by simp
ultimately show ?thesis
using assms C.VV.ide_char \<Phi>.preserves_hom
apply simp
by (metis (no_types, lifting) C.VV.ideI C.VV.ide_in_hom C.VxV.ide_Ide C.ideD(1)
fst_conv snd_conv)
qed
show "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
proof -
have "C.hseq a b"
by (simp add: assms(1-3))
thus ?thesis
- by (metis C.src_hcomp' C.trg_hcomp' D.in_hhom_def D.in_homE D.src_cod D.trg_cod
+ by (metis C.src_hcomp C.trg_hcomp D.in_hhom_def D.in_homE D.src_cod D.trg_cod
\<open>\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>\<close> preserves_src preserves_trg)
qed
qed
lemma \<Phi>_simps [simp]:
assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
shows "D.arr (\<Phi> (f, g))"
and "src\<^sub>D (\<Phi> (f, g)) = src\<^sub>D (F g)" and "trg\<^sub>D (\<Phi> (f, g)) = trg\<^sub>D (F f)"
and "D.dom (\<Phi> (f, g)) = F f \<star>\<^sub>D F g" and "D.cod (\<Phi> (f, g)) = F (f \<star>\<^sub>C g)"
and "D.iso (\<Phi> (f, g))"
proof -
show "D.arr (\<Phi> (f, g))"
using assms \<Phi>_in_hom by auto
show "src\<^sub>D (\<Phi> (f, g)) = src\<^sub>D (F g)"
using assms \<Phi>_in_hom by auto
show "trg\<^sub>D (\<Phi> (f, g)) = trg\<^sub>D (F f)"
using assms \<Phi>_in_hom by auto
show "D.dom (\<Phi> (f, g)) = F f \<star>\<^sub>D F g"
using assms \<Phi>_in_hom by blast
show "D.cod (\<Phi> (f, g)) = F (f \<star>\<^sub>C g)"
using assms \<Phi>_in_hom by blast
show "D.iso (\<Phi> (f, g))"
- using assms \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char by simp
+ using assms C.VV.ide_char C.VV.arr_char by simp
qed
lemma \<Phi>_components_are_iso:
assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
shows "D.iso (\<Phi> (f, g))"
- using assms C.VV.ide_char C.VV.arr_char \<Phi>.components_are_iso by simp
+ using assms C.VV.ide_char C.VV.arr_char by simp
lemma weakly_preserves_hcomp:
assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
shows "D.isomorphic (F f \<star>\<^sub>D F g) (F (f \<star>\<^sub>C g))"
- using assms \<Phi>_in_hom \<Phi>_components_are_iso D.isomorphic_def by auto
+ using assms D.isomorphic_def by auto
text \<open>
The following defines the image of the unit isomorphism \<open>\<i>\<^sub>C[a]\<close> under \<open>F\<close>.
We will use \<open>(F a, \<i>[a])\<close> as an ``alternate unit'', to substitute for
\<open>(src\<^sub>D (F a), \<i>\<^sub>D[src\<^sub>D (F a)])\<close>.
\<close>
abbreviation (input) \<i> ("\<i>[_]")
where "\<i>[a] \<equiv> F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a)"
lemma \<i>_in_hom [intro]:
assumes "C.obj a"
shows "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a\<guillemotright>"
and "\<guillemotleft>\<i>[a] : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F a\<guillemotright>"
proof (unfold map\<^sub>0_def)
show "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F a\<guillemotright>"
using assms preserves_hom \<Phi>_in_hom
by (intro D.comp_in_homI, auto)
show "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : src\<^sub>D (F a) \<rightarrow>\<^sub>D src\<^sub>D (F a)\<guillemotright>"
using assms C.VV.arr_char
by (intro D.vcomp_in_hhom D.seqI, auto)
qed
lemma \<i>_simps [simp]:
assumes "C.obj a"
shows "D.arr (\<i> a)"
and "src\<^sub>D \<i>[a] = map\<^sub>0 a" and "trg\<^sub>D \<i>[a] = map\<^sub>0 a"
and "D.dom \<i>[a] = F a \<star>\<^sub>D F a" and "D.cod \<i>[a] = F a"
proof -
show "src\<^sub>D \<i>[a] = map\<^sub>0 a"
unfolding map\<^sub>0_def
using assms \<i>_in_hom D.src_cod [of "F a"]
by (metis C.unit_simps(1) C.unit_simps(5) D.arrI D.src_vcomp D.vseq_implies_hpar(1)
is_natural_2 preserves_arr)
show "trg\<^sub>D \<i>[a] = map\<^sub>0 a"
unfolding map\<^sub>0_def
using assms \<i>_in_hom D.trg_cod [of "F a"]
by (metis C.obj_def C.unit_simps(1) C.unit_simps(3) D.arrI D.trg_vcomp preserves_hseq)
show "D.arr \<i>[a]"
using assms \<i>_in_hom by auto
show "D.dom \<i>[a] = F a \<star>\<^sub>D F a"
using assms \<i>_in_hom by auto
show "D.cod \<i>[a] = F a"
using assms \<i>_in_hom by auto
qed
lemma iso_\<i>:
assumes "C.obj a"
shows "D.iso \<i>[a]"
proof -
have "D.iso (\<Phi> (a, a))"
- using assms \<Phi>_components_are_iso by auto
+ using assms by auto
moreover have "D.iso (F \<i>\<^sub>C[a])"
using assms C.iso_unit preserves_iso by simp
moreover have "D.seq (F \<i>\<^sub>C[a]) (\<Phi> (a, a))"
- using assms \<Phi>_in_hom C.unit_in_hom(2) C.obj_self_composable(1) C.seq_if_composable
- by blast
+ using assms C.obj_self_composable(1) C.seq_if_composable by blast
ultimately show ?thesis by auto
qed
end
context pseudofunctor
begin
text \<open>
If \<open>a\<close> is an object of \<open>C\<close> and we have an isomorphism \<open>\<guillemotleft>\<Phi> (a, a) : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C a)\<guillemotright>\<close>,
then there is a canonical way to define a compatible isomorphism \<open>\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>\<close>.
Specifically, we take \<open>\<Psi> a\<close> to be the unique isomorphism \<open>\<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>\<close> such that
\<open>\<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)\<close>.
\<close>
definition \<Psi>
where "\<Psi> a \<equiv> THE \<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and>
\<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
lemma \<Psi>_char:
assumes "C.obj a"
shows "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" and "D.iso (\<Psi> a)"
and "\<Psi> a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<Psi> a \<star>\<^sub>D \<Psi> a)"
and "\<exists>!\<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
proof -
let ?P = "\<lambda>\<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
show "\<exists>!\<psi>. ?P \<psi>"
proof -
have "D.obj (map\<^sub>0 a)"
using assms by simp
moreover have "D.isomorphic (map\<^sub>0 a) (F a)"
unfolding map\<^sub>0_def
using assms isomorphic_src by simp
ultimately show ?thesis
using assms D.unit_unique_upto_unique_iso \<Phi>.preserves_hom \<i>_in_hom iso_\<i> by simp
qed
hence 1: "?P (\<Psi> a)"
using assms \<Psi>_def the1I2 [of ?P ?P] by simp
show "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" using 1 by simp
show "D.iso (\<Psi> a)" using 1 by simp
show "\<Psi> a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<Psi> a \<star>\<^sub>D \<Psi> a)"
using 1 by simp
qed
lemma \<Psi>_simps [simp]:
assumes "C.obj a"
shows "D.arr (\<Psi> a)"
and "src\<^sub>D (\<Psi> a) = map\<^sub>0 a" and "trg\<^sub>D (\<Psi> a) = map\<^sub>0 a"
and "D.dom (\<Psi> a) = map\<^sub>0 a" and "D.cod (\<Psi> a) = F a"
proof -
show "D.arr (\<Psi> a)"
using assms \<Psi>_char(1) by auto
show 1: "D.dom (\<Psi> a) = map\<^sub>0 a"
using assms \<Psi>_char(1) by auto
show 2: "D.cod (\<Psi> a) = F a"
using assms \<Psi>_char(1) by auto
show "src\<^sub>D (\<Psi> a) = map\<^sub>0 a"
using assms 1 D.src_dom
unfolding map\<^sub>0_def
by (metis C.obj_def D.arr_dom_iff_arr D.src.preserves_reflects_arr D.src_src preserves_arr)
show "trg\<^sub>D (\<Psi> a) = map\<^sub>0 a"
unfolding map\<^sub>0_def
using assms 2 \<Psi>_char
by (metis "1" D.trg_dom map\<^sub>0_def map\<^sub>0_simps(3) \<open>D.arr (\<Psi> a)\<close>)
qed
lemma \<Psi>_in_hom [intro]:
assumes "C.obj a"
shows "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a\<guillemotright>"
and "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>"
using assms by auto
lemma \<Psi>_eqI:
assumes "C.obj a" and "\<guillemotleft>\<mu>: map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" and "D.iso \<mu>"
and "\<mu> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i> a \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<mu>)"
shows "\<mu> = \<Psi> a"
using assms \<Psi>_def \<Psi>_char
the1_equality [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<mu> \<and>
\<mu> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<mu>)" \<mu>]
by simp
text \<open>
The following defines the unique isomorphism satisfying the characteristic conditions
for the left unitor \<open>\<l>\<^sub>D[trg\<^sub>D (F f)]\<close>, but using the ``alternate unit'' \<open>\<i>[trg\<^sub>C f]\<close>
instead of \<open>\<i>\<^sub>D[trg\<^sub>D (F f)]\<close>, which is used to define \<open>\<l>\<^sub>D[trg\<^sub>D (F f)]\<close>.
\<close>
definition lF
where "lF f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
F (trg\<^sub>C f) \<star>\<^sub>D \<mu> =(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
lemma lF_char:
assumes "C.ide f"
shows "\<guillemotleft>lF f : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright>"
and "F (trg\<^sub>C f) \<star>\<^sub>D lF f = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
and "\<exists>!\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
F (trg\<^sub>C f) \<star>\<^sub>D \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
proof -
let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
F (trg\<^sub>C f) \<star>\<^sub>D \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
show "\<exists>!\<mu>. ?P \<mu>"
proof -
interpret Df: prebicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D
using D.is_prebicategory by simp
interpret S: subcategory \<open>(\<cdot>\<^sub>D)\<close> \<open>Df.left (F (trg\<^sub>C f))\<close>
using assms Df.left_hom_is_subcategory by simp
interpret Df: left_hom \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<open>F (trg\<^sub>C f)\<close>
using assms D.weak_unit_char
apply unfold_locales by simp
interpret Df: left_hom_with_unit \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<open>\<i>[trg\<^sub>C f]\<close> \<open>F (trg\<^sub>C f)\<close>
proof
show "Df.weak_unit (F (trg\<^sub>C f))"
using assms D.weak_unit_char
by (metis C.ideD(1) C.trg.preserves_reflects_arr C.trg_trg weakly_preserves_trg)
show "\<guillemotleft>\<i>[trg\<^sub>C f] : F (trg\<^sub>C f) \<star>\<^sub>D F (trg\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
using assms \<i>_in_hom by simp
show "D.iso \<i>[trg\<^sub>C f]"
using assms iso_\<i> by simp
qed
have "\<exists>!\<mu>. \<guillemotleft>\<mu> : Df.L (F f) \<Rightarrow>\<^sub>S F f\<guillemotright> \<and>
Df.L \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>S \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
proof -
have "Df.left (F (trg\<^sub>C f)) (F f)"
using assms weakly_preserves_src D.isomorphic_def D.hseq_char D.hseq_char'
Df.left_def
by fastforce
thus ?thesis
using assms Df.lunit_char(3) S.ide_char S.arr_char by simp
qed
moreover have "Df.L (F f) = F (trg\<^sub>C f) \<star>\<^sub>D F f"
using assms by (simp add: Df.H\<^sub>L_def)
moreover have "\<And>\<mu>. Df.L \<mu> = F (trg\<^sub>C f) \<star>\<^sub>D \<mu>"
using Df.H\<^sub>L_def by simp
moreover have "(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>S \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f] =
(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
by (metis (no_types, lifting) D.assoc'_eq_inv_assoc D.ext D.hseqE D.seqE
D.vconn_implies_hpar(1) D.vconn_implies_hpar(3) Df.characteristic_iso(4)
Df.equivalence_functor_L Df.iso_unit(2) S.comp_simp S.ext S.ide_char
S.in_hom_char S.iso_is_arr S.null_char calculation(1) category.ide_cod
category.in_homE equivalence_functor_def)
moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<longleftrightarrow>
\<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>S F f\<guillemotright>"
using assms S.in_hom_char S.arr_char
by (metis D.in_homE Df.hom_connected(2) Df.left_def calculation(1) calculation(2))
ultimately show ?thesis by simp
qed
hence 1: "?P (lF f)"
using lF_def the1I2 [of ?P ?P] by simp
show "\<guillemotleft>lF f : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright>"
using 1 by simp
show "F (trg\<^sub>C f) \<star>\<^sub>D lF f = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
using 1 by simp
qed
lemma lF_simps [simp]:
assumes "C.ide f"
shows "D.arr (lF f)"
and "src\<^sub>D (lF f) = map\<^sub>0 (src\<^sub>C f)" and "trg\<^sub>D (lF f) = map\<^sub>0 (trg\<^sub>C f)"
and "D.dom (lF f) = F (trg\<^sub>C f) \<star>\<^sub>D F f" and "D.cod (lF f) = F f"
proof -
show "D.arr (lF f)"
using assms lF_char(1) by auto
show "D.dom (lF f) = F (trg\<^sub>C f) \<star>\<^sub>D F f"
using assms lF_char(1) by auto
show "D.cod (lF f) = F f"
using assms lF_char(1) by auto
show "src\<^sub>D (lF f) = map\<^sub>0 (src\<^sub>C f)"
unfolding map\<^sub>0_def
using assms \<open>D.arr (lF f)\<close> \<open>D.cod (lF f) = F f\<close> D.src_cod by fastforce
show "trg\<^sub>D (lF f) = map\<^sub>0 (trg\<^sub>C f)"
using assms \<open>D.arr (lF f)\<close> \<open>D.cod (lF f) = F f\<close> D.trg_cod by fastforce
qed
text \<open>
\sloppypar
The next two lemmas generalize the eponymous results from
@{theory MonoidalCategory.MonoidalFunctor}. See the proofs of those results for diagrams.
\<close>
lemma lunit_coherence1:
assumes "C.ide f"
shows "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) = lF f"
proof -
let ?b = "trg\<^sub>C f"
have 1: "trg\<^sub>D (F f) = map\<^sub>0 ?b"
using assms by simp
have "lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f) = \<l>\<^sub>D[F f]"
proof -
have "D.par (lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f)) \<l>\<^sub>D[F f]"
- using assms 1 D.lunit_in_hom \<Psi>_char(1-2) lF_char(1) D.ideD(1) D.hseqI'
- by auto
+ using assms 1 D.lunit_in_hom \<Psi>_char(1-2) lF_char(1) D.ideD(1) by auto
moreover have "map\<^sub>0 ?b \<star>\<^sub>D (lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f)) = map\<^sub>0 ?b \<star>\<^sub>D \<l>\<^sub>D[F f]"
proof -
have "map\<^sub>0 ?b \<star>\<^sub>D (lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f)) =
(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (map\<^sub>0 ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
- using assms D.objE [of "map\<^sub>0 (trg\<^sub>C f)"] D.hseqI'
+ using assms D.objE [of "map\<^sub>0 (trg\<^sub>C f)"]
D.whisker_left [of "map\<^sub>0 ?b" "lF f" "\<Psi> ?b \<star>\<^sub>D F f"]
by auto
also have "... = (map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D
(D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
proof -
have "(D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f) =
D.inv (\<Psi> ?b) \<cdot>\<^sub>D \<Psi> ?b \<star>\<^sub>D F ?b \<cdot>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f \<cdot>\<^sub>D F f"
- using assms \<Psi>_char(1-2) D.hseqI'
+ using assms \<Psi>_char(1-2)
D.interchange [of "F ?b" "\<Psi> ?b" "F f" "F f"]
D.interchange [of "D.inv (\<Psi> ?b)" "\<Psi> ?b" "F ?b \<star>\<^sub>D F f" "\<Psi> ?b \<star>\<^sub>D F f"]
by simp
also have "... = map\<^sub>0 ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f"
using assms \<Psi>_char(1-2) [of ?b] D.comp_arr_dom D.comp_cod_arr D.comp_inv_arr
by (simp add: D.inv_is_inverse)
finally show ?thesis by simp
qed
also have "... = (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
proof -
have "(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) =
(D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
proof -
have "(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) = D.inv (\<Psi> ?b) \<star>\<^sub>D lF f"
using assms \<Psi>_char(1-2) lF_char(1) D.comp_arr_dom D.comp_cod_arr
D.interchange [of "map\<^sub>0 ?b" "D.inv (\<Psi> ?b)" "lF f" "F ?b \<star>\<^sub>D F f"]
by simp
also have "... = D.inv (\<Psi> ?b) \<cdot>\<^sub>D F ?b \<star>\<^sub>D F f \<cdot>\<^sub>D lF f"
using assms \<Psi>_char(1-2) lF_char(1) D.comp_arr_dom D.comp_cod_arr
D.inv_in_hom
by auto
also have "... = (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
using assms \<Psi>_char(1-2) lF_char(1) D.inv_in_hom
D.interchange [of "D.inv (\<Psi> ?b)" "F ?b" "F f" "lF f"]
by simp
finally show ?thesis by simp
qed
thus ?thesis
using assms \<Psi>_char(1-2) D.inv_in_hom D.comp_assoc by metis
qed
also have "... = (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f] \<cdot>\<^sub>D
(\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
using assms \<Psi>_char(1-2) lF_char(2) D.comp_assoc by auto
also have "... = ((D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((\<Psi> ?b \<star>\<^sub>D \<Psi> ?b) \<star>\<^sub>D F f))
\<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[map\<^sub>0 ?b, map\<^sub>0 ?b, F f]"
using assms \<Psi>_char(1-2) D.assoc'_naturality [of "\<Psi> ?b" "\<Psi> ?b" "F f"] D.comp_assoc
by (simp add: \<open>trg\<^sub>D (F f) = map\<^sub>0 (trg\<^sub>C f)\<close>)
also have "... = (\<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[map\<^sub>0 ?b, map\<^sub>0 ?b, F f]"
proof -
have "((D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((\<Psi> ?b \<star>\<^sub>D \<Psi> ?b) \<star>\<^sub>D F f)) =
\<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
proof -
have "((D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((\<Psi> ?b \<star>\<^sub>D \<Psi> ?b) \<star>\<^sub>D F f)) =
D.inv (\<Psi> ?b) \<cdot>\<^sub>D \<Psi> ?b \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
using assms 1 D.unit_in_hom D.whisker_right [of "F f"] \<Psi>_char(2-3)
D.invert_side_of_triangle(1)
by (metis C.ideD(1) C.obj_trg D.seqI' map\<^sub>0_simps(1) \<Psi>_in_hom(2) preserves_ide)
also have "... = \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
proof -
have "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D \<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 ?b] = \<i>\<^sub>D[map\<^sub>0 ?b]"
by (simp add: D.comp_cod_arr D.comp_inv_arr D.inv_is_inverse \<Psi>_char(2) assms)
thus ?thesis
by (simp add: D.comp_assoc)
qed
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = map\<^sub>0 ?b \<star>\<^sub>D \<l>\<^sub>D[F f]"
using assms D.lunit_char [of "F f"] \<open>trg\<^sub>D (F f) = map\<^sub>0 ?b\<close> by simp
finally show ?thesis by blast
qed
ultimately show ?thesis
using assms D.L.is_faithful
by (metis D.trg_cod D.trg_vcomp D.vseq_implies_hpar(2) lF_simps(3))
qed
thus ?thesis
using assms 1 \<Psi>_char(1-2) C.ideD(1) C.obj_trg D.inverse_arrows_hcomp(1)
D.invert_side_of_triangle(2) D.lunit_simps(1) \<Psi>_simps(2) preserves_ide
D.iso_hcomp components_are_iso
by metis
qed
lemma lunit_coherence2:
assumes "C.ide f"
shows "lF f = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)"
proof -
let ?b = "trg\<^sub>C f"
have "D.par (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f)) (lF f)"
using assms \<Phi>_in_hom [of ?b f] lF_simps by auto
moreover have "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f) = F ?b \<star>\<^sub>D lF f"
proof -
have "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f) = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D \<Phi> (?b, f))"
using assms \<Phi>_in_hom D.whisker_left [of "F ?b" "F \<l>\<^sub>C[f]" "\<Phi> (?b, f)"]
by (simp add: calculation)
also have "... = F ?b \<star>\<^sub>D lF f"
proof -
have "(F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D \<Phi> (?b, f))
= (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D
\<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
proof -
have 1: "D.seq (F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f])
(\<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f))"
- using assms \<Phi>_in_hom by fastforce
+ using assms by fastforce
hence 2: "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
(\<Phi> (?b, ?b) \<star>\<^sub>D F f)
= (F ?b \<star>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F ?b, F ?b, F f]"
using assms \<Phi>_in_hom assoc_coherence \<Phi>_components_are_iso
D.invert_side_of_triangle(1)
[of "F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f)"
"\<Phi> (?b, ?b \<star>\<^sub>C f)"
"(F ?b \<star>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F ?b, F ?b, F f]"]
- C.ideD(1) C.ide_hcomp C.trg_hcomp' C.trg_trg C.src_trg C.trg.preserves_ide
+ C.ideD(1) C.ide_hcomp C.trg_hcomp C.trg_trg C.src_trg C.trg.preserves_ide
by metis
hence "F ?b \<star>\<^sub>D \<Phi> (?b, f)
= (D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
(\<Phi> (?b, ?b) \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
proof -
have "D.seq (D.inv (\<Phi> (trg\<^sub>C f, trg\<^sub>C f \<star>\<^sub>C f)))
(F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D
(\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f))"
- using assms 1 \<Phi>_in_hom \<Phi>_components_are_iso preserves_hseq preserves_inv
- preserves_iso D.hseq_char
- by auto
+ using assms 1 D.hseq_char by auto
moreover have "(F (trg\<^sub>C f) \<star>\<^sub>D \<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F (trg\<^sub>C f), F (trg\<^sub>C f), F f] =
D.inv (\<Phi> (trg\<^sub>C f, trg\<^sub>C f \<star>\<^sub>C f)) \<cdot>\<^sub>D
F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D
(\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f)"
- using assms 2 \<Phi>_in_hom by simp
+ using assms 2 by simp
ultimately show ?thesis
- using assms \<Phi>_components_are_iso D.iso_assoc
+ using assms
D.invert_side_of_triangle(2)
[of "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
(\<Phi> (?b, ?b) \<star>\<^sub>D F f)"
"F ?b \<star>\<^sub>D \<Phi> (?b, f)" "\<a>\<^sub>D[F ?b, F ?b, F f]"]
- by simp
+ by fastforce
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
(D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)) \<cdot>\<^sub>D
\<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
proof -
have 1: "F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) = F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[?b, ?b, f])"
- using assms C.lunit_char(1-2) C.unit_in_hom preserves_inv C.hseqI' by auto
+ using assms C.lunit_char(1-2) C.unit_in_hom preserves_inv by auto
have "F \<a>\<^sub>C[?b, ?b, f] = D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)"
proof -
have "F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D D.inv (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)) =
D.inv (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[?b, ?b, f]))"
using assms D.iso_inv_iso
- by (simp add: C.hseqI' C.iso_unit D.inv_comp)
+ by (simp add: C.iso_unit D.inv_comp)
thus ?thesis
using assms 1 D.invert_side_of_triangle D.iso_inv_iso
by (metis C.iso_hcomp C.ideD(1) C.ide_is_iso C.iso_lunit C.iso_unit
C.lunit_simps(3) C.obj_trg C.src_trg C.trg.components_are_iso
C.unit_simps(2) D.arr_inv D.inv_inv preserves_iso)
qed
thus ?thesis by argo
qed
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f)) \<cdot>\<^sub>D
(\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
using D.comp_assoc by auto
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D (\<Phi> (?b, f) \<cdot>\<^sub>D (F \<i>\<^sub>C[?b] \<star>\<^sub>D F f)) \<cdot>\<^sub>D
(\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
using assms \<Phi>.naturality [of "(\<i>\<^sub>C[?b], f)"] FF_def C.VV.arr_char C.VV.cod_char
C.VV.dom_char
by simp
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f) \<cdot>\<^sub>D
((F \<i>\<^sub>C[?b] \<star>\<^sub>D F f)) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
using D.comp_assoc by auto
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
using assms by (simp add: D.comp_assoc D.whisker_right)
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D
(D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D
(F ?b \<star>\<^sub>D lF f)"
proof -
have "(\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f] = F ?b \<star>\<^sub>D lF f"
using assms lF_char by auto
thus ?thesis
using assms D.inv_is_inverse \<i>_in_hom \<Phi>_in_hom D.invert_side_of_triangle(2)
by (simp add: D.comp_assoc)
qed
also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
proof -
have "D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) =
D.inv (((F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f))) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
- proof -
- have "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f) = F ?b \<star>\<^sub>D F (?b \<star>\<^sub>C f)"
- using assms D.comp_inv_arr \<Phi>_components_are_iso D.comp_inv_arr' \<Phi>_simps(4)
- by auto
- thus ?thesis
- using assms D.comp_arr_dom D.comp_assoc D.hseqI' by simp
- qed
+ using assms D.comp_inv_arr D.comp_inv_arr' \<Phi>_simps(4)
+ D.comp_arr_dom D.comp_assoc
+ by simp
also have "... = D.inv (D.inv (\<Phi> (?b, f)) \<cdot>\<^sub>D F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
proof -
have 1: "\<Phi> (?b, f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) = F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)"
using assms \<Phi>.naturality [of "(?b, \<l>\<^sub>C[f])"] FF_def C.VV.arr_char
C.VV.cod_char D.VV.null_char
by simp
have "(F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) =
D.inv (\<Phi> (?b, f)) \<cdot>\<^sub>D F (?b \<star>\<^sub>C \<l>\<^sub>C[f])"
proof -
have "D.seq (\<Phi> (?b, f)) (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])"
- using assms \<Phi>_in_hom(2) [of ?b f] D.hseqI' by auto
+ using assms \<Phi>_in_hom(2) [of ?b f] by auto
moreover have "D.iso (\<Phi> (?b, f)) \<and> D.iso (\<Phi> (?b, ?b \<star>\<^sub>C f))"
- using assms \<Phi>_components_are_iso by simp
+ using assms by simp
ultimately show ?thesis
- using 1 D.invert_opposite_sides_of_square
- [of "\<Phi> (?b, f)" "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]" "F (?b \<star>\<^sub>C \<l>\<^sub>C[f])" "\<Phi> (?b, ?b \<star>\<^sub>C f)"]
- by simp
+ using 1 D.invert_opposite_sides_of_square by simp
qed
thus ?thesis
using D.comp_assoc by auto
qed
also have "... = D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D \<Phi> (?b, f)"
proof -
have "D.iso (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
- using assms \<Phi>_components_are_iso D.isos_compose C.VV.arr_char C.iso_lunit
- C.hseqI'
- by simp
+ using assms D.isos_compose C.VV.arr_char C.iso_lunit by simp
moreover have "D.iso (D.inv (\<Phi> (?b, f)))"
using assms D.iso_inv_iso by simp
moreover have "D.seq (D.inv (\<Phi> (?b, f))) (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
- using assms \<Phi>_in_hom(2) [of ?b f] \<Phi>_components_are_iso C.VV.arr_char C.hseqI'
- by simp
+ using assms C.VV.arr_char by simp
ultimately show ?thesis
- using assms \<Phi>_components_are_iso D.inv_comp by simp
+ using assms D.inv_comp by simp
qed
also have "... = D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)"
proof -
have "D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)) =
D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]))"
- using assms \<Phi>_components_are_iso D.isos_compose C.VV.arr_char C.iso_lunit
- D.inv_comp C.hseqI'
- by simp
+ using assms D.isos_compose C.VV.arr_char C.iso_lunit D.inv_comp by simp
thus ?thesis using D.comp_assoc by simp
qed
finally have "D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])
= D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)"
by blast
thus ?thesis by argo
qed
also have "... = ((F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
using D.comp_assoc by simp
also have "... = F ?b \<star>\<^sub>D lF f"
- using assms D.comp_arr_inv' [of "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]"] D.comp_cod_arr preserves_iso
- D.hseqI'
- by simp
+ using assms D.comp_arr_inv' [of "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]"] D.comp_cod_arr by simp
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
ultimately show ?thesis
using assms D.L.is_faithful
by (metis D.in_homI lF_char(2-3) lF_simps(4-5))
qed
lemma lunit_coherence:
assumes "C.ide f"
shows "\<l>\<^sub>D[F f] = 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)"
proof -
have 1: "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)"
using assms lunit_coherence1 lunit_coherence2 by simp
have "\<l>\<^sub>D[F f] = (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)"
proof -
have "D.seq (F \<l>\<^sub>C[f]) (\<Phi> (trg\<^sub>C f, f))"
using assms \<Phi>_in_hom [of "trg\<^sub>C f" f] C.unit_in_vhom by auto
moreover have "D.iso (D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
using assms \<Psi>_char D.iso_inv_iso \<Psi>_char(1-2)
by (simp add: preserves_hseq)
ultimately show ?thesis
using assms 1 \<Psi>_char(2) D.iso_inv_iso \<Phi>_in_hom D.inv_inv
D.invert_side_of_triangle(2)
[of "F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)" "\<l>\<^sub>D[F f]" "D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"]
by auto
qed
thus ?thesis
using assms \<Psi>_char(1) D.comp_assoc by auto
qed
text \<open>
We postpone proving the dual version of this result until after we have developed
the notion of the ``op bicategory'' in the next section.
\<close>
end
subsection "Pseudofunctors and Opposite Bicategories"
text \<open>
There are three duals to a bicategory:
\begin{enumerate}
\item ``op'': sources and targets are exchanged;
\item ``co'': domains and codomains are exchanged;
\item ``co-op'': both sources and targets and domains and codomains are exchanged.
\end{enumerate}
Here we consider the "op" case.
\<close>
locale op_bicategory =
B: bicategory V H\<^sub>B \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B
for V :: "'a comp" (infixr "\<cdot>" 55)
and H\<^sub>B :: "'a comp" (infixr "\<star>\<^sub>B" 53)
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"
begin
abbreviation H (infixr "\<star>" 53)
where "H f g \<equiv> H\<^sub>B g f"
abbreviation src
where "src \<equiv> trg\<^sub>B"
abbreviation trg
where "trg \<equiv> src\<^sub>B"
interpretation H: horizontal_homs V src trg
by (unfold_locales, auto)
interpretation VV: subcategory B.VxV.comp
\<open>\<lambda>\<mu>\<nu>. B.arr (fst \<mu>\<nu>) \<and> B.arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
by (unfold_locales, auto)
interpretation H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
- using VV.arr_char B.hseqI'
+ using VV.arr_char
apply unfold_locales
apply (metis (no_types, lifting) B.hseqE B.hseq_char')
apply auto[3]
using VV.comp_char VV.seq_char VV.arr_char B.VxV.comp_char B.interchange
by (metis (no_types, lifting) B.VxV.seqE fst_conv snd_conv)
interpretation horizontal_composition V H src trg
- by (unfold_locales, simp_all)
+ by (unfold_locales, auto)
interpretation VVV: subcategory B.VxVxV.comp
\<open>\<lambda>\<tau>\<mu>\<nu>. B.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 H.subcategory_VVV by auto
interpretation "functor" VVV.comp V HoHV
using functor_HoHV by auto
interpretation "functor" VVV.comp V HoVH
using functor_HoVH by auto
abbreviation UP
where "UP \<mu>\<nu>\<tau> \<equiv> if B.VVV.arr \<mu>\<nu>\<tau> then
(snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)
else VVV.null"
abbreviation DN
where "DN \<mu>\<nu>\<tau> \<equiv> if VVV.arr \<mu>\<nu>\<tau> then
(snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)
else B.VVV.null"
lemma VVV_arr_char:
shows "VVV.arr \<mu>\<nu>\<tau> \<longleftrightarrow> B.VVV.arr (DN \<mu>\<nu>\<tau>)"
using VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char B.VVV.not_arr_null
by auto
lemma VVV_ide_char:
shows "VVV.ide \<mu>\<nu>\<tau> \<longleftrightarrow> B.VVV.ide (DN \<mu>\<nu>\<tau>)"
proof -
have "VVV.ide \<mu>\<nu>\<tau> \<longleftrightarrow> VVV.arr \<mu>\<nu>\<tau> \<and> B.VxVxV.ide \<mu>\<nu>\<tau>"
using VVV.ide_char by simp
also have "... \<longleftrightarrow> B.VVV.arr (DN \<mu>\<nu>\<tau>) \<and> B.VxVxV.ide (DN \<mu>\<nu>\<tau>)"
using VVV_arr_char B.VxVxV.ide_char by auto
also have "... \<longleftrightarrow> B.VVV.ide (DN \<mu>\<nu>\<tau>)"
using B.VVV.ide_char [of "DN \<mu>\<nu>\<tau>"] by blast
finally show ?thesis by fast
qed
lemma VVV_dom_char:
shows "VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
proof (cases "VVV.arr \<mu>\<nu>\<tau>")
show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
using VVV.dom_def VVV.has_domain_iff_arr VVV_arr_char B.VVV.dom_null
by auto
show "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
proof -
assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
have "VVV.dom \<mu>\<nu>\<tau> =
(B.dom (fst \<mu>\<nu>\<tau>), B.dom (fst (snd \<mu>\<nu>\<tau>)), B.dom (snd (snd \<mu>\<nu>\<tau>)))"
using \<mu>\<nu>\<tau> VVV.dom_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
by simp
also have "... = UP (B.dom (snd (snd \<mu>\<nu>\<tau>)), B.dom (fst (snd \<mu>\<nu>\<tau>)), B.dom (fst \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> VVV_arr_char B.VV.arr_char B.VVV.arr_char B.arr_dom_iff_arr H.src_dom
H.trg_dom
apply simp
by (metis (no_types, lifting) H.src_dom H.trg_dom VV.arrE VVV.arrE)
also have "... = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> B.VVV.dom_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
by simp
finally show ?thesis by blast
qed
qed
lemma VVV_cod_char:
shows "VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
proof (cases "VVV.arr \<mu>\<nu>\<tau>")
show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
using VVV.cod_def VVV.has_codomain_iff_arr VVV_arr_char B.VVV.cod_null
by auto
show "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
proof -
assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
have "VVV.cod \<mu>\<nu>\<tau> = (B.cod (fst \<mu>\<nu>\<tau>), B.cod (fst (snd \<mu>\<nu>\<tau>)), B.cod (snd (snd \<mu>\<nu>\<tau>)))"
using \<mu>\<nu>\<tau> VVV.cod_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
by simp
also have "... = UP (B.cod (snd (snd \<mu>\<nu>\<tau>)), B.cod (fst (snd \<mu>\<nu>\<tau>)), B.cod (fst \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> VVV_arr_char B.VV.arr_char B.VVV.arr_char
apply simp
by (metis (no_types, lifting) B.arr_cod_iff_arr H.src_cod H.trg_cod VV.arrE VVV.arrE)
also have "... = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> B.VVV.cod_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
by simp
finally show ?thesis by blast
qed
qed
lemma HoHV_char:
shows "HoHV \<mu>\<nu>\<tau> = B.HoVH (DN \<mu>\<nu>\<tau>)"
using HoHV_def B.HoVH_def VVV_arr_char by simp
lemma HoVH_char:
shows "HoVH \<mu>\<nu>\<tau> = B.HoHV (DN \<mu>\<nu>\<tau>)"
using HoVH_def B.HoHV_def VVV_arr_char by simp
definition \<a> ("\<a>[_, _, _]")
where "\<a>[\<mu>, \<nu>, \<tau>] \<equiv> B.\<alpha>' (DN (\<mu>, \<nu>, \<tau>))"
interpretation natural_isomorphism VVV.comp \<open>(\<cdot>)\<close> HoHV HoVH
\<open>\<lambda>\<mu>\<nu>\<tau>. \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]\<close>
proof
fix \<mu>\<nu>\<tau>
show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = B.null"
using VVV.arr_char B.VVV.arr_char \<a>_def B.\<alpha>'.is_extensional by auto
assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
show "B.dom \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
proof -
have "HoHV (VVV.dom \<mu>\<nu>\<tau>) =
(B.dom (fst \<mu>\<nu>\<tau>) \<star> B.dom (fst (snd \<mu>\<nu>\<tau>))) \<star> B.dom (snd (snd \<mu>\<nu>\<tau>))"
unfolding HoHV_def B.VxVxV.dom_char
using \<mu>\<nu>\<tau> VVV.arr_char VVV.dom_char VV.arr_char by simp
also have "... = B.HoVH (B.VVV.dom (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
unfolding B.HoVH_def B.VxVxV.dom_char
using \<mu>\<nu>\<tau> B.VVV.dom_char B.VxVxV.dom_char B.VVV.arr_char B.VV.arr_char
apply simp
by (metis (no_types, lifting) VV.arr_char VVV.arrE)
also have "... = B.dom (B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> B.\<alpha>'.preserves_dom VVV_arr_char by presburger
also have "... = B.dom \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
using \<mu>\<nu>\<tau> \<a>_def by simp
finally show ?thesis by simp
qed
show "B.cod \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
proof -
have "HoVH (VVV.cod \<mu>\<nu>\<tau>) =
B.cod (fst \<mu>\<nu>\<tau>) \<star> B.cod (fst (snd \<mu>\<nu>\<tau>)) \<star> B.cod (snd (snd \<mu>\<nu>\<tau>))"
unfolding HoVH_def B.VxVxV.cod_char
using \<mu>\<nu>\<tau> VVV.arr_char VVV.cod_char VV.arr_char by simp
also have "... = B.HoHV (B.VVV.cod (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
unfolding B.HoHV_def B.VxVxV.cod_char
using \<mu>\<nu>\<tau> B.VVV.cod_char B.VxVxV.cod_char B.VVV.arr_char B.VV.arr_char
apply simp
by (metis (no_types, lifting) VV.arr_char VVV.arrE)
also have "... = B.cod (B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
using \<mu>\<nu>\<tau> B.\<alpha>'.preserves_cod VVV_arr_char by presburger
also have "... = B.cod \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
using \<mu>\<nu>\<tau> \<a>_def by simp
finally show ?thesis by simp
qed
show "HoVH \<mu>\<nu>\<tau> \<cdot>
\<a>[fst (VVV.dom \<mu>\<nu>\<tau>), fst (snd (VVV.dom \<mu>\<nu>\<tau>)), snd (snd (VVV.dom \<mu>\<nu>\<tau>))] =
\<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
proof -
have "HoVH \<mu>\<nu>\<tau> \<cdot>
\<a>[fst (VVV.dom \<mu>\<nu>\<tau>), fst (snd (VVV.dom \<mu>\<nu>\<tau>)), snd (snd (VVV.dom \<mu>\<nu>\<tau>))] =
HoVH \<mu>\<nu>\<tau> \<cdot> B.\<alpha>' (B.VVV.dom (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
unfolding \<a>_def
using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char VVV.dom_char B.VVV.arr_char B.VVV.dom_char
by auto
also have "... = B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)"
using B.\<alpha>'.is_natural_1 VVV_arr_char \<mu>\<nu>\<tau> HoVH_char by presburger
also have "... = \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
using \<mu>\<nu>\<tau> \<a>_def by simp
finally show ?thesis by blast
qed
show "\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
HoHV \<mu>\<nu>\<tau> =
\<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
proof -
have "\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
HoHV \<mu>\<nu>\<tau> =
B.\<alpha>' (B.VVV.cod (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)) \<cdot> HoHV \<mu>\<nu>\<tau>"
unfolding \<a>_def
using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char VVV.cod_char B.VVV.arr_char B.VVV.cod_char
by auto
also have "... = B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)"
using B.\<alpha>'.is_natural_2 VVV_arr_char \<mu>\<nu>\<tau> HoHV_char by presburger
also have "... = \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
using \<mu>\<nu>\<tau> \<a>_def by simp
finally show ?thesis by blast
qed
next
fix \<mu>\<nu>\<tau>
assume \<mu>\<nu>\<tau>: "VVV.ide \<mu>\<nu>\<tau>"
show "B.iso \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
proof -
have "B.VVV.ide (DN \<mu>\<nu>\<tau>)"
using \<mu>\<nu>\<tau> VVV_ide_char by blast
thus ?thesis
using \<mu>\<nu>\<tau> \<a>_def B.\<alpha>'.components_are_iso by auto
qed
qed
interpretation bicategory V H \<a> \<i> src trg
proof
show "\<And>a. H.obj a \<Longrightarrow> \<guillemotleft>\<i> a : H a a \<rightarrow>\<^sub>B a\<guillemotright>"
using H.obj_def H.objE B.obj_def B.objE B.unit_in_hom by meson
show "\<And>a. H.obj a \<Longrightarrow> B.iso (\<i> a)"
using H.obj_def H.objE B.obj_def B.objE B.iso_unit by meson
show "\<And>f g h k. \<lbrakk> B.ide f; B.ide g; B.ide h; B.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]"
unfolding \<a>_def
using B.\<a>'_def B.comp_assoc B.pentagon' VVV.arr_char VV.arr_char by simp
qed
proposition is_bicategory:
shows "bicategory V H \<a> \<i> src trg"
..
end
sublocale op_bicategory \<subseteq> bicategory V H \<a> \<i> src trg
using is_bicategory by auto
context op_bicategory
begin
lemma assoc_ide_simp:
assumes "B.ide f" and "B.ide g" and "B.ide h"
and "src f = trg g" and "src g = trg h"
shows "\<a>[f, g, h] = B.\<a>' h g f"
using assms \<a>_def B.\<a>'_def by fastforce
lemma lunit_ide_simp:
assumes "B.ide f"
shows "lunit f = B.runit f"
proof (intro B.runit_eqI)
show "B.ide f" by fact
show "\<guillemotleft>lunit f : H (trg f) f \<rightarrow>\<^sub>B f\<guillemotright>"
using assms by simp
show "trg f \<star> lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sub>B[f, trg f, trg f]"
proof -
have "trg f \<star> lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>' (trg f) (trg f) f"
using assms lunit_char(1-2) [of f] by simp
moreover have "\<a>' (trg f) (trg f) f = \<a>\<^sub>B[f, trg f, trg f]"
proof (unfold \<a>'_def)
have 1: "VVV.ide (trg f, trg f, f)"
using assms VVV.ide_char VVV.arr_char VV.arr_char by simp
have "\<alpha>' (trg f, trg f, f) = B.inv \<a>[trg f, trg f, f]"
using 1 B.\<alpha>'.inverts_components by simp
also have "... = B.inv (B.\<alpha>' (f, trg f, trg f))"
unfolding \<a>_def using 1 by simp
also have "... = \<a>\<^sub>B[f, trg f, trg f]"
using 1 B.VVV.ide_char B.VVV.arr_char B.VV.arr_char VVV.ide_char
VVV.arr_char VV.arr_char B.\<alpha>'.inverts_components B.\<alpha>_def
by force
finally show "\<alpha>' (trg f, trg f, f) = \<a>\<^sub>B[f, trg f, trg f]"
by blast
qed
ultimately show ?thesis by simp
qed
qed
lemma runit_ide_simp:
assumes "B.ide f"
shows "runit f = B.lunit f"
using assms runit_char(1-2) [of f] B.\<a>'_def assoc_ide_simp
apply (intro B.lunit_eqI)
by simp_all
end
context pseudofunctor
begin
interpretation C': op_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C ..
interpretation D': op_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
notation C'.H (infixr "\<star>\<^sub>C\<^sup>o\<^sup>p" 53)
notation D'.H (infixr "\<star>\<^sub>D\<^sup>o\<^sup>p" 53)
interpretation F': weak_arrow_of_homs V\<^sub>C C'.src C'.trg V\<^sub>D D'.src D'.trg F
apply unfold_locales
using weakly_preserves_src weakly_preserves_trg by simp_all
interpretation FF: "functor" C'.VV.comp D'.VV.comp F'.FF
using F'.functor_FF by auto
interpretation H\<^sub>D'oFF: composite_functor C'.VV.comp D'.VV.comp V\<^sub>D F'.FF
\<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>D\<^sup>o\<^sup>p snd \<mu>\<nu>\<close> ..
interpretation FoH\<^sub>C': composite_functor C'.VV.comp V\<^sub>C V\<^sub>D
\<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>C\<^sup>o\<^sup>p snd \<mu>\<nu>\<close> F
..
interpretation \<Phi>': natural_isomorphism C'.VV.comp V\<^sub>D H\<^sub>D'oFF.map FoH\<^sub>C'.map
\<open>\<lambda>f. \<Phi> (snd f, fst f)\<close>
using C.VV.arr_char C'.VV.arr_char C'.VV.ide_char C.VV.ide_char FF_def F'.FF_def
- \<Phi>.is_extensional \<Phi>.is_natural_1 \<Phi>.is_natural_2 \<Phi>.components_are_iso
+ \<Phi>.is_extensional \<Phi>.is_natural_1 \<Phi>.is_natural_2
apply unfold_locales by auto
interpretation F': pseudofunctor V\<^sub>C C'.H C'.\<a> \<i>\<^sub>C C'.src C'.trg
V\<^sub>D D'.H D'.\<a> \<i>\<^sub>D D'.src D'.trg
F \<open>\<lambda>f. \<Phi> (snd f, fst f)\<close>
proof
fix f g h
assume f: "C.ide f" and g: "C.ide g" and h: "C.ide h"
and fg: "C'.src f = C'.trg g" and gh: "C'.src g = C'.trg h"
have "F (C'.\<a> f g h) \<cdot>\<^sub>D \<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h) =
\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g)) \<cdot>\<^sub>D D'.\<a> (F f) (F g) (F h)"
proof -
have "F (\<a>\<^sub>C h g f) \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g)) =
(\<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h)) \<cdot>\<^sub>D \<a>\<^sub>D (F h) (F g) (F f)"
using f g h fg gh assoc_coherence D.comp_assoc by simp
moreover have "D.seq (F \<a>\<^sub>C[h, g, f]) (\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g)))"
proof -
have "\<guillemotleft>F (\<a>\<^sub>C h g f) : F ((h \<star>\<^sub>C g) \<star>\<^sub>C f) \<Rightarrow>\<^sub>D F (h \<star>\<^sub>C g \<star>\<^sub>C f)\<guillemotright>"
using f g h fg gh preserves_hom C.assoc_in_hom(2) by simp
moreover have "\<guillemotleft>\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) : F (h \<star>\<^sub>C g) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F ((h \<star>\<^sub>C g) \<star>\<^sub>C f)\<guillemotright>"
- using f g h fg gh preserves_hom \<Phi>.preserves_hom by auto
+ using f g h fg gh by auto
moreover have "\<guillemotleft>F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g) : (F h \<star>\<^sub>D F g) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (h \<star>\<^sub>C g) \<star>\<^sub>D F f\<guillemotright>"
- using f g h fg gh preserves_hom \<Phi>.preserves_hom C.VV.in_hom_char
- FF_def C.VV.arr_char D.hseqI'
- by auto
+ using f g h fg gh C.VV.in_hom_char FF_def C.VV.arr_char by auto
ultimately show ?thesis by auto
qed
moreover have "D.iso (F \<a>\<^sub>C[h, g, f])"
using f g h fg gh by simp
moreover have "D.iso \<a>\<^sub>D[F h, F g, F f]"
using f g h fg gh by simp
moreover have "D.inv (F \<a>\<^sub>C[h, g, f]) = F (C'.\<a> f g h)"
using f g h fg gh
by (simp add: C'.assoc_ide_simp preserves_inv)
moreover have "D.inv \<a>\<^sub>D[F h, F g, F f] = D'.\<a> (F f) (F g) (F h)"
using f g h fg gh
by (simp add: D'.assoc_ide_simp)
ultimately show ?thesis
using D.invert_opposite_sides_of_square
[of "F (\<a>\<^sub>C h g f)" "\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g))"
"\<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h)" "\<a>\<^sub>D (F h) (F g) (F f)"]
D.comp_assoc
by simp
qed
thus "F (C'.\<a> f g h) \<cdot>\<^sub>D \<Phi> (snd (f \<star>\<^sub>C\<^sup>o\<^sup>p g, h), fst (f \<star>\<^sub>C\<^sup>o\<^sup>p g, h)) \<cdot>\<^sub>D
(\<Phi> (snd (f, g), fst (f, g)) \<star>\<^sub>D\<^sup>o\<^sup>p F h) =
\<Phi> (snd (f, g \<star>\<^sub>C\<^sup>o\<^sup>p h), fst (f, g \<star>\<^sub>C\<^sup>o\<^sup>p h)) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (snd (g, h), fst (g, h))) \<cdot>\<^sub>D
D'.\<a> (F f) (F g) (F h)"
using f g h fg gh by simp
qed
lemma induces_pseudofunctor_between_opposites:
shows "pseudofunctor (\<cdot>\<^sub>C) (\<star>\<^sub>C\<^sup>o\<^sup>p) C'.\<a> \<i>\<^sub>C C'.src C'.trg
(\<cdot>\<^sub>D) (\<star>\<^sub>D\<^sup>o\<^sup>p) D'.\<a> \<i>\<^sub>D D'.src D'.trg
F (\<lambda>f. \<Phi> (snd f, fst f))"
..
text \<open>
It is now easy to dualize the coherence condition for \<open>F\<close> with respect to
left unitors to obtain the corresponding condition for right unitors.
\<close>
lemma runit_coherence:
assumes "C.ide f"
shows "\<r>\<^sub>D[F f] = F \<r>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
proof -
have "C'.lunit f = \<r>\<^sub>C[f]"
using assms C'.lunit_ide_simp by simp
moreover have "D'.lunit (F f) = \<r>\<^sub>D[F f]"
using assms D'.lunit_ide_simp by simp
moreover have "F'.\<Psi> (src\<^sub>C f) = \<Psi> (src\<^sub>C f)"
using assms F'.\<Psi>_char F'.preserves_trg
by (intro \<Psi>_eqI, auto)
moreover have "D'.lunit (F f) =
F (C'.lunit f) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D F'.\<Psi> (src\<^sub>C f))"
using assms F'.lunit_coherence by simp
ultimately show ?thesis by simp
qed
end
subsection "Preservation Properties"
text \<open>
The objective of this section is to establish explicit formulas for the result
of applying a pseudofunctor to expressions of various forms.
\<close>
context pseudofunctor
begin
lemma preserves_lunit:
assumes "C.ide f"
shows "F \<l>\<^sub>C[f] = \<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
and "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] = \<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]"
proof -
have "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) = F \<l>\<^sub>C[f]"
proof -
have "D.arr \<l>\<^sub>D[F f]"
using assms by simp
moreover have "\<l>\<^sub>D[F f] = 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)"
using assms lunit_coherence by simp
moreover have "D.iso (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
- using assms \<Phi>_components_are_iso \<Psi>_char D.iso_hcomp FF_def D.hseqI'
+ using assms \<Psi>_char D.iso_hcomp FF_def
by (intro D.isos_compose D.seqI, auto)
ultimately show ?thesis
using assms
D.invert_side_of_triangle(2)
[of "\<l>\<^sub>D[F f]" "F \<l>\<^sub>C[f]" "\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"]
by metis
qed
moreover have "D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) =
(D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
- using assms \<Phi>_in_hom \<Phi>_components_are_iso C.VV.arr_char \<Psi>_char
- D.iso_hcomp FF_def D.hseqI' D.inv_comp
- by simp
+ using assms C.VV.arr_char \<Psi>_char FF_def D.inv_comp by simp
ultimately show "F \<l>\<^sub>C[f] =
\<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
by simp
hence "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] =
D.inv (\<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f)))"
- using assms preserves_inv C.iso_lunit by simp
+ using assms preserves_inv 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]"
proof -
have "\<guillemotleft>\<l>\<^sub>D[F f] : map\<^sub>0 (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and> D.iso \<l>\<^sub>D[F f]"
- using assms D.iso_lunit by simp
+ using assms by simp
moreover have "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f :
F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C f) \<star>\<^sub>D F f\<guillemotright> \<and>
D.iso (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f)"
using assms \<Psi>_char [of "trg\<^sub>C f"] D.iso_inv_iso
by (intro conjI D.hcomp_in_vhom, auto)
moreover have
"\<guillemotleft>D.inv (\<Phi> (trg\<^sub>C f, f)) : F (trg\<^sub>C f \<star>\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f) \<star>\<^sub>D F f\<guillemotright> \<and>
D.iso (D.inv (\<Phi> (trg\<^sub>C f, f)))"
using assms \<Phi>_in_hom D.iso_inv_iso by simp
moreover have "D.inv (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) = \<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f"
using assms \<Psi>_char [of "trg\<^sub>C f"] D.iso_inv_iso by simp
ultimately show ?thesis
using assms D.iso_inv_iso D.comp_assoc D.iso_hcomp D.isos_compose
- by (elim conjE D.in_homE, auto simp add: D.inv_comp)
+ apply (elim conjE D.in_homE)
+ by (auto simp add: D.inv_comp)
qed
finally show "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] = \<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]"
by simp
qed
lemma preserves_runit:
assumes "C.ide f"
shows "F \<r>\<^sub>C[f] = \<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))"
and "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
proof -
have "F \<r>\<^sub>C[f] = \<r>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)))"
proof -
have "\<r>\<^sub>D[F f] = F \<r>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
using assms runit_coherence [of f] by simp
moreover have "D.iso (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)))"
- using assms \<Phi>_components_are_iso \<Psi>_char D.iso_hcomp FF_def D.hseqI'
+ using assms \<Psi>_char D.iso_hcomp FF_def
apply (intro D.isos_compose D.seqI) by auto
moreover have "D.arr \<r>\<^sub>D[F f]"
using assms by simp
ultimately show ?thesis
using assms D.invert_side_of_triangle(2)
[of "\<r>\<^sub>D[F f]" "F \<r>\<^sub>C[f]" "\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"]
by metis
qed
moreover have "D.inv (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))) =
(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 \<Phi>_in_hom \<Phi>_components_are_iso C.VV.arr_char \<Psi>_char
- D.iso_hcomp FF_def D.hseqI' D.inv_comp
- by simp
+ using assms C.VV.arr_char \<Psi>_char D.iso_hcomp FF_def D.inv_comp by simp
ultimately show "F \<r>\<^sub>C[f] =
\<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))"
by simp
hence "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] =
D.inv (\<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 assms preserves_inv C.iso_runit by simp
also have "... = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
proof -
have "\<guillemotleft>\<r>\<^sub>D[F f] : F f \<star>\<^sub>D map\<^sub>0 (src\<^sub>C f) \<Rightarrow>\<^sub>D F f\<guillemotright> \<and> D.iso \<r>\<^sub>D[F f]"
using assms D.iso_runit by simp
moreover have "\<guillemotleft>F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) :
F f \<star>\<^sub>D F (src\<^sub>C f) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright> \<and>
D.iso (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)))"
using assms \<Psi>_char [of "src\<^sub>C f"] D.iso_inv_iso
apply (intro conjI D.hcomp_in_vhom) by auto
moreover have
"\<guillemotleft>D.inv (\<Phi> (f, src\<^sub>C f)) : F (f \<star>\<^sub>C src\<^sub>C f) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F (src\<^sub>C f)\<guillemotright> \<and>
D.iso (D.inv (\<Phi> (f, src\<^sub>C f)))"
- using assms \<Phi>_in_hom \<Phi>_components_are_iso D.iso_inv_iso by simp
+ using assms \<Phi>_in_hom D.iso_inv_iso by simp
moreover have "D.inv (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) = F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)"
using assms \<Psi>_char [of "src\<^sub>C f"] D.iso_inv_iso by simp
ultimately show ?thesis
using assms D.inv_comp D.iso_inv_iso D.comp_assoc D.isos_compose
apply (elim conjE D.in_homE)
by (auto simp add: D.inv_comp)
qed
finally show "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
by simp
qed
lemma preserves_assoc:
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 \<a>\<^sub>D[F f, F g, F 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 \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, 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 \<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 simp
moreover have "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])"
- using assms \<Phi>_components_are_iso C.VV.arr_char FF_def D.hseqI' by auto
+ using assms C.VV.arr_char FF_def by auto
moreover have 1: "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
- using assms \<Phi>_components_are_iso C.VV.arr_char FF_def D.hseqI' by auto
+ using assms C.VV.arr_char FF_def by auto
moreover 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))"
- using assms 1 \<Phi>_components_are_iso C.VV.arr_char FF_def D.inv_comp D.hseqI'
- by simp
+ using assms 1 C.VV.arr_char FF_def D.inv_comp by simp
ultimately 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 \<a>\<^sub>D[F f, F g, F 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 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)"]
D.comp_assoc
by simp
hence "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
D.inv (\<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, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
using assms preserves_inv 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 \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, 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 "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>C h) : F f \<star>\<^sub>D F (g \<star>\<^sub>C h) \<Rightarrow>\<^sub>D F (f \<star>\<^sub>C g \<star>\<^sub>C h)\<guillemotright> \<and> D.iso (\<Phi> (f, g \<star>\<^sub>C h))"
- using assms \<Phi>_components_are_iso by auto
+ using assms by auto
moreover have "\<guillemotleft>F f \<star>\<^sub>D \<Phi> (g, h) : F f \<star>\<^sub>D F g \<star>\<^sub>D F h \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F (g \<star>\<^sub>C h)\<guillemotright> \<and>
D.iso (F f \<star>\<^sub>D \<Phi> (g, h))"
- using assms \<Phi>_components_are_iso
+ using assms
by (intro conjI D.hcomp_in_vhom, auto)
moreover have "\<guillemotleft>\<a>\<^sub>D[F f, F g, F h] : (F f \<star>\<^sub>D F g) \<star>\<^sub>D F h \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g \<star>\<^sub>D F h\<guillemotright> \<and>
D.iso \<a>\<^sub>D[F f, F g, F h]"
using assms by auto
moreover have
"\<guillemotleft>D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h : F (f \<star>\<^sub>C g) \<star>\<^sub>D F h \<Rightarrow>\<^sub>D (F f \<star>\<^sub>D F g) \<star>\<^sub>D F h\<guillemotright> \<and>
D.iso (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h)"
- using assms \<Phi>_components_are_iso D.iso_inv_iso
- by (intro conjI D.hcomp_in_vhom, auto)
+ using assms D.iso_inv_iso by auto
moreover have
"\<guillemotleft>D.inv (\<Phi> (f \<star>\<^sub>C g, h)) : F ((f \<star>\<^sub>C g) \<star>\<^sub>C h) \<Rightarrow>\<^sub>D F (f \<star>\<^sub>C g) \<star>\<^sub>D F h\<guillemotright> \<and>
D.iso (D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
- using assms \<Phi>_components_are_iso D.iso_inv_iso by auto
+ using assms D.iso_inv_iso by auto
ultimately show ?thesis
- using assms \<Phi>_components_are_iso D.isos_compose D.inv_comp
- D.comp_assoc D.iso_inv_iso
- apply (elim conjE D.in_homE) by (auto simp add: D.inv_comp)
+ using assms D.isos_compose D.comp_assoc D.iso_inv_iso
+ apply (elim conjE D.in_homE)
+ by (auto simp add: D.inv_comp)
qed
finally show "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, 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))"
by simp
qed
lemma preserves_hcomp:
assumes "C.hseq \<mu> \<nu>"
shows "F (\<mu> \<star>\<^sub>C \<nu>) =
\<Phi> (C.cod \<mu>, C.cod \<nu>) \<cdot>\<^sub>D (F \<mu> \<star>\<^sub>D F \<nu>) \<cdot>\<^sub>D D.inv (\<Phi> (C.dom \<mu>, C.dom \<nu>))"
proof -
have "F (\<mu> \<star>\<^sub>C \<nu>) \<cdot>\<^sub>D \<Phi> (C.dom \<mu>, C.dom \<nu>) = \<Phi> (C.cod \<mu>, C.cod \<nu>) \<cdot>\<^sub>D (F \<mu> \<star>\<^sub>D F \<nu>)"
using assms \<Phi>.naturality C.VV.arr_char C.VV.cod_char FF_def by auto
thus ?thesis
by (metis (no_types) assms C.hcomp_simps(3) C.hseqE C.ide_dom C.src_dom C.trg_dom
D.comp_arr_inv' D.comp_assoc \<Phi>_components_are_iso \<Phi>_simps(5) is_natural_1)
qed
lemma preserves_adjunction_data:
assumes "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>"
shows "adjunction_data_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_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 by auto
show "D.ide (F f)"
using preserves_ide by simp
show "D.ide (F g)"
using preserves_ide by simp
show "\<guillemotleft>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) : src\<^sub>D (F f) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
using antipar C.VV.ide_char C.VV.arr_char \<Phi>_in_hom(2) \<Psi>_in_hom FF_def by auto
show "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D src\<^sub>D (F g)\<guillemotright>"
using antipar C.VV.ide_char C.VV.arr_char FF_def \<Phi>_in_hom(2) \<Psi>_in_hom(2)
\<Psi>_char(2)
by auto
qed
lemma preserves_equivalence:
assumes "equivalence_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 "equivalence_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 equivalence_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 "equivalence_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.iso (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
- using antipar \<Psi>_in_hom \<Phi>_components_are_iso D.iso_inv_iso FF_def unit_is_iso
+ using antipar D.iso_inv_iso FF_def unit_is_iso
preserves_iso \<Psi>_char(2) D.isos_compose
by simp
show "D.iso (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
- using antipar \<Psi>_in_hom(2) \<Psi>_char(2) C.VV.ide_char C.VV.arr_char FF_def
- \<Phi>_in_hom(2) D.iso_inv_iso counit_is_iso preserves_iso \<Phi>_components_are_iso
- D.isos_compose
+ using antipar \<Psi>_char(2) C.VV.ide_char C.VV.arr_char FF_def
+ D.iso_inv_iso D.isos_compose
by auto
qed
qed
lemma preserves_equivalence_maps:
assumes "C.equivalence_map f"
shows "D.equivalence_map (F f)"
proof -
obtain g \<eta> \<epsilon> where E: "equivalence_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 C.equivalence_map_def by auto
interpret E: equivalence_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 E by auto
have E': "equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^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 E preserves_equivalence by auto
moreover have "src\<^sub>D (F f) = map\<^sub>0 (src\<^sub>C f) \<and> trg\<^sub>D (F f) = map\<^sub>0 (trg\<^sub>C f)"
using assms C.equivalence_map_def map\<^sub>0_simps by simp
ultimately show ?thesis
using D.equivalence_map_def by auto
qed
lemma preserves_equivalent_objects:
assumes "C.equivalent_objects a b"
shows "D.equivalent_objects (map\<^sub>0 a) (map\<^sub>0 b)"
proof -
obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.equivalence_map f"
using assms C.equivalent_objects_def by auto
have "\<guillemotleft>F f : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright> \<and> D.equivalence_map (F f)"
using f preserves_equivalence_maps by auto
thus ?thesis
using D.equivalent_objects_def by auto
qed
end
subsection "Equivalence Pseudofunctors"
text \<open>
In this section, we define ``equivalence pseudofunctors'', which are pseudofunctors
that can be extended to an equivalence of bicategories. My purpose at the moment
is just to have some way to establish that bicategories are equivalent and not to
go so far as to give a full and proper development of equivalence of bicategories
(which would involve the further definition of pseudonatural transformations and so on),
nor even to prove that the pseudofunctors in an equivalence of bicategories are in fact
``equivalence pseudofunctors'' according to the definition given here.
So in some sense the results we ultimately prove depend on one's having taken for
granted that the definition given here is ``correct''. This is not entirely vacuous,
because the definition does have some subtleties and it took me awhile to work the bugs
out of the formalization. However, enough is proved using the definition that I think
it is not difficult to accept it as correct. Future work can go back and give a fuller
development to provide even more confidence.
\sloppypar
It is asserted on the ``nLab'' \cite{nlab-equivalence-of-2-categories}
that a pseudofunctor is part of an equivalence of bicategories if and only if it is
essentially surjective on objects, essentially full on 1-cells (here: ``identities'')
and fully faithful on 2-cells (here: ``arrows'').
To turn this into a formal definition, it is necessary to find the proper way to express
formally the notions involved. ``Essentially surjective on objects'' is perhaps the
most complex of these, as it involves internal equivalences between objects.
The definition below requires that an equivalence pseudofunctor be (globally) faithful
with respect to vertical composition. Traditional formulations do not consider a
pseudofunctor as a single global functor, so we have to consider whether this condition
is too strong. In fact, a pseudofunctor (as defined here) is locally faithful if and
only if it is globally faithful.
\<close>
context pseudofunctor
begin
definition locally_faithful
where "locally_faithful \<equiv>
\<forall>f g \<mu> \<mu>'. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> F \<mu> = F \<mu>' \<longrightarrow> \<mu> = \<mu>'"
lemma locally_faithful_iff_faithful:
shows "locally_faithful \<longleftrightarrow> faithful_functor V\<^sub>C V\<^sub>D F"
proof
show "faithful_functor V\<^sub>C V\<^sub>D F \<Longrightarrow> locally_faithful"
proof -
assume 1: "faithful_functor V\<^sub>C V\<^sub>D F"
interpret faithful_functor V\<^sub>C V\<^sub>D F
using 1 by blast
show "locally_faithful"
unfolding locally_faithful_def using is_faithful by blast
qed
show "locally_faithful \<Longrightarrow> faithful_functor V\<^sub>C V\<^sub>D F"
proof -
assume 1: "locally_faithful"
show "faithful_functor V\<^sub>C V\<^sub>D F"
proof
fix \<mu> \<mu>'
assume par: "C.par \<mu> \<mu>'" and eq: "F \<mu> = F \<mu>'"
obtain f g where fg: "\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>C g\<guillemotright>"
using par by auto
show "\<mu> = \<mu>'"
using 1 fg locally_faithful_def eq by simp
qed
qed
qed
end
text \<open>
In contrast, it is not true that a pseudofunctor that is locally full is also
globally full, because we can have \<open>\<guillemotleft>\<nu> : F h \<Rightarrow>\<^sub>D F k\<guillemotright>\<close> even if \<open>h\<close> and \<open>k\<close>
are not in the same hom-category. So it would be a mistake to require that an
equivalence functor be globally full.
\<close>
locale equivalence_pseudofunctor =
pseudofunctor +
faithful_functor V\<^sub>C V\<^sub>D F +
assumes surjective_on_objects_up_to_equivalence:
"D.obj a' \<Longrightarrow> \<exists>a. C.obj a \<and> D.equivalent_objects (map\<^sub>0 a) a'"
and locally_essentially_surjective:
"\<lbrakk> C.obj a; C.obj b; \<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright>; D.ide g \<rbrakk> \<Longrightarrow>
\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) g"
and locally_full:
"\<lbrakk> C.ide f; C.ide f'; src\<^sub>C f = src\<^sub>C f'; trg\<^sub>C f = trg\<^sub>C f'; \<guillemotleft>\<nu> : F f \<Rightarrow>\<^sub>D F f'\<guillemotright> \<rbrakk> \<Longrightarrow>
\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C f'\<guillemotright> \<and> F \<mu> = \<nu>"
begin
lemma reflects_ide:
assumes "C.endo \<mu>" and "D.ide (F \<mu>)"
shows "C.ide \<mu>"
using assms is_faithful [of "C.dom \<mu>" \<mu>] C.ide_char'
by (metis C.arr_dom C.cod_dom C.dom_dom C.seqE D.ide_char preserves_dom)
lemma reflects_iso:
assumes "C.arr \<mu>" and "D.iso (F \<mu>)"
shows "C.iso \<mu>"
proof -
obtain \<mu>' where \<mu>': "\<guillemotleft>\<mu>' : C.cod \<mu> \<Rightarrow>\<^sub>C C.dom \<mu>\<guillemotright> \<and> F \<mu>' = D.inv (F \<mu>)"
using assms locally_full [of "C.cod \<mu>" "C.dom \<mu>" "D.inv (F \<mu>)"]
D.inv_in_hom C.in_homE preserves_hom C.in_homI
by auto
have "C.inverse_arrows \<mu> \<mu>'"
proof
have "D.ide (F (\<mu>' \<cdot>\<^sub>C \<mu>))"
using assms \<mu>'
by (metis (no_types, lifting) C.dom_comp C.in_homE C.seqI D.comp_inv_arr'
D.ide_char' preserves_arr preserves_comp preserves_dom)
moreover have "C.endo (\<mu>' \<cdot>\<^sub>C \<mu>)"
using assms \<mu>' by auto
ultimately show "C.ide (\<mu>' \<cdot>\<^sub>C \<mu>)"
using assms \<mu>' reflects_ide by blast
have "D.ide (F (\<mu> \<cdot>\<^sub>C \<mu>'))"
using assms \<mu>'
by (metis C.ide_compE D.comp_arr_inv' D.dom_cod D.ide_char' \<open>C.ide (\<mu>' \<cdot>\<^sub>C \<mu>)\<close>
preserves_arr preserves_comp_2)
moreover have "C.endo (\<mu> \<cdot>\<^sub>C \<mu>')"
using assms \<mu>' by auto
ultimately show "C.ide (\<mu> \<cdot>\<^sub>C \<mu>')"
using assms reflects_ide by blast
qed
thus ?thesis by auto
qed
lemma reflects_equivalence:
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 "equivalence_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 "equivalence_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 -
interpret E': equivalence_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 assms by auto
show ?thesis
proof
show "C.ide f"
using assms(1) by simp
show "C.ide g"
using assms(2) by simp
show "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>"
using assms(3) by simp
show "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
using assms(4) by simp
have 0: "src\<^sub>C f = trg\<^sub>C g \<and> src\<^sub>C g = trg\<^sub>C f"
using `\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>`
by (metis C.hseqE C.ideD(1) C.ide_cod C.ide_dom C.in_homE assms(4))
show "C.iso \<eta>"
proof -
have "D.iso (F \<eta>)"
proof -
have 1: "\<guillemotleft>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) : map\<^sub>0 (src\<^sub>C f) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
using `C.ide f` `C.ide g` `\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>`
\<Psi>_char \<Phi>_in_hom \<Phi>_components_are_iso
by (metis (mono_tags, lifting) C.ideD(1) E'.unit_in_vhom preserves_src)
have 2: "D.iso (\<Phi> (g, f)) \<and> \<guillemotleft>\<Phi> (g, f) : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
- using 0 `C.ide f` `C.ide g` \<Phi>_in_hom \<Phi>_components_are_iso
- by simp
+ using 0 `C.ide f` `C.ide g` \<Phi>_in_hom by simp
have 3: "D.iso (D.inv (\<Psi> (src\<^sub>C f))) \<and>
\<guillemotleft>D.inv (\<Psi> (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright>"
using `C.ide f` \<Psi>_char D.iso_inv_iso by simp
have "D.iso (\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D
D.inv (\<Psi> (src\<^sub>C f)))"
using 1 2 3 E'.unit_is_iso D.isos_compose by blast
moreover have "\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D
D.inv (\<Psi> (src\<^sub>C f)) =
F \<eta>"
proof -
have "\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) =
(\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D (\<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)))"
using D.comp_assoc by simp
also have "... = F (g \<star>\<^sub>C f) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D F (src\<^sub>C f)"
using 2 3 D.comp_arr_inv D.comp_inv_arr D.inv_is_inverse
by (metis C.ideD(1) C.obj_src D.comp_assoc D.dom_inv D.in_homE \<Psi>_char(2)
assms(1))
also have "... = F \<eta>"
using `\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>` D.comp_arr_dom D.comp_cod_arr by auto
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
thus ?thesis
using assms reflects_iso by auto
qed
show "C.iso \<epsilon>"
proof -
have "D.iso (F \<epsilon>)"
proof -
have 1: "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C g)\<guillemotright>"
using `C.ide f` `C.ide g` `\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>`
\<Psi>_char \<Phi>_in_hom \<Phi>_components_are_iso
by (metis (mono_tags, lifting) C.ideD(1) E'.counit_in_vhom preserves_src)
have 2: "D.iso (D.inv (\<Phi> (f, g))) \<and>
\<guillemotleft>D.inv (\<Phi> (f, g)) : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g\<guillemotright>"
using 0 `C.ide f` `C.ide g` `\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>` \<Phi>_in_hom(2)
- \<Phi>_components_are_iso D.inv_in_hom D.iso_inv_iso
+ D.inv_in_hom D.iso_inv_iso
by simp
have 3: "D.iso (\<Psi> (trg\<^sub>C f)) \<and> \<guillemotleft>\<Psi> (trg\<^sub>C f) : map\<^sub>0 (trg\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
using `C.ide f` \<Psi>_char by simp
have
"D.iso (\<Psi> (trg\<^sub>C f) \<cdot>\<^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> (f, g)))"
using 0 1 2 3 E'.counit_is_iso D.isos_compose
by (metis D.arrI D.cod_comp D.cod_inv D.seqI D.seqI')
moreover have "\<Psi> (trg\<^sub>C f) \<cdot>\<^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> (f, g)) =
F \<epsilon>"
proof -
have "\<Psi> (trg\<^sub>C f) \<cdot>\<^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> (f, g)) =
(\<Psi> (trg\<^sub>C f) \<cdot>\<^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> (f, g)))"
using D.comp_assoc by simp
also have "... = F (trg\<^sub>C f) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D F (f \<star>\<^sub>C g)"
using 0 2 3 D.comp_arr_inv D.comp_inv_arr D.inv_is_inverse D.iso_inv_iso
by (simp add: C.VV.arr_char C.VV.ide_char assms(1) assms(2))
also have "... = F \<epsilon>"
using 0 `\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>` D.comp_arr_dom D.comp_cod_arr by auto
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
thus ?thesis
using assms reflects_iso by auto
qed
qed
qed
lemma reflects_equivalence_map:
assumes "C.ide f" and "D.equivalence_map (F f)"
shows "C.equivalence_map f"
proof -
obtain g' \<phi> \<psi> where E': "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) g' \<phi> \<psi>"
using assms D.equivalence_map_def by auto
interpret E': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> g' \<phi> \<psi>
using E' 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 E'.antipar locally_essentially_surjective [of "trg\<^sub>C f" "src\<^sub>C f" g']
by auto
obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : g' \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<mu>"
using g D.isomorphic_def D.isomorphic_symmetric by blast
have E'': "equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
((F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>)
(\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>))"
using assms \<mu> E'.equivalence_in_bicategory_axioms D.ide_is_iso
D.equivalence_respects_iso [of "F f" g' \<phi> \<psi> "F f" "F f" \<mu> "F g"]
by auto
interpret E'': equivalence_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>(F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>\<close>
\<open>\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>)\<close>
using E'' by auto
let ?\<eta>' = "\<Phi> (g, f) \<cdot>\<^sub>D (F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi> \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
have \<eta>': "\<guillemotleft>?\<eta>' : F (src\<^sub>C f) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Psi> (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D src\<^sub>D (F f)\<guillemotright>"
using assms \<Psi>_char by simp
show "\<guillemotleft>\<phi> : src\<^sub>D (F f) \<Rightarrow>\<^sub>D g' \<star>\<^sub>D F f\<guillemotright>"
using g E'.unit_in_hom(2) by simp
show "\<guillemotleft>\<mu> \<star>\<^sub>D F f : g' \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
using assms g \<mu> E'.antipar E''.antipar by blast
show "\<guillemotleft>F g \<star>\<^sub>D F f : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
using assms g E''.antipar by auto
show "\<guillemotleft>\<Phi> (g, f) : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
using assms g \<Phi>_in_hom by auto
qed
have iso_\<eta>': "D.iso ?\<eta>'"
proof -
have "D.iso (\<Phi> (g, f))"
- using assms g \<Phi>_components_are_iso by auto
+ using assms g by auto
thus ?thesis
using assms g \<mu> E'.antipar E''.antipar \<Phi>_in_hom \<Psi>_char
E'.unit_in_hom D.iso_inv_iso E'.unit_is_iso \<eta>'
- apply (intro D.isos_compose)
- apply simp_all
- apply (meson D.iso_hcomp D.hseqE D.seqE E''.unit_simps(1) components_are_iso)
- apply (meson D.arrI D.seqE)
- apply (meson D.arrI D.seqE)
- by (meson D.arrI D.seqE)
+ apply (intro D.isos_compose) by auto
qed
let ?\<epsilon>' = "\<Psi> (src\<^sub>C g) \<cdot>\<^sub>D \<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>) \<cdot>\<^sub>D D.inv (\<Phi> (f, g))"
have \<epsilon>': "\<guillemotleft>?\<epsilon>' : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Phi> (f, g)) : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g\<guillemotright>"
using assms g \<Phi>_in_hom C.VV.ide_char C.VV.arr_char by auto
show "\<guillemotleft>F f \<star>\<^sub>D D.inv \<mu> : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F f \<star>\<^sub>D g'\<guillemotright>"
using assms g \<mu> E'.antipar E''.antipar D.ide_in_hom(2) by auto
show "\<guillemotleft>D.inv (F f) \<star>\<^sub>D g' : F f \<star>\<^sub>D g' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D g'\<guillemotright>"
using assms E'.antipar E''.antipar D.ide_is_iso
by (simp add: D.ide_in_hom(2))
show "\<guillemotleft>\<psi> : F f \<star>\<^sub>D g' \<Rightarrow>\<^sub>D trg\<^sub>D (F f)\<guillemotright>"
using E'.counit_in_hom by simp
show "\<guillemotleft>\<Psi> (src\<^sub>C g) : trg\<^sub>D (F f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
using assms g \<Psi>_char E'.antipar by auto
qed
have iso_\<epsilon>': "D.iso ?\<epsilon>'"
proof -
have "D.iso (\<Phi> (f, g))"
using assms g C.VV.ide_char C.VV.arr_char by auto
thus ?thesis
using assms g \<mu> E'.antipar E''.antipar \<Phi>_in_hom \<Psi>_char
E'.counit_in_hom D.iso_inv_iso E'.counit_is_iso \<epsilon>'
by (metis C.ideD(1) C.obj_src D.arrI D.iso_hcomp D.hseq_char D.ide_is_iso
D.isos_compose D.seqE E'.ide_right components_are_iso)
qed
obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright> \<and> F \<eta> = ?\<eta>'"
using assms g E'.antipar \<eta>' locally_full [of "src\<^sub>C f" "g \<star>\<^sub>C f" ?\<eta>']
by (metis C.ide_hcomp C.ideD(1) C.in_hhomE C.src.preserves_ide C.hcomp_simps(1-2)
C.src_trg C.trg_trg)
have iso_\<eta>: "C.iso \<eta>"
using \<eta> \<eta>' iso_\<eta>' reflects_iso by auto
have 1: "\<exists>\<epsilon>. \<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> F \<epsilon> = ?\<epsilon>'"
proof -
have "C.ide (f \<star>\<^sub>C g)"
using assms g by auto
moreover have "C.ide (src\<^sub>C g)"
using assms g by simp
moreover have "src\<^sub>C (f \<star>\<^sub>C g) = src\<^sub>C (src\<^sub>C g)"
using assms g by auto
moreover have "trg\<^sub>C (f \<star>\<^sub>C g) = trg\<^sub>C (src\<^sub>C g)"
using assms g by auto
ultimately show ?thesis
using locally_full [of "f \<star>\<^sub>C g" "src\<^sub>C g" ?\<epsilon>']
by (metis C.in_hhomE \<epsilon>' g)
qed
obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> F \<epsilon> = ?\<epsilon>'"
using 1 by blast
have iso_\<epsilon>: "C.iso \<epsilon>"
using \<epsilon> \<epsilon>' iso_\<epsilon>' reflects_iso by auto
have "equivalence_in_bicategory (\<cdot>\<^sub>C) (\<star>\<^sub>C) \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
using assms g \<eta> \<epsilon> iso_\<eta> iso_\<epsilon> by (unfold_locales, auto)
thus ?thesis
using C.equivalence_map_def by auto
qed
lemma reflects_equivalent_objects:
assumes "C.obj a" and "C.obj b" and "D.equivalent_objects (map\<^sub>0 a) (map\<^sub>0 b)"
shows "C.equivalent_objects a b"
proof -
obtain f' where f': "\<guillemotleft>f' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright> \<and> D.equivalence_map f'"
using assms D.equivalent_objects_def D.equivalence_map_def by auto
obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) f'"
using assms f' locally_essentially_surjective [of a b f'] D.equivalence_map_is_ide
by auto
have "D.equivalence_map (F f)"
using f f' D.equivalence_map_preserved_by_iso [of f' "F f"] D.isomorphic_symmetric
by simp
hence "C.equivalence_map f"
using f f' reflects_equivalence_map [of f] by simp
thus ?thesis
using f C.equivalent_objects_def by auto
qed
end
text \<open>
As previously stated, I have been trying to avoid, as part of the current project,
a full development of pseudonatural transformations and equivalences of bicategories.
I have chosen instead to define the notion of an equivalence pseudofunctor and to
define two bicategories to be equivalent if there exists an equivalence pseudofunctor
between them. However I cannot avoid needing to show that the relation of ``equivalence''
so defined is at least a symmetric relation. To do that requires showing how
to construct, given an equivalence pseudofunctor, an equivalence pseudofunctor going
in the opposite direction. That is the purpose of the next section. A fuller development
would define the notion ``equivalence of bicategories'' in terms of pseudofunctors and
pseudonatural equivalences and would show that a pseudofunctor is an equivalence
pseudofunctor if and only if it extends to an equivalence of bicategories.
I am leaving such a development for future work.
\<close>
locale converse_equivalence_pseudofunctor =
C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
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>\<^sub>F
for V\<^sub>C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
and H\<^sub>C :: "'c comp" (infixr "\<star>\<^sub>C" 53)
and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c" ("\<a>\<^sub>C[_, _, _]")
and \<i>\<^sub>C :: "'c \<Rightarrow> 'c" ("\<i>\<^sub>C[_]")
and src\<^sub>C :: "'c \<Rightarrow> 'c"
and trg\<^sub>C :: "'c \<Rightarrow> 'c"
and V\<^sub>D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
and H\<^sub>D :: "'d comp" (infixr "\<star>\<^sub>D" 53)
and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" ("\<a>\<^sub>D[_, _, _]")
and \<i>\<^sub>D :: "'d \<Rightarrow> 'd" ("\<i>\<^sub>D[_]")
and src\<^sub>D :: "'d \<Rightarrow> 'd"
and trg\<^sub>D :: "'d \<Rightarrow> 'd"
and F :: "'c \<Rightarrow> 'd"
and \<Phi>\<^sub>F :: "'c * 'c \<Rightarrow> 'd"
begin
notation C.isomorphic (infix "\<cong>\<^sub>C" 50)
notation D.isomorphic (infix "\<cong>\<^sub>D" 50)
(*
* TODO: export a neutral name for the defined pseudofunctor, such as "map" or "this".
*)
text \<open>
Specification of the object map of the converse pseudofunctor uses surjectivity
on objects up to equivalence, and will in general involve a choice.
\<close>
definition G\<^sub>0
where "G\<^sub>0 a' \<equiv> SOME a. C.obj a \<and> D.equivalent_objects a' (F.map\<^sub>0 a)"
lemma G\<^sub>0_preserves_obj:
assumes "D.obj a'"
shows "C.obj (G\<^sub>0 a')"
and "D.equivalent_objects a' (F.map\<^sub>0 (G\<^sub>0 a'))"
using assms G\<^sub>0_def F.surjective_on_objects_up_to_equivalence [of a']
someI_ex [of "\<lambda>a. C.obj a \<and> D.equivalent_objects a' (F.map\<^sub>0 a)"]
D.equivalent_objects_symmetric
by auto
text \<open>
We obtain, for each object \<open>a'\<close> of \<open>D\<close>, the data for an equivalence between
\<open>F.map\<^sub>0 (G\<^sub>0 a')\<close> and \<open>a'\<close>.
\<close>
definition e
where "e a' \<equiv> SOME e. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and> D.equivalence_map e"
definition d
where "d a' \<equiv>
SOME d. \<exists>\<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') d \<eta> \<epsilon>"
definition \<eta>
where "\<eta> a' \<equiv>
SOME \<eta>. \<exists>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') \<eta> \<epsilon>"
definition \<epsilon>
where "\<epsilon> a' \<equiv>
SOME \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') \<epsilon>"
lemma G\<^sub>0_props:
assumes "D.obj a'"
shows "\<guillemotleft>e a' : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright>"
and "\<guillemotleft>d a' : F.map\<^sub>0 (G\<^sub>0 a') \<rightarrow>\<^sub>D a'\<guillemotright>"
and "D.ide (e a')" and "D.ide (d a')"
and "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') (\<epsilon> a')"
proof -
have "C.obj (G\<^sub>0 a') \<and> D.equivalent_objects a' (F.map\<^sub>0 (G\<^sub>0 a'))"
using assms G\<^sub>0_preserves_obj by simp
hence 1: "\<exists>e d \<eta> \<epsilon>. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and>
equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e d \<eta> \<epsilon>"
using D.equivalent_objects_def D.equivalence_map_def by auto
show ea': "\<guillemotleft>e a' : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright>"
using 1 e_def D.equivalence_map_def
someI_ex [of "\<lambda>e. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and> D.equivalence_map e"]
by simp
have 2: "\<exists>d \<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') d \<eta> \<epsilon>"
using 1 e_def D.equivalence_map_def
someI_ex [of "\<lambda>e. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and> D.equivalence_map e"]
by simp
hence "\<exists>\<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') \<eta> \<epsilon>"
using d_def
someI_ex
[of "\<lambda>d. \<exists>\<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') d \<eta> \<epsilon>"]
by simp
hence "\<exists>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') \<epsilon>"
using \<eta>_def
someI_ex
[of "\<lambda>\<eta>. \<exists>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') \<eta> \<epsilon>"]
by simp
thus 3: "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') (\<epsilon> a')"
using \<epsilon>_def
someI_ex
[of "\<lambda>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') \<epsilon>"]
by simp
interpret e: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>e a'\<close> \<open>d a'\<close> \<open>\<eta> a'\<close> \<open>\<epsilon> a'\<close>
using 3 by simp
show "\<guillemotleft>d a' : F.map\<^sub>0 (G\<^sub>0 a') \<rightarrow>\<^sub>D a'\<guillemotright>"
using ea' e.antipar(1) e.antipar(2) by auto
show "D.ide (e a')"
by simp
show "D.ide (d a')"
by simp
qed
lemma e_in_hom [intro]:
assumes "D.obj a'"
shows "\<guillemotleft>e a' : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright>"
using assms G\<^sub>0_props by auto
lemma e_simps [simp]:
assumes "D.obj a'"
shows "D.ide (e a')"
and "src\<^sub>D (e a') = a'" and "trg\<^sub>D (e a') = F.map\<^sub>0 (G\<^sub>0 a')"
and "D.dom (e a') = e a'" and "D.cod (e a') = e a'"
using assms G\<^sub>0_props by auto
lemma d_in_hom [intro]:
assumes "D.obj a'"
shows "\<guillemotleft>d a' : F.map\<^sub>0 (G\<^sub>0 a') \<rightarrow>\<^sub>D a'\<guillemotright>"
using assms G\<^sub>0_props by auto
lemma d_simps [simp]:
assumes "D.obj a'"
shows "D.ide (d a')"
and "src\<^sub>D (d a') = F.map\<^sub>0 (G\<^sub>0 a')" and "trg\<^sub>D (d a') = a'"
and "D.dom (d a') = d a'" and "D.cod (d a') = d a'"
using assms G\<^sub>0_props by auto
text \<open>
Next, we specify how the converse pseudofunctor behaves on identities (1-cells).
This uses local essential surjectivity and also involves a choice.
\<close>
definition G\<^sub>1
where "G\<^sub>1 f' \<equiv> SOME f. C.ide f \<and> \<guillemotleft>f : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
F f \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
lemma G\<^sub>1_props:
assumes "D.ide f'"
shows "C.ide (G\<^sub>1 f')"
and "\<guillemotleft>G\<^sub>1 f' : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright>"
and "F (G\<^sub>1 f') \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
proof -
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>e (src\<^sub>D f')\<close> \<open>d (src\<^sub>D f')\<close> \<open>\<eta> (src\<^sub>D f')\<close> \<open>\<epsilon> (src\<^sub>D f')\<close>
using assms G\<^sub>0_props 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>e (trg\<^sub>D f')\<close> \<open>d (trg\<^sub>D f')\<close> \<open>\<eta> (trg\<^sub>D f')\<close> \<open>\<epsilon> (trg\<^sub>D f')\<close>
using assms G\<^sub>0_props by simp
have "\<exists>f. C.ide f \<and> \<guillemotleft>f : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
F f \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
using assms G\<^sub>0_props
F.locally_essentially_surjective
[of "G\<^sub>0 (src\<^sub>D f')" "G\<^sub>0 (trg\<^sub>D f')" "e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"]
G\<^sub>0_preserves_obj D.equivalent_objects_def
by auto
hence 1: "C.ide (G\<^sub>1 f') \<and> \<guillemotleft>G\<^sub>1 f' : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
F (G\<^sub>1 f') \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
using G\<^sub>1_def someI_ex [of "\<lambda>f. C.ide f \<and> \<guillemotleft>f : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
F f \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"]
by simp
show "C.ide (G\<^sub>1 f')"
using 1 by simp
show "\<guillemotleft>G\<^sub>1 f' : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright>"
using 1 by simp
show "F (G\<^sub>1 f') \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
using 1 by simp
qed
text \<open>
We need to choose a specific isomorphism between \<open>F (G\<^sub>1 f')\<close> and
\<open>e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<close>.
\<close>
definition \<phi>
where "\<phi> f' \<equiv> SOME \<phi>. \<guillemotleft>\<phi> : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso \<phi>"
lemma \<phi>_props:
assumes "D.ide f'"
shows "\<guillemotleft>\<phi> f' : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
and "D.iso (\<phi> f')"
proof -
have "\<exists>\<phi>. \<guillemotleft>\<phi> : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso \<phi>"
using assms G\<^sub>1_props by blast
hence 1: "\<guillemotleft>\<phi> f' : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso (\<phi> f')"
using \<phi>_def
someI_ex [of "\<lambda>\<phi>. \<guillemotleft>\<phi> : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso \<phi>"]
by simp
show "\<guillemotleft>\<phi> f' : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
using 1 by simp
show "D.iso (\<phi> f')"
using 1 by simp
qed
text \<open>
The behavior of the converse pseudofunctor on arrows (2-cells) is now determined
by local fullness. We have used indefinite choice in the definition here,
but in fact the choice is unique due to faithfulness.
\<close>
definition G
where "G \<mu>' \<equiv> if D.arr \<mu>' then
SOME \<mu>. \<guillemotleft>\<mu> : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
F \<mu> = D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')
else
C.null"
lemma G_props:
assumes "D.arr \<mu>'"
shows "\<guillemotleft>G \<mu>' : G\<^sub>0 (src\<^sub>D \<mu>') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D \<mu>')\<guillemotright>"
and "\<guillemotleft>G \<mu>' : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright>"
and "F (G \<mu>') =
D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
proof -
have "C.ide (G\<^sub>1 (D.dom \<mu>'))"
using assms G\<^sub>1_props by simp
moreover have "C.ide (G\<^sub>1 (D.cod \<mu>'))"
using assms G\<^sub>1_props by simp
moreover have "src\<^sub>C (G\<^sub>1 (D.dom \<mu>')) = src\<^sub>C (G\<^sub>1 (D.cod \<mu>'))"
using assms G\<^sub>1_props
by (metis C.in_hhomE D.ide_cod D.ide_dom D.src_cod D.src_dom)
moreover have "trg\<^sub>C (G\<^sub>1 (D.dom \<mu>')) = trg\<^sub>C (G\<^sub>1 (D.cod \<mu>'))"
using assms G\<^sub>1_props
by (metis C.in_hhomE D.ide_cod D.ide_dom D.trg_cod D.trg_dom)
moreover have
"\<guillemotleft>D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>') :
F (G\<^sub>1 (D.dom \<mu>')) \<Rightarrow>\<^sub>D F (G\<^sub>1 (D.cod \<mu>'))\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>\<phi> (D.dom \<mu>') :
F (G\<^sub>1 (D.dom \<mu>')) \<Rightarrow>\<^sub>D
e (trg\<^sub>D (D.dom \<mu>')) \<star>\<^sub>D D.dom \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.dom \<mu>'))\<guillemotright>"
using assms \<phi>_props [of "D.dom \<mu>'"] by simp
show "\<guillemotleft>e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>') :
e (trg\<^sub>D (D.dom \<mu>')) \<star>\<^sub>D D.dom \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.dom \<mu>')) \<Rightarrow>\<^sub>D
e (trg\<^sub>D (D.cod \<mu>')) \<star>\<^sub>D D.cod \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.cod \<mu>'))\<guillemotright>"
using assms G\<^sub>0_props
by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>D.inv (\<phi> (D.cod \<mu>')) :
e (trg\<^sub>D (D.cod \<mu>')) \<star>\<^sub>D D.cod \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.cod \<mu>')) \<Rightarrow>\<^sub>D F (G\<^sub>1 (D.cod \<mu>'))\<guillemotright>"
using assms \<phi>_props D.ide_cod D.inv_in_hom by presburger
qed
ultimately have
"\<exists>\<mu>. \<guillemotleft>\<mu> : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
F \<mu> = D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
by (simp add: F.locally_full)
hence 1: "\<guillemotleft>G \<mu>' : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
F (G \<mu>') =
D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
using assms G_def
someI_ex [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
F \<mu> = D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"]
by simp
show "\<guillemotleft>G \<mu>' : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright>"
using 1 by simp
thus "\<guillemotleft>G \<mu>' : G\<^sub>0 (src\<^sub>D \<mu>') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D \<mu>')\<guillemotright>"
using assms G\<^sub>1_props
by (metis C.arrI C.ide_in_hom(2) C.in_hhom_def C.seqI' C.vseq_implies_hpar(1)
C.vseq_implies_hpar(2) D.ide_dom D.src_dom D.trg_dom)
show "F (G \<mu>') =
D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
using 1 by simp
qed
lemma G_ide:
assumes "D.ide f'"
shows "G f' = G\<^sub>1 f'"
proof -
have "F (G f') =
D.inv (\<phi> (D.cod f')) \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')) \<cdot>\<^sub>D \<phi> (D.dom f')"
using assms G_props by simp
also have "... = D.inv (\<phi> f') \<cdot>\<^sub>D \<phi> f'"
using assms \<phi>_props [of f'] D.comp_cod_arr by auto
also have "... = F (G\<^sub>1 f')"
using assms \<phi>_props D.comp_inv_arr' by auto
finally have "F (G f') = F (G\<^sub>1 f')" by simp
thus ?thesis
using assms G_props G\<^sub>1_props F.is_faithful
by (metis C.ideD(3) C.in_homE D.ideD(1-3) F.locally_reflects_ide F.preserves_ide)
qed
lemma \<phi>_in_hom [intro]:
assumes "D.ide f'"
shows "\<guillemotleft>\<phi> f' : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f')) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f'))\<guillemotright>"
and "\<guillemotleft>\<phi> f' : F (G f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
proof -
show "\<guillemotleft>\<phi> f' : F (G f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
using assms \<phi>_props G_ide by auto
thus "\<guillemotleft>\<phi> f' : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f')) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f'))\<guillemotright>"
- using assms \<phi>_props D.hseqI' d_simps e_simps D.src_cod D.trg_cod
- apply (intro D.in_hhomI)
- apply auto[1]
- apply (metis D.arr_cod D.hseqI' D.ideD(1) D.in_homE D.obj_src D.hcomp_simps(1))
- by (metis D.arr_cod D.ideD(1) D.in_homE D.obj_trg D.hcomp_simps(2))
+ using assms \<phi>_props d_simps e_simps
+ D.src_cod [of "\<phi> f'"] D.trg_cod [of "\<phi> f'"]
+ by fastforce
qed
lemma \<phi>_simps [simp]:
assumes "D.ide f'"
shows "D.arr (\<phi> f')"
and "src\<^sub>D (\<phi> f') = F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f'))" and "trg\<^sub>D (\<phi> f') = F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f'))"
and "D.dom (\<phi> f') = F (G f')" and "D.cod (\<phi> f') = e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
using assms \<phi>_in_hom by auto
interpretation "functor" V\<^sub>D V\<^sub>C G
proof
show "\<And>\<mu>'. \<not> D.arr \<mu>' \<Longrightarrow> G \<mu>' = C.null"
using G_def by simp
- show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')"
+ show A: "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')"
using G_props by auto
- show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')"
+ show D: "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')"
proof -
fix \<mu>'
assume \<mu>': "D.arr \<mu>'"
have "C.dom (G \<mu>') = G\<^sub>1 (D.dom \<mu>')"
using \<mu>' G_props by auto
also have "... = G (D.dom \<mu>')"
proof -
have "F (G (D.dom \<mu>')) = F (G\<^sub>1 (D.dom \<mu>'))"
using \<mu>' G_props [of "D.dom \<mu>'"] \<phi>_props [of "D.dom \<mu>'"] D.comp_cod_arr
D.comp_inv_arr'
by auto
moreover have "C.par (G\<^sub>1 (D.dom \<mu>')) (G (D.dom \<mu>'))"
using \<mu>' G\<^sub>1_props G_props [of "D.dom \<mu>'"] by auto
ultimately show ?thesis
using F.is_faithful [of "G\<^sub>1 (D.dom \<mu>')" "G (D.dom \<mu>')"] by auto
qed
finally show "C.dom (G \<mu>') = G (D.dom \<mu>')" by simp
qed
- show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')"
+ show C: "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')"
proof -
fix \<mu>'
assume \<mu>': "D.arr \<mu>'"
have "C.cod (G \<mu>') = G\<^sub>1 (D.cod \<mu>')"
using \<mu>' G_props [of \<mu>'] by auto
also have "... = G (D.cod \<mu>')"
proof -
have "F (G (D.cod \<mu>')) = F (G\<^sub>1 (D.cod \<mu>'))"
using \<mu>' G_props [of "D.cod \<mu>'"] \<phi>_props [of "D.cod \<mu>'"] D.comp_cod_arr
D.comp_inv_arr'
by auto
moreover have "C.par (G (D.cod \<mu>')) (G\<^sub>1 (D.cod \<mu>'))"
using \<mu>' G\<^sub>1_props G_props [of "D.cod \<mu>'"] by auto
ultimately show ?thesis
using F.is_faithful [of "G (D.cod \<mu>')" "G\<^sub>1 (D.cod \<mu>')"] by simp
qed
finally show "C.cod (G \<mu>') = G (D.cod \<mu>')" by simp
qed
show "\<And>\<mu> \<nu>. D.seq \<mu> \<nu> \<Longrightarrow> G (\<mu> \<cdot>\<^sub>D \<nu>) = G \<mu> \<cdot>\<^sub>C G \<nu>"
proof -
fix \<mu> \<nu>
assume \<mu>\<nu>: "D.seq \<mu> \<nu>"
have \<mu>: "\<guillemotleft>\<mu> : src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>) \<rightarrow>\<^sub>D trg\<^sub>D \<mu>\<guillemotright>"
using \<mu>\<nu> D.vseq_implies_hpar
by (intro D.in_hhomI, auto)
have \<nu>: "\<guillemotleft>\<nu> : src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>) \<rightarrow>\<^sub>D trg\<^sub>D \<nu>\<guillemotright>"
using \<mu>\<nu> D.vseq_implies_hpar
by (intro D.in_hhomI, auto)
have "F (G (\<mu> \<cdot>\<^sub>D \<nu>)) =
D.inv (\<phi> (D.cod (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D \<mu> \<cdot>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
\<phi> (D.dom (\<mu> \<cdot>\<^sub>D \<nu>))"
using \<mu>\<nu> G_props by simp
also have "... =
D.inv (\<phi> (D.cod (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D (\<mu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D (\<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)))) \<cdot>\<^sub>D
\<phi> (D.dom (\<mu> \<cdot>\<^sub>D \<nu>))"
using \<mu>\<nu> D.whisker_right D.obj_src G\<^sub>0_props(4) by metis
also have "... = D.inv (\<phi> (D.cod (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
((e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)))) \<cdot>\<^sub>D
\<phi> (D.dom (\<mu> \<cdot>\<^sub>D \<nu>))"
proof -
have "D.seq (\<mu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) (\<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)))"
- using \<mu> \<nu> \<mu>\<nu> D.obj_src G\<^sub>0_props(4)
- apply (intro D.seqI D.hseqI, auto)
- using D.hseqI' by fastforce
+ using \<mu> \<nu> \<mu>\<nu> D.obj_src G\<^sub>0_props(4) by fastforce
thus ?thesis
using \<mu>\<nu> D.obj_src D.obj_trg G\<^sub>0_props(3) D.whisker_left by metis
qed
also have "... = D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
\<phi> (D.dom \<nu>)"
using \<mu>\<nu> D.vseq_implies_hpar(1) D.vseq_implies_hpar(2) D.comp_assoc by auto
also have "... = D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D
(\<phi> (D.dom \<mu>) \<cdot>\<^sub>D D.inv (\<phi> (D.cod \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
\<phi> (D.dom \<nu>)"
proof -
have "\<phi> (D.dom \<mu>) \<cdot>\<^sub>D D.inv (\<phi> (D.cod \<nu>)) =
D.cod ((e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D \<phi> (D.dom \<nu>))"
- using \<mu> \<nu> G\<^sub>0_props(3-4) D.obj_src D.obj_trg D.hseqI' \<mu>\<nu> \<phi>_props
+ using \<mu> \<nu> G\<^sub>0_props(3-4) D.obj_src D.obj_trg \<mu>\<nu> \<phi>_props
D.comp_arr_inv' D.ide_cod
by auto
thus ?thesis
using \<mu>\<nu> \<phi>_props D.comp_cod_arr
by (metis D.seqE \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')\<close> calculation F.preserves_arr)
qed
also have "... =
(D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)) \<cdot>\<^sub>D
(D.inv (\<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D \<phi> (D.dom \<nu>))"
using D.comp_assoc by simp
also have "... = F (G \<mu>) \<cdot>\<^sub>D F (G \<nu>)"
using \<mu>\<nu> G_props by auto
also have "... = F (G \<mu> \<cdot>\<^sub>C G \<nu>)"
- using \<mu>\<nu> G_props D.seqE \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')\<close>
- \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')\<close>
- \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')\<close>
- by auto
+ using \<mu>\<nu> A D C G_props D.seqE by auto
finally have "F (G (\<mu> \<cdot>\<^sub>D \<nu>)) = F (G \<mu> \<cdot>\<^sub>C G \<nu>)"
by simp
- thus "G (\<mu> \<cdot>\<^sub>D \<nu>) = G \<mu> \<cdot>\<^sub>C G \<nu>"
- using \<mu>\<nu> G_props F.is_faithful [of "G (\<mu> \<cdot>\<^sub>D \<nu>)" "G \<mu> \<cdot>\<^sub>C G \<nu>"]
- (*
- * TODO: Here supposedly weak_arrow_of_homs_def is not used, but the proof does not
- * succeed without it.
- *)
- by (metis D.seqE \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')\<close>
- \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')\<close>
- \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')\<close>
- C.dom_comp D.dom_comp C.cod_comp D.cod_comp F.preserves_reflects_arr
- weak_arrow_of_homs_def)
+ moreover have "C.par (G (\<mu> \<cdot>\<^sub>D \<nu>)) (G \<mu> \<cdot>\<^sub>C G \<nu>)"
+ using \<mu>\<nu> A D C G_props
+ apply (intro conjI C.seqI) by auto
+ ultimately show "G (\<mu> \<cdot>\<^sub>D \<nu>) = G \<mu> \<cdot>\<^sub>C G \<nu>"
+ using F.is_faithful [of "G (\<mu> \<cdot>\<^sub>D \<nu>)" "G \<mu> \<cdot>\<^sub>C G \<nu>"] by blast
qed
qed
interpretation weak_arrow_of_homs V\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C src\<^sub>C trg\<^sub>C G
proof
fix \<mu>'
assume \<mu>': "D.arr \<mu>'"
show "G (src\<^sub>D \<mu>') \<cong>\<^sub>C src\<^sub>C (G \<mu>')"
proof -
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>e (src\<^sub>D \<mu>')\<close> \<open>d (src\<^sub>D \<mu>')\<close> \<open>\<eta> (src\<^sub>D \<mu>')\<close> \<open>\<epsilon> (src\<^sub>D \<mu>')\<close>
using \<mu>' G\<^sub>0_props by simp
have 1: "F (G (src\<^sub>D \<mu>')) \<cong>\<^sub>D F (src\<^sub>C (G \<mu>'))"
proof -
have "F (G\<^sub>1 (src\<^sub>D \<mu>')) \<cong>\<^sub>D e (src\<^sub>D \<mu>') \<star>\<^sub>D src\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')"
using \<mu>' G\<^sub>1_props [of "src\<^sub>D \<mu>'"] by simp
also have "D.isomorphic ... (F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D \<mu>')))"
proof -
have "\<guillemotleft>\<epsilon> (src\<^sub>D \<mu>') \<cdot>\<^sub>D (e (src\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (src\<^sub>D \<mu>')]) :
e (src\<^sub>D \<mu>') \<star>\<^sub>D src\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>') \<Rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D \<mu>'))\<guillemotright>"
using \<mu>' G\<^sub>0_props e_src.counit_in_hom by fastforce
moreover have "D.iso (\<epsilon> (src\<^sub>D \<mu>') \<cdot>\<^sub>D (e (src\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (src\<^sub>D \<mu>')]))"
using \<mu>' G\<^sub>0_props D.isos_compose D.arrI calculation by auto
ultimately show ?thesis
using D.isomorphic_def by blast
qed
also have "... \<cong>\<^sub>D F (src\<^sub>C (G \<mu>'))"
using \<mu>' G\<^sub>0_props G_props [of \<mu>'] F.weakly_preserves_objects G\<^sub>0_preserves_obj(1)
by auto
finally have "F (G\<^sub>1 (src\<^sub>D \<mu>')) \<cong>\<^sub>D F (src\<^sub>C (G \<mu>'))"
by blast
moreover have "F (G (src\<^sub>D \<mu>')) = F (G\<^sub>1 (src\<^sub>D \<mu>'))"
using \<mu>' G_props [of "src\<^sub>D \<mu>'"] D.comp_cod_arr D.comp_inv_arr' by auto
ultimately show ?thesis by argo
qed
obtain \<phi>' where \<phi>': "\<guillemotleft>\<phi>' : F (G (src\<^sub>D \<mu>')) \<Rightarrow>\<^sub>D F (src\<^sub>C (G \<mu>'))\<guillemotright> \<and> D.iso \<phi>'"
using 1 D.isomorphic_def by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : G (src\<^sub>D \<mu>') \<Rightarrow>\<^sub>C src\<^sub>C (G \<mu>')\<guillemotright> \<and> F \<phi> = \<phi>'"
using \<mu>' \<phi>' F.locally_full [of "G (src\<^sub>D \<mu>')" "src\<^sub>C (G \<mu>')" \<phi>'] C.in_hhom_def G_props(1)
by auto
have "C.iso \<phi>"
using \<phi> \<phi>' F.reflects_iso by auto
thus ?thesis
using \<phi> C.isomorphic_def by auto
qed
show "G (trg\<^sub>D \<mu>') \<cong>\<^sub>C trg\<^sub>C (G \<mu>')"
proof -
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>e (trg\<^sub>D \<mu>')\<close> \<open>d (trg\<^sub>D \<mu>')\<close> \<open>\<eta> (trg\<^sub>D \<mu>')\<close> \<open>\<epsilon> (trg\<^sub>D \<mu>')\<close>
using \<mu>' G\<^sub>0_props by simp
have 1: "F (G (trg\<^sub>D \<mu>')) \<cong>\<^sub>D F (trg\<^sub>C (G \<mu>'))"
proof -
have "F (G\<^sub>1 (trg\<^sub>D \<mu>')) \<cong>\<^sub>D e (trg\<^sub>D \<mu>') \<star>\<^sub>D trg\<^sub>D \<mu>' \<star>\<^sub>D d (trg\<^sub>D \<mu>')"
using \<mu>' G\<^sub>1_props [of "trg\<^sub>D \<mu>'"] by simp
also have "... \<cong>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D \<mu>'))"
proof -
have "\<guillemotleft>\<epsilon> (trg\<^sub>D \<mu>') \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (trg\<^sub>D \<mu>')]) :
e (trg\<^sub>D \<mu>') \<star>\<^sub>D trg\<^sub>D \<mu>' \<star>\<^sub>D d (trg\<^sub>D \<mu>') \<Rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D \<mu>'))\<guillemotright>"
using \<mu>' G\<^sub>0_props e_trg.counit_in_hom by fastforce
moreover have "D.iso (\<epsilon> (trg\<^sub>D \<mu>') \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (trg\<^sub>D \<mu>')]))"
using \<mu>' G\<^sub>0_props D.isos_compose D.arrI calculation by simp
ultimately show ?thesis
using D.isomorphic_def by blast
qed
also have "... \<cong>\<^sub>D F (trg\<^sub>C (G \<mu>'))"
using \<mu>' G\<^sub>0_props G_props [of \<mu>'] F.weakly_preserves_objects G\<^sub>0_preserves_obj(1)
by auto
finally have "F (G\<^sub>1 (trg\<^sub>D \<mu>')) \<cong>\<^sub>D F (trg\<^sub>C (G \<mu>'))"
by blast
moreover have "F (G (trg\<^sub>D \<mu>')) = F (G\<^sub>1 (trg\<^sub>D \<mu>'))"
using \<mu>' G_props [of "trg\<^sub>D \<mu>'"] D.comp_cod_arr D.comp_inv_arr' by auto
ultimately show ?thesis by argo
qed
obtain \<phi>' where \<phi>': "\<guillemotleft>\<phi>' : F (G (trg\<^sub>D \<mu>')) \<Rightarrow>\<^sub>D F (trg\<^sub>C (G \<mu>'))\<guillemotright> \<and> D.iso \<phi>'"
using 1 D.isomorphic_def by auto
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : G (trg\<^sub>D \<mu>') \<Rightarrow>\<^sub>C trg\<^sub>C (G \<mu>')\<guillemotright> \<and> F \<phi> = \<phi>'"
using \<mu>' \<phi>' F.locally_full [of "G (trg\<^sub>D \<mu>')" "trg\<^sub>C (G \<mu>')" \<phi>'] C.in_hhom_def G_props(1)
by auto
have "C.iso \<phi>"
using \<phi> \<phi>' F.reflects_iso by auto
thus ?thesis
using \<phi> C.isomorphic_def by auto
qed
qed
lemma map\<^sub>0_eq_G\<^sub>0 [simp]:
assumes "D.obj a'"
shows "map\<^sub>0 a' = G\<^sub>0 a'"
using assms map\<^sub>0_def C.in_hhom_def D.obj_def G_props(1) by metis
text \<open>
We will need a naturality property of \<open>\<phi>\<close>, which amounts to the fact that the \<open>\<phi> f'\<close>
are the components of a natural transformation from the functor \<open>F \<circ> G\<close> to the
functor that transports \<open>\<mu>'\<close> to \<open>e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')\<close>.
\<close>
interpretation FG: composite_functor V\<^sub>D V\<^sub>C V\<^sub>D G F ..
interpretation FG': "functor" V\<^sub>D V\<^sub>D \<open>\<lambda>\<mu>'. e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')\<close>
proof
show "\<And>\<mu>'. \<not> D.arr \<mu>' \<Longrightarrow> e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>') = D.null"
using D.hseq_char' by auto
show 1: "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.hseq (e (trg\<^sub>D \<mu>')) (\<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>'))"
by (metis D.hseqI' D.in_hhomE D.obj_src D.obj_trg D.hcomp_simps(2) G\<^sub>0_props(1-2))
show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.dom (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) =
e (trg\<^sub>D (D.dom \<mu>')) \<star>\<^sub>D D.dom \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.dom \<mu>'))"
using G\<^sub>0_props(3-4) \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.hseq (e (trg\<^sub>D \<mu>')) (\<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>'))\<close>
by force
show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.cod (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) =
e (trg\<^sub>D (D.cod \<mu>')) \<star>\<^sub>D D.cod \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.cod \<mu>'))"
using 1 G\<^sub>0_props(3-4) by force
show "\<And>\<mu>' \<nu>'. D.seq \<mu>' \<nu>' \<Longrightarrow>
e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<cdot>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) =
(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>') \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D \<nu>'))"
proof -
fix \<mu>' \<nu>'
assume \<mu>'\<nu>': "D.seq \<mu>' \<nu>'"
have \<mu>': "\<guillemotleft>\<mu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<mu>'\<guillemotright>"
using \<mu>'\<nu>' D.vseq_implies_hpar by (intro D.in_hhomI, auto)
have \<nu>': "\<guillemotleft>\<nu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<nu>'\<guillemotright>"
using \<mu>'\<nu>' D.vseq_implies_hpar by (intro D.in_hhomI, auto)
show "e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<cdot>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) =
(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>') \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D \<nu>'))"
proof -
have "e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<cdot>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) =
e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D (\<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<cdot>\<^sub>D (\<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
using \<mu>'\<nu>' D.whisker_right D.obj_src G\<^sub>0_props(4) by metis
also have "... = (e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<cdot>\<^sub>D
(e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
proof -
have "D.seq (\<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) (\<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
proof (intro D.seqI D.hseqI)
show "\<guillemotleft>d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<rightarrow>\<^sub>D src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')\<guillemotright>"
using \<mu>'\<nu>' D.obj_src by blast
show "\<guillemotleft>d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<rightarrow>\<^sub>D src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')\<guillemotright>"
by fact
show "\<guillemotleft>\<mu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<mu>'\<guillemotright>"
using \<mu>' by simp
show "\<guillemotleft>\<nu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<nu>'\<guillemotright>"
using \<nu>' by simp
show "D.dom (\<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) = D.cod (\<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
proof -
have "D.hseq \<mu>' (d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<and> D.hseq \<nu>' (d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
using \<mu>' \<nu>' by blast
moreover have "D.ide (d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
using \<mu>'\<nu>' G\<^sub>0_props(4) D.obj_src by blast
ultimately show ?thesis
- using \<mu>'\<nu>' by auto
+ using \<mu>'\<nu>' by fastforce
qed
qed
thus ?thesis
using \<mu>'\<nu>' D.obj_src D.obj_trg G\<^sub>0_props(3) D.whisker_left by metis
qed
also have "... =
(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>') \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D \<nu>'))"
using \<mu>'\<nu>' D.src_vcomp D.trg_vcomp D.vseq_implies_hpar by simp
finally show ?thesis by simp
qed
qed
qed
interpretation \<phi>: transformation_by_components V\<^sub>D V\<^sub>D FG.map
\<open>\<lambda>\<mu>'. e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')\<close> \<phi>
proof
show "\<And>f'. D.ide f' \<Longrightarrow> \<guillemotleft>\<phi> f' : FG.map f' \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
using \<phi>_props G_ide by simp
show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow>
\<phi> (D.cod \<mu>') \<cdot>\<^sub>D FG.map \<mu>' =
(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
proof -
fix \<mu>'
assume \<mu>': "D.arr \<mu>'"
show "\<phi> (D.cod \<mu>') \<cdot>\<^sub>D FG.map \<mu>' = (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
proof -
have "D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>') =
F (G \<mu>')"
using \<mu>' G_props(3) by simp
thus ?thesis
using \<mu>' \<phi>_props D.iso_inv_iso D.inv_inv
D.invert_side_of_triangle(1)
[of "F (G \<mu>')" "D.inv (\<phi> (D.cod \<mu>'))"
"(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"]
by auto
qed
qed
qed
interpretation GG: "functor" D.VV.comp C.VV.comp FF
using functor_FF by simp
interpretation GoH\<^sub>D: composite_functor D.VV.comp V\<^sub>D V\<^sub>C
\<open>\<lambda>\<mu>\<nu>. H\<^sub>D (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> G
..
interpretation H\<^sub>DoGG: composite_functor D.VV.comp C.VV.comp V\<^sub>C FF
\<open>\<lambda>\<mu>\<nu>. H\<^sub>C (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
..
text \<open>
Now we need to define the composition isomorphisms \<open>\<Phi> (f', g')\<close> for each composable pair
of 1-cells \<open>(f', g')\<close>. These should be 2-cells \<open>\<guillemotleft>\<Phi> (f', g') : G f' \<star>\<^sub>D G g' \<Rightarrow>\<^sub>D G (f' \<star>\<^sub>D g')\<guillemotright>\<close>.
The way we obtain these is to define what the \<open>F\<close>-images \<open>F (\<Phi> (f', g'))\<close> have to be,
then use local fullness and faithfulness to obtain the \<open>\<Phi> (f', g')\<close>.
To prove naturality and coherence we first show that corresponding results hold for
\<open>F\<close>-images and then apply faithfulness.
The \<open>F\<close>-images \<open>F (\<Phi> (f', g'))\<close> are 2-cells
\<open>\<guillemotleft>F (\<Phi> (f', g')) : F (G f' \<star>\<^sub>D G g') \<Rightarrow>\<^sub>D F (G (f' \<star>\<^sub>D g'))\<guillemotright>\<close>.
These are defined as the composition of a chain of 2-cells:
\[\begin{array}{l}
\<open>F (G f' \<star>\<^sub>C G g')\<close>\\
\qquad \<open>\<Rightarrow>\<close> \<open>F (G f') \<star>\<^sub>D F (G g')\<close>\\
\qquad \<open>\<Rightarrow>\<close> \<open>(e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')) \<star>\<^sub>D e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
\qquad \<open>\<Rightarrow>\<close> \<open>e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D (d (src\<^sub>D f') \<star>\<^sub>D e (trg\<^sub>D g')) \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
\qquad \<open>\<Rightarrow>\<close> \<open>e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
\qquad \<open>\<Rightarrow>\<close> \<open>e (trg\<^sub>D f') \<star>\<^sub>D (f' \<star>\<^sub>D g') \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
\qquad \<open>\<Rightarrow>\<close> \<open>F (G (f' \<star>\<^sub>D g'))\<close>.
\end{array}\]
This results in a rather large expression, which is very nasty to work with if we try
to expand everything out.
Instead, we express it in terms of simpler chunks obtained by translating arrows,
composition, and unitors along the mapping that takes \<open>\<mu>\<close> to \<open>e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)\<close>.
Since this mapping is an endo-biequivalence of \<open>D\<close> (though we don't establish this,
\emph{per se}), it preserves equations that hold in \<open>D\<close> and we can work with the \<open>F\<close>-images
of these equations to help establish the naturality and coherence results we need.
\<close>
abbreviation (input) SRC
where "SRC \<mu> \<equiv> d (src\<^sub>D \<mu>) \<star>\<^sub>D e (src\<^sub>D \<mu>)"
abbreviation (input) TRG
where "TRG \<mu> \<equiv> d (trg\<^sub>D \<mu>) \<star>\<^sub>D e (trg\<^sub>D \<mu>)"
abbreviation (input) XLT
where "XLT \<mu> \<equiv> e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)"
definition LUNIT
where "LUNIT f \<equiv> \<l>\<^sub>D[f] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f)"
definition RUNIT
where "RUNIT f \<equiv> \<r>\<^sub>D[f] \<cdot>\<^sub>D (f \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D f)))"
text \<open>
Here we prove a series of results that would be automatic if we had some notion of
``bicategory \<open>D\<close> with \<open>SRC\<close> and \<open>TRG\<close> as alternative source and target''.
Perhaps this idea can be developed in future work and used to simplify the overall
development. For the current project, it is the end result (obtaining the converse
equivalence pseudofunctor) that I am primarily interested in.
\<close>
lemma LUNIT_in_hom [intro]:
assumes "D.ide f"
shows "\<guillemotleft>LUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
and "\<guillemotleft>LUNIT f : TRG f \<star>\<^sub>D f \<Rightarrow>\<^sub>D f\<guillemotright>"
proof -
interpret e_trg_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (trg\<^sub>D f)\<close> \<open>d (trg\<^sub>D f)\<close> \<open>\<eta> (trg\<^sub>D f)\<close> \<open>\<epsilon> (trg\<^sub>D f)\<close>
using assms G\<^sub>0_props [of "trg\<^sub>D f"] by simp
show "\<guillemotleft>LUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
unfolding LUNIT_def
- using assms e_trg_f.unit_is_iso D.hseqI' by auto
+ using assms e_trg_f.unit_is_iso by auto
show "\<guillemotleft>LUNIT f : TRG f \<star>\<^sub>D f \<Rightarrow>\<^sub>D f\<guillemotright>"
unfolding LUNIT_def
- using assms e_trg_f.unit_is_iso D.hseqI' by auto
+ using assms e_trg_f.unit_is_iso by auto
qed
lemma LUNIT_simps [simp]:
assumes "D.ide f"
shows "D.arr (LUNIT f)"
and "src\<^sub>D (LUNIT f) = src\<^sub>D f" and "trg\<^sub>D (LUNIT f) = trg\<^sub>D f"
and "D.dom (LUNIT f) = TRG f \<star>\<^sub>D f"
and "D.cod (LUNIT f) = f"
using assms LUNIT_in_hom by auto
lemma RUNIT_in_hom [intro]:
assumes "D.ide f"
shows "\<guillemotleft>RUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
and "\<guillemotleft>RUNIT f : f \<star>\<^sub>D SRC f \<Rightarrow>\<^sub>D f\<guillemotright>"
proof -
interpret e_src_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (src\<^sub>D f)\<close> \<open>d (src\<^sub>D f)\<close> \<open>\<eta> (src\<^sub>D f)\<close> \<open>\<epsilon> (src\<^sub>D f)\<close>
using assms G\<^sub>0_props [of "src\<^sub>D f"] by simp
show "\<guillemotleft>RUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
unfolding RUNIT_def
- using assms e_src_f.unit_is_iso D.hseqI' by auto
+ using assms e_src_f.unit_is_iso by auto
show "\<guillemotleft>RUNIT f : f \<star>\<^sub>D SRC f \<Rightarrow>\<^sub>D f\<guillemotright>"
unfolding RUNIT_def
- using assms e_src_f.unit_is_iso D.hseqI' by auto
+ using assms e_src_f.unit_is_iso by auto
qed
lemma RUNIT_simps [simp]:
assumes "D.ide f"
shows "D.arr (RUNIT f)"
and "src\<^sub>D (RUNIT f) = src\<^sub>D f" and "trg\<^sub>D (RUNIT f) = trg\<^sub>D f"
and "D.dom (RUNIT f) = f \<star>\<^sub>D SRC f"
and "D.cod (RUNIT f) = f"
using assms RUNIT_in_hom by auto
lemma iso_LUNIT:
assumes "D.ide f"
shows "D.iso (LUNIT f)"
proof -
interpret e_trg_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (trg\<^sub>D f)\<close> \<open>d (trg\<^sub>D f)\<close> \<open>\<eta> (trg\<^sub>D f)\<close> \<open>\<epsilon> (trg\<^sub>D f)\<close>
using assms G\<^sub>0_props [of "trg\<^sub>D f"] by simp
show ?thesis
using assms e_trg_f.unit_is_iso D.iso_inv_iso D.iso_lunit LUNIT_def LUNIT_simps(1)
by auto
qed
lemma iso_RUNIT:
assumes "D.ide f"
shows "D.iso (RUNIT f)"
proof -
interpret e_src_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (src\<^sub>D f)\<close> \<open>d (src\<^sub>D f)\<close> \<open>\<eta> (src\<^sub>D f)\<close> \<open>\<epsilon> (src\<^sub>D f)\<close>
using assms G\<^sub>0_props [of "src\<^sub>D f"] by simp
show ?thesis
using assms e_src_f.unit_is_iso D.iso_inv_iso D.iso_runit RUNIT_def RUNIT_simps(1)
by auto
qed
lemma LUNIT_naturality:
assumes "D.arr \<mu>"
shows "\<mu> \<cdot>\<^sub>D LUNIT (D.dom \<mu>) = LUNIT (D.cod \<mu>) \<cdot>\<^sub>D (TRG \<mu> \<star>\<^sub>D \<mu>)"
proof -
interpret e_trg_\<mu>: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (trg\<^sub>D \<mu>)\<close> \<open>d (trg\<^sub>D \<mu>)\<close> \<open>\<eta> (trg\<^sub>D \<mu>)\<close> \<open>\<epsilon> (trg\<^sub>D \<mu>)\<close>
using assms G\<^sub>0_props [of "trg\<^sub>D \<mu>"] by simp
show ?thesis
proof -
have "\<mu> \<cdot>\<^sub>D LUNIT (D.dom \<mu>) =
(\<mu> \<cdot>\<^sub>D \<l>\<^sub>D[D.dom \<mu>]) \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D D.dom \<mu>)"
unfolding LUNIT_def
using assms D.comp_assoc by simp
also have "... = \<l>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (trg\<^sub>D \<mu> \<star>\<^sub>D \<mu>) \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D D.dom \<mu>)"
using assms D.lunit_naturality [of \<mu>] D.comp_assoc by simp
also have "... = \<l>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D \<mu>)"
using assms D.interchange [of "trg\<^sub>D \<mu>" "D.inv (\<eta> (trg\<^sub>D \<mu>))" \<mu> "D.dom \<mu>"]
e_trg_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr by simp
also have "... = \<l>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D D.cod \<mu>) \<cdot>\<^sub>D (TRG \<mu> \<star>\<^sub>D \<mu>)"
using assms D.interchange [of "D.inv (\<eta> (trg\<^sub>D \<mu>))" "TRG \<mu>" "D.cod \<mu>" \<mu>]
e_trg_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr by simp
also have "... = LUNIT (D.cod \<mu>) \<cdot>\<^sub>D (TRG \<mu> \<star>\<^sub>D \<mu>)"
unfolding LUNIT_def
using assms D.comp_assoc by simp
finally show ?thesis by simp
qed
qed
lemma RUNIT_naturality:
assumes "D.arr \<mu>"
shows "\<mu> \<cdot>\<^sub>D RUNIT (D.dom \<mu>) = RUNIT (D.cod \<mu>) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D SRC \<mu>)"
proof -
interpret e_src_\<mu>: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (src\<^sub>D \<mu>)\<close> \<open>d (src\<^sub>D \<mu>)\<close> \<open>\<eta> (src\<^sub>D \<mu>)\<close> \<open>\<epsilon> (src\<^sub>D \<mu>)\<close>
using assms G\<^sub>0_props [of "src\<^sub>D \<mu>"] by simp
show ?thesis
proof -
have "\<mu> \<cdot>\<^sub>D RUNIT (D.dom \<mu>) =
(\<mu> \<cdot>\<^sub>D \<r>\<^sub>D[D.dom \<mu>]) \<cdot>\<^sub>D (D.dom \<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>)))"
unfolding RUNIT_def
using assms D.comp_assoc by simp
also have "... = \<r>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D src\<^sub>D \<mu>) \<cdot>\<^sub>D (D.dom \<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>)))"
using assms D.runit_naturality [of \<mu>] D.comp_assoc by simp
also have "... = \<r>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>)))"
using assms D.interchange [of \<mu> "D.dom \<mu>" "src\<^sub>D \<mu>" "D.inv (\<eta> (src\<^sub>D \<mu>))"]
e_src_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr by simp
also have "... = \<r>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (D.cod \<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>))) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D SRC \<mu>)"
using assms D.interchange [of "D.cod \<mu>" \<mu> "D.inv (\<eta> (src\<^sub>D \<mu>))" "SRC \<mu>"]
e_src_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr
by simp
also have "... = RUNIT (D.cod \<mu>) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D SRC \<mu>)"
unfolding RUNIT_def
using assms D.comp_assoc by simp
finally show ?thesis by simp
qed
qed
lemma LUNIT_hcomp:
assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
shows "LUNIT (f \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[d (trg\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D f), f, g] = LUNIT f \<star>\<^sub>D g"
proof -
interpret e_trg_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (trg\<^sub>D f)\<close> \<open>d (trg\<^sub>D f)\<close> \<open>\<eta> (trg\<^sub>D f)\<close> \<open>\<epsilon> (trg\<^sub>D f)\<close>
using assms G\<^sub>0_props [of "trg\<^sub>D f"] by simp
have "LUNIT (f \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[TRG f, f, g] =
\<l>\<^sub>D[f \<star>\<^sub>D g] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[TRG f, f, g]"
unfolding LUNIT_def
using assms D.comp_assoc by simp
also have "... = (\<l>\<^sub>D[f \<star>\<^sub>D g] \<cdot>\<^sub>D \<a>\<^sub>D[trg\<^sub>D f, f, g]) \<cdot>\<^sub>D ((D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f) \<star>\<^sub>D g)"
using assms D.assoc_naturality [of "D.inv (\<eta> (trg\<^sub>D f))" f g] e_trg_f.unit_is_iso
D.comp_assoc
by simp
also have "... = (\<l>\<^sub>D[f] \<star>\<^sub>D g) \<cdot>\<^sub>D ((D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f) \<star>\<^sub>D g)"
using assms D.lunit_hcomp [of f g] by simp
also have "... = LUNIT f \<star>\<^sub>D g"
using assms LUNIT_def LUNIT_simps(1) D.whisker_right [of g] by auto
finally show ?thesis by simp
qed
lemma RUNIT_hcomp:
assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
shows "RUNIT (f \<star>\<^sub>D g) = (f \<star>\<^sub>D RUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, SRC g]"
proof -
interpret e_src_g: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (src\<^sub>D g)\<close> \<open>d (src\<^sub>D g)\<close> \<open>\<eta> (src\<^sub>D g)\<close> \<open>\<epsilon> (src\<^sub>D g)\<close>
using assms G\<^sub>0_props [of "src\<^sub>D g"] by simp
have "(f \<star>\<^sub>D RUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, SRC g] =
(f \<star>\<^sub>D \<r>\<^sub>D[g]) \<cdot>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g))) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, SRC g]"
unfolding RUNIT_def
- using assms D.whisker_left [of f "\<r>\<^sub>D[g]" "g \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g))"] e_src_g.unit_is_iso
- D.hseqI' D.comp_assoc
- by simp
+ using assms D.whisker_left e_src_g.unit_is_iso D.comp_assoc by simp
also have "... = ((f \<star>\<^sub>D \<r>\<^sub>D[g]) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, src\<^sub>D g]) \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g)))"
using assms D.assoc_naturality [of f g "D.inv (\<eta> (src\<^sub>D g))"] e_src_g.unit_is_iso
D.comp_assoc
by simp
also have "... = \<r>\<^sub>D[f \<star>\<^sub>D g] \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g)))"
using assms D.runit_hcomp [of f g] by simp
also have "... = RUNIT (f \<star>\<^sub>D g)"
using assms RUNIT_def by simp
finally show ?thesis by simp
qed
lemma TRIANGLE:
assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
shows "(f \<star>\<^sub>D LUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, SRC f, g] = RUNIT f \<star>\<^sub>D g"
proof -
interpret e_trg_g: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (trg\<^sub>D g)\<close> \<open>d (trg\<^sub>D g)\<close> \<open>\<eta> (trg\<^sub>D g)\<close> \<open>\<epsilon> (trg\<^sub>D g)\<close>
using assms G\<^sub>0_props [of "trg\<^sub>D g"] by simp
show ?thesis
proof -
have "(f \<star>\<^sub>D LUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, SRC f, g] =
(f \<star>\<^sub>D \<l>\<^sub>D[g]) \<cdot>\<^sub>D (f \<star>\<^sub>D D.inv (\<eta> (trg\<^sub>D g)) \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[f, SRC f, g]"
using assms D.whisker_left [of f "\<l>\<^sub>D[g]" "D.inv (\<eta> (trg\<^sub>D g)) \<star>\<^sub>D g"] e_trg_g.unit_is_iso
LUNIT_def LUNIT_simps(1) D.comp_assoc
by auto
also have "... = ((f \<star>\<^sub>D \<l>\<^sub>D[g]) \<cdot>\<^sub>D \<a>\<^sub>D[f, src\<^sub>D f, g]) \<cdot>\<^sub>D ((f \<star>\<^sub>D D.inv (\<eta> (trg\<^sub>D g))) \<star>\<^sub>D g)"
using assms D.assoc_naturality [of f "D.inv (\<eta> (trg\<^sub>D g))" g] e_trg_g.unit_is_iso
D.comp_assoc
by auto
also have "... = (\<r>\<^sub>D[f] \<star>\<^sub>D g) \<cdot>\<^sub>D ((f \<star>\<^sub>D D.inv (\<eta> (trg\<^sub>D g))) \<star>\<^sub>D g)"
using assms D.triangle by simp
also have "... = RUNIT f \<star>\<^sub>D g"
using assms D.whisker_right [of g "\<r>\<^sub>D[f]" "D.inv (\<eta> (trg\<^sub>D g))"] e_trg_g.unit_is_iso
RUNIT_def RUNIT_simps D.whisker_right
by metis
finally show ?thesis by simp
qed
qed
definition CMP
where "CMP f g \<equiv> (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g)"
text \<open>
The 2-cell \<open>CMP f g\<close> has the right type to be a component of the compositor of a pseudofunctor
whose underlying mapping is \<open>XLT\<close>. This pseudofunctor ought to be an endo-biequivalence
of \<open>D\<close>, though we don't go so far as to show that.
\<close>
lemma CMP_in_hom [intro]:
assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
shows "\<guillemotleft>CMP f g : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D g)) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f))\<guillemotright>"
and "\<guillemotleft>CMP f g : XLT f \<star>\<^sub>D XLT g \<Rightarrow>\<^sub>D XLT (f \<star>\<^sub>D g)\<guillemotright>"
proof -
show 1: "\<guillemotleft>CMP f g : XLT f \<star>\<^sub>D XLT g \<Rightarrow>\<^sub>D XLT (f \<star>\<^sub>D g)\<guillemotright>"
apply (unfold CMP_def, intro D.comp_in_homI)
using assms by fastforce+
thus "\<guillemotleft>CMP f g : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D g)) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f))\<guillemotright>"
- using assms D.src_cod [of "CMP f g"] D.trg_cod [of "CMP f g"] D.hseqI'
- by fastforce
+ using assms D.src_cod D.trg_cod by fastforce
qed
lemma CMP_simps [simp]:
assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
shows "D.arr (CMP f g)"
and "src\<^sub>D (CMP f g) = F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D g))"
and "trg\<^sub>D (CMP f g) = F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f))"
and "D.dom (CMP f g) = XLT f \<star>\<^sub>D XLT g"
and "D.cod (CMP f g) = XLT (f \<star>\<^sub>D g)"
using assms CMP_in_hom [of f g] by auto
text \<open>
The \<open>CMP f g\<close> also satisfy the naturality conditions required of compositors.
\<close>
lemma CMP_naturality:
assumes "D.arr \<mu>" and "D.arr \<nu>" and "src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
shows "CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D (XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D CMP (D.dom \<mu>) (D.dom \<nu>)"
proof -
have "CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D (XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu>, d (src\<^sub>D \<mu>), XLT (D.cod \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.cod \<nu>)) \<cdot>\<^sub>D
(XLT \<mu> \<star>\<^sub>D XLT \<nu>)"
unfolding CMP_def using assms D.comp_assoc by simp
also have
"... = (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu>, d (src\<^sub>D \<mu>), XLT (D.cod \<nu>)] \<cdot>\<^sub>D
(((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.cod \<nu>)) \<cdot>\<^sub>D
(XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<cdot>\<^sub>D XLT \<mu> \<star>\<^sub>D XLT (D.cod \<nu>) \<cdot>\<^sub>D XLT \<nu>"
using assms G\<^sub>0_props
D.interchange
[of "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)]" "XLT \<mu>" "XLT (D.cod \<nu>)" "XLT \<nu>"]
by fastforce
also have
"... = ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D
XLT (D.cod \<nu>) \<cdot>\<^sub>D XLT \<nu>"
using assms G\<^sub>0_props D.assoc'_naturality [of "e (trg\<^sub>D \<mu>)" \<mu> "d (src\<^sub>D \<mu>)"] by simp
also have
"... = ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D
XLT \<nu> \<cdot>\<^sub>D XLT (D.dom \<nu>)"
using assms G\<^sub>0_props D.comp_arr_dom D.comp_cod_arr D.src_cod D.src_dom
D.trg_cod D.trg_dom FG'.naturality
by presburger
also have "... = (((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have "D.seq ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)]"
- using assms G\<^sub>0_props D.hseqI' by auto
+ using assms G\<^sub>0_props by auto
moreover have "D.seq (XLT \<nu>) (XLT (D.dom \<nu>))"
- using assms G\<^sub>0_props D.hseqI' by auto
+ using assms G\<^sub>0_props by auto
moreover have "src\<^sub>D ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) = trg\<^sub>D (XLT \<nu>)"
- using assms G\<^sub>0_props by (simp add: D.hseqI')
+ using assms G\<^sub>0_props by simp
ultimately show ?thesis
- using assms G\<^sub>0_props
- D.interchange
- [of "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)" "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)]"
- "XLT \<nu>" "XLT (D.dom \<nu>)"]
- by simp
+ using assms G\<^sub>0_props D.interchange by simp
qed
finally have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.cod \<nu>)) \<cdot>\<^sub>D
(XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
(((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have "\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu>, d (src\<^sub>D \<mu>), XLT (D.cod \<nu>)] \<cdot>\<^sub>D
(((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>) =
((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)]"
using assms D.assoc_naturality [of "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>" "d (src\<^sub>D \<mu>)" "XLT \<nu>"]
- by (simp add: D.hseqI')
+ by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
((e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have "\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)]"
- using assms D.hseqI' D.assoc_naturality [of "e (trg\<^sub>D \<mu>)" \<mu> "d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>"]
+ using assms D.assoc_naturality [of "e (trg\<^sub>D \<mu>)" \<mu> "d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>"]
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
((e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D SRC \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have
"(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)])"
proof -
have
"(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) =
e (trg\<^sub>D \<mu>) \<star>\<^sub>D
(D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(\<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)"
- using assms D.hseqI' G\<^sub>0_props D.whisker_left by simp
+ using assms G\<^sub>0_props D.whisker_left by simp
also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)] \<cdot>\<^sub>D
(d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)"
- using assms D.hseqI' D.comp_cod_arr
+ using assms D.comp_cod_arr
D.interchange
[of "D.cod \<mu>" \<mu> "\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]"
"d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>"]
by simp
also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D (TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]"
- using assms D.hseqI' G\<^sub>0_props
+ using assms G\<^sub>0_props
D.assoc'_naturality [of "d (src\<^sub>D \<mu>)" "e (trg\<^sub>D \<nu>)" "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"]
by simp
also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D (\<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
(D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)])"
- using assms D.hseqI' G\<^sub>0_props D.comp_arr_dom
+ using assms G\<^sub>0_props D.comp_arr_dom
D.interchange
[of \<mu> "D.dom \<mu>" "TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"
"\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]"]
- by simp
+ by fastforce
also have
"... = (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)])"
- using assms D.hseqI' G\<^sub>0_props D.whisker_left by simp
+ using assms G\<^sub>0_props D.whisker_left by simp
finally show ?thesis by simp
qed
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have "((e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) =
e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D
LUNIT (D.cod (\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
((d (src\<^sub>D \<mu>) \<star>\<^sub>D e (trg\<^sub>D \<nu>)) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"
- using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr D.whisker_left
+ using assms D.comp_arr_dom D.comp_cod_arr D.whisker_left
D.interchange [of "D.cod \<mu>" \<mu> "LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))"
"(d (src\<^sub>D \<mu>) \<star>\<^sub>D e (trg\<^sub>D \<nu>)) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"]
by fastforce
also have "... =
e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D (\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"
- using assms D.hseqI' LUNIT_naturality [of "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"] by simp
+ using assms LUNIT_naturality [of "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"] by simp
also have "... = (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)))"
- using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr D.whisker_left
+ using assms D.comp_arr_dom D.comp_cod_arr D.whisker_left
D.interchange [of \<mu> "D.dom \<mu>" "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)" "LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"]
by simp
finally have
"((e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)))"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
proof -
have "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) =
XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)])"
proof -
have "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) =
e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"
- using assms D.hseqI'
- D.whisker_left [of "e (trg\<^sub>D \<mu>)" "\<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]"]
- by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D ((\<mu> \<star>\<^sub>D \<nu>) \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)]"
- using assms D.hseqI' D.assoc'_naturality [of \<mu> \<nu> "d (src\<^sub>D \<nu>)"] by simp
+ using assms D.assoc'_naturality [of \<mu> \<nu> "d (src\<^sub>D \<nu>)"] by simp
also have "... = XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally show ?thesis by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D CMP (D.dom \<mu>) (D.dom \<nu>)"
unfolding CMP_def using assms D.comp_assoc by simp
finally show ?thesis by simp
qed
interpretation E: self_evaluation_map V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
notation E.eval ("\<lbrace>_\<rbrace>")
abbreviation (input) SRCt ("\<^bold>S\<^bold>R\<^bold>C")
where "\<^bold>S\<^bold>R\<^bold>C \<mu> \<equiv> \<^bold>\<langle>d (src\<^sub>D \<mu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>e (src\<^sub>D \<mu>)\<^bold>\<rangle>"
abbreviation (input) TRGt ("\<^bold>T\<^bold>R\<^bold>G")
where "\<^bold>T\<^bold>R\<^bold>G \<mu> \<equiv> \<^bold>\<langle>d (trg\<^sub>D \<mu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D \<mu>)\<^bold>\<rangle>"
abbreviation (input) XLTt ("\<^bold>X\<^bold>L\<^bold>T")
where "\<^bold>X\<^bold>L\<^bold>T \<mu> \<equiv> \<^bold>\<langle>e (trg\<^sub>D \<mu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D \<mu>)\<^bold>\<rangle>"
text \<open>
The \<open>CMP f g\<close> satisfy the coherence conditions with respect to associativity that are
required of compositors.
\<close>
(* TODO: This is a nasty proof that I would like to shorten somehow. *)
lemma CMP_coherence:
assumes "D.ide f" and "D.ide g" and "D.ide h" and "src\<^sub>D f = trg\<^sub>D g" and "src\<^sub>D g = trg\<^sub>D h"
shows "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h) =
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D \<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
text \<open>
The overall strategy of the proof is to expand the definition of \<open>CMP\<close> on the
left and right-hand sides, then permute the occurrences of \<open>LUNIT\<close> and
\<open>RUNIT\<close> to the left ends of both the left-hand side and right-hand side of the
equation to be proved, so that the initial portions of these expressions become
identical and the remaining parts to the right consist only of canonical isomorphisms.
Then the Coherence Theorem is applied to prove syntactically (and automatically) that the
canonical parts are equal, which implies equality of the complete expressions.
The rest is just grinding through the calculations.
\<close>
have "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h) =
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g)
\<star>\<^sub>D XLT h)"
unfolding CMP_def using assms D.comp_assoc by simp
also have
"... =
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g)
\<star>\<^sub>D XLT h) =
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
- using assms D.hseqI' D.whisker_right by simp (* 15 sec *)
+ using assms D.whisker_right by simp (* 15 sec *)
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D (LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"
- using assms LUNIT_hcomp [of h "d (src\<^sub>D h)"] D.hseqI' D.invert_side_of_triangle
+ using assms LUNIT_hcomp [of h "d (src\<^sub>D h)"] D.invert_side_of_triangle
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
- using assms D.whisker_left D.hseqI' by simp
+ using assms D.whisker_left by simp
finally have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)] \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.whisker_left D.hseqI' by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
(((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
using assms D.assoc'_naturality [of "f \<star>\<^sub>D g" "LUNIT h" "d (src\<^sub>D h)"] by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.whisker_left D.hseqI' by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<cdot>\<^sub>D
\<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.assoc_naturality [of f g "LUNIT h"] by simp
+ using assms D.assoc_naturality [of f g "LUNIT h"] by simp
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
finally have
"XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h))"
by simp
thus ?thesis using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) =
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h"
- using assms TRIANGLE [of f "g \<star>\<^sub>D d (src\<^sub>D g)"] D.invert_side_of_triangle D.hseqI'
+ using assms TRIANGLE [of f "g \<star>\<^sub>D d (src\<^sub>D g)"] D.invert_side_of_triangle
by simp
also have "... = ((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h)"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
finally have "((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) =
((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)])
\<star>\<^sub>D XLT h)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)] \<cdot>\<^sub>D (RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D ((RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h"
using assms D.assoc'_naturality [of "RUNIT f" g "d (src\<^sub>D g)"] by simp
also have "... = ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h)"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
finally have "((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
also have "... = ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h"
- using assms D.hseqI' D.assoc'_naturality [of "e (trg\<^sub>D f)" "RUNIT f \<star>\<^sub>D g" "d (src\<^sub>D g)"]
+ using assms D.assoc'_naturality [of "e (trg\<^sub>D f)" "RUNIT f \<star>\<^sub>D g" "d (src\<^sub>D g)"]
by simp
also have "... = (((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
finally have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
(((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]"
- using assms D.hseqI'
+ using assms
D.assoc_naturality [of "e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)" "d (src\<^sub>D g)" "XLT h"]
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h) =
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]"
- using assms D.hseqI'
+ using assms
D.assoc_naturality [of "e (trg\<^sub>D f)" "RUNIT f \<star>\<^sub>D g" "d (src\<^sub>D g) \<star>\<^sub>D XLT h"]
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)])) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) =
e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)] \<cdot>\<^sub>D (d (src\<^sub>D g) \<star>\<^sub>D XLT h)"
- using assms D.hseqI' D.comp_cod_arr D.whisker_left [of "e (trg\<^sub>D f)"]
+ using assms D.comp_cod_arr D.whisker_left
D.interchange [of "f \<star>\<^sub>D g" "RUNIT f \<star>\<^sub>D g"]
by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"
- using assms D.hseqI' D.comp_arr_dom by simp
+ using assms D.comp_arr_dom by simp
finally have "((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) =
e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) =
e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"
- using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr D.whisker_left
+ using assms D.comp_arr_dom D.comp_cod_arr D.whisker_left
D.interchange [of "f \<star>\<^sub>D g" "RUNIT f \<star>\<^sub>D g"
"\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"
"\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"]
by simp (* 10 sec *)
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)])"
- using assms D.hseqI' D.comp_arr_dom D.whisker_left
+ using assms D.comp_arr_dom D.whisker_left
D.interchange [of "RUNIT f \<star>\<^sub>D g" "(f \<star>\<^sub>D SRC f) \<star>\<^sub>D g"
"\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"
"\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"]
by simp
finally have
"(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) =
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) =
e (trg\<^sub>D f) \<star>\<^sub>D
(\<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have
"... = e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[f, g, ((d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
proof -
have "(\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]) =
\<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, ((d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
using assms D.pentagon' D.comp_assoc by simp
moreover have "D.inv (\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) =
\<a>\<^sub>D[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.iso_inv_iso by simp
+ using assms D.iso_inv_iso by simp
ultimately show ?thesis
- using assms D.hseqI' D.iso_inv_iso D.comp_assoc
+ using assms D.iso_inv_iso D.comp_assoc
D.invert_opposite_sides_of_square
[of "\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)"
"\<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)])"
"\<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]"
"\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, ((d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"]
by simp (* 10 sec *)
qed
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) =
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) =
e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)] \<cdot>\<^sub>D
((RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
(RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]"
using assms D.hseqI'
D.assoc_naturality [of "RUNIT f" g "\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"]
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) =
(e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h), h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h), h, d (src\<^sub>D h)] =
(e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left D.comp_arr_dom D.comp_cod_arr
+ using assms D.whisker_left D.comp_arr_dom D.comp_cod_arr
D.interchange [of "RUNIT f" "f \<star>\<^sub>D SRC f"
"g \<star>\<^sub>D ((TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
"g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"]
by simp (* 20 sec *)
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D
(f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
\<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
- using assms D.hseqI' TRIANGLE [of f "g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
- by simp
+ using assms TRIANGLE [of f "g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"] by simp
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left D.comp_assoc by simp
+ using assms D.whisker_left D.comp_assoc by simp
finally have
"e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)] =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
- using assms D.hseqI' LUNIT_hcomp [of g "(TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
+ using assms LUNIT_hcomp [of g "(TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
D.invert_side_of_triangle
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
((LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI'
- D.assoc'_naturality [of "LUNIT g" "TRG h \<star>\<^sub>D h" "d (src\<^sub>D h)"]
+ using assms D.assoc'_naturality [of "LUNIT g" "TRG h \<star>\<^sub>D h" "d (src\<^sub>D h)"]
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D SRC g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
((f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI'
- D.assoc'_naturality [of f "LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h" "d (src\<^sub>D h)"]
+ using assms D.assoc'_naturality [of f "LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h" "d (src\<^sub>D h)"]
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.whisker_left D.whisker_right D.comp_arr_dom D.comp_cod_arr
+ using assms D.whisker_left D.whisker_right D.comp_arr_dom D.comp_cod_arr
D.interchange [of g "LUNIT g" "LUNIT h" "(d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h"]
by simp (* 10 sec *)
thus ?thesis
using assms D.comp_assoc by simp
qed
finally have
L: "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
by simp
have "CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D \<a>\<^sub>D[XLT f, XLT g, XLT h] =
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D
(e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
unfolding CMP_def using assms D.comp_assoc by simp
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "XLT f \<star>\<^sub>D
(e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) =
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)"
- using assms D.hseqI' D.whisker_left by auto (* 15 sec *)
+ using assms D.whisker_left by auto (* 15 sec *)
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
(LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI' LUNIT_hcomp [of "g \<star>\<^sub>D h" "d (src\<^sub>D h)"]
+ using assms LUNIT_hcomp [of "g \<star>\<^sub>D h" "d (src\<^sub>D h)"]
D.invert_side_of_triangle
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
((f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI' D.assoc'_naturality [of f "LUNIT (g \<star>\<^sub>D h)" "d (src\<^sub>D h)"]
+ using assms D.assoc'_naturality [of f "LUNIT (g \<star>\<^sub>D h)" "d (src\<^sub>D h)"]
LUNIT_in_hom [of "g \<star>\<^sub>D h"]
by auto
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
((XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
(RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)]"
- using assms D.hseqI' TRIANGLE [of g "h \<star>\<^sub>D d (src\<^sub>D h)"] D.invert_side_of_triangle
+ using assms TRIANGLE [of g "h \<star>\<^sub>D d (src\<^sub>D h)"] D.invert_side_of_triangle
by simp
also have "... = (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)])"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) =
XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)] \<cdot>\<^sub>D (RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
((RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]"
- using assms D.hseqI' D.assoc'_naturality [of "RUNIT g" h "d (src\<^sub>D h)"] by auto
+ using assms D.assoc'_naturality [of "RUNIT g" h "d (src\<^sub>D h)"] by auto
also have "... = (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) =
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
(RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr
+ using assms D.comp_arr_dom D.comp_cod_arr
D.interchange
[of "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)]" "XLT f"
"XLT (g \<star>\<^sub>D h)" "e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
by simp
also have "... = (((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr
+ using assms D.comp_arr_dom D.comp_cod_arr
D.interchange
[of "(e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)" "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)]"
"e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"
"e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
by simp (* 15 sec *)
finally have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
(RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have
"\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
(((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D
d (src\<^sub>D h)) =
((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)]"
- using assms D.hseqI'
+ using assms
D.assoc_naturality
[of "e (trg\<^sub>D f) \<star>\<^sub>D f" "d (src\<^sub>D f)" "e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have
"\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D
d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)]"
- using assms D.hseqI'
+ using assms
D.assoc_naturality
[of "e (trg\<^sub>D f)" f "d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have
"(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D
d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)] \<cdot>\<^sub>D
(d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
(TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
- using assms D.hseqI'
+ using assms
D.assoc'_naturality [of "d (src\<^sub>D f)" "e (trg\<^sub>D g)" "(RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
by auto
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have
"(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
((TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI'
- D.assoc'_naturality [of "TRG g" "RUNIT g \<star>\<^sub>D h" "d (src\<^sub>D h)"]
+ using assms D.assoc'_naturality [of "TRG g" "RUNIT g \<star>\<^sub>D h" "d (src\<^sub>D h)"]
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
(f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
((f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]"
- using assms D.hseqI'
+ using assms
D.assoc'_naturality
[of f "(d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)" "d (src\<^sub>D h)"]
by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
- using assms D.hseqI' D.whisker_left by simp
+ using assms D.whisker_left by simp
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
using assms by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h]) \<star>\<^sub>D
d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D(g \<star>\<^sub>D LUNIT h) \<cdot>\<^sub>D \<a>\<^sub>D[g, SRC g, h]) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' TRIANGLE [of g h] by simp
+ using assms TRIANGLE [of g h] by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
finally have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h))"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D \<a>\<^sub>D[g, SRC g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' LUNIT_hcomp [of g h] D.invert_side_of_triangle by simp
+ using assms LUNIT_hcomp [of g h] D.invert_side_of_triangle by simp
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left D.whisker_right by simp
+ using assms D.whisker_left D.whisker_right by simp
finally have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h))"
by simp
thus ?thesis
using assms D.comp_assoc by simp
qed
also have
"... = ((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D \<a>\<^sub>D[g, SRC g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have
"(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h] \<cdot>\<^sub>D (TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h)) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.whisker_left D.whisker_right by auto
+ using assms D.whisker_left D.whisker_right by auto
also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
(f \<star>\<^sub>D ((TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<cdot>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, SRC g \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.assoc'_naturality [of "TRG g" g "LUNIT h"] by auto
+ using assms D.assoc'_naturality [of "TRG g" g "LUNIT h"] by auto
also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h))"
- using assms D.hseqI' D.whisker_left D.whisker_right by auto
+ using assms D.whisker_left D.whisker_right by auto
finally have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h))"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D \<a>\<^sub>D[g, d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
proof -
have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)"
- using assms D.hseqI' D.whisker_left D.whisker_right D.comp_arr_dom D.comp_cod_arr
+ using assms D.whisker_left D.whisker_right D.comp_arr_dom D.comp_cod_arr
D.interchange [of "LUNIT g" "TRG g \<star>\<^sub>D g" h "LUNIT h"]
by simp (* 15 sec *)
thus ?thesis
using assms by simp
qed
finally have
R: "CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D \<a>\<^sub>D[XLT f, XLT g, XLT h] =
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
using assms by simp
text \<open>
The portions of the expressions on the right-hand sides of assertions \<open>L\<close> and \<open>R\<close>
that are not identical only involve canonical isomorphisms, and thus they can be proved
equal automatically by the simplifier, once we have expressed them in the formal
language of \<open>D\<close>.
\<close>
let ?LHS =
"(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D
\<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
(\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
let ?LHSt =
"(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>T\<^bold>R\<^bold>G g \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g, \<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G h, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D h)\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>X\<^bold>L\<^bold>T h\<^bold>] \<^bold>\<cdot>
(\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
((\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
((\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>S\<^bold>R\<^bold>C f, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
((\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
(\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T g\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
(\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>, \<^bold>X\<^bold>L\<^bold>T g\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
((\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T g) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h)"
let ?RHS =
"(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
\<a>\<^sub>D[XLT f, XLT g, XLT h]"
let ?RHSt =
"(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G g \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star>
\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>,
\<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>)\<^bold>] \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>,
(\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>)\<^bold>] \<^bold>\<cdot>
(\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>\<^bold>] \<^bold>\<star>
\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>) \<^bold>\<cdot>
(\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>S\<^bold>R\<^bold>C g, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D h)\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
(\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h\<^bold>]) \<^bold>\<cdot>
(\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>X\<^bold>L\<^bold>T h\<^bold>]) \<^bold>\<cdot>
(\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
\<^bold>\<a>\<^bold>[\<^bold>X\<^bold>L\<^bold>T f, \<^bold>X\<^bold>L\<^bold>T g, \<^bold>X\<^bold>L\<^bold>T h\<^bold>]"
have E: "?LHS = ?RHS"
proof -
have "?LHS = \<lbrace>?LHSt\<rbrace>"
using assms D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
D.VV.ide_char D.VV.arr_char
by simp
also have "... = \<lbrace>?RHSt\<rbrace>"
using assms by (intro E.eval_eqI, auto)
also have "... = ?RHS"
using assms D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
D.VV.ide_char D.VV.arr_char
by simp
finally show ?thesis by blast
qed
show ?thesis
using L R E by argo
qed
text \<open>
The component of the compositor at \<open>(f', g')\<close> is a 2-cell
\[
\<open>\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>\<close>
\]
having the property \<open>F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'\<close>, where
\[
\<open>F\<Phi>\<^sub>0 f' g' =
D.inv (\<phi> (f' \<star>\<^sub>D g')) \<cdot>\<^sub>D CMP f' g' \<cdot>\<^sub>D (\<phi> f' \<star>\<^sub>D \<phi> g') \<cdot>\<^sub>D D.inv (\<Phi> (G f', G g'))\<close>.
\]
It is unique due to the faithfulness of \<open>F\<close>.
\<close>
abbreviation (input) F\<Phi>\<^sub>0
where "F\<Phi>\<^sub>0 f' g' \<equiv>
D.inv (\<phi> (f' \<star>\<^sub>D g')) \<cdot>\<^sub>D CMP f' g' \<cdot>\<^sub>D (\<phi> f' \<star>\<^sub>D \<phi> g') \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G f', G g'))"
definition \<Phi>\<^sub>0
where "\<Phi>\<^sub>0 \<equiv> \<lambda>(f', g'). THE \<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"
lemma \<Phi>\<^sub>0_props:
assumes "D.ide f'" and "D.ide g'" and "src\<^sub>D f' = trg\<^sub>D g'"
shows "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
and "F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'"
proof -
have *: "\<exists>!\<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"
proof -
have "\<guillemotleft>F\<Phi>\<^sub>0 f' g' : F (G f' \<star>\<^sub>C G g') \<Rightarrow>\<^sub>D F (G (f' \<star>\<^sub>D g'))\<guillemotright>"
proof (intro D.comp_in_homI)
show "\<guillemotleft>D.inv (\<Phi>\<^sub>F (G f', G g')) : F (G f' \<star>\<^sub>C G g') \<Rightarrow>\<^sub>D F (G f') \<star>\<^sub>D F (G g')\<guillemotright>"
using assms F.\<Phi>_in_hom G_props by auto
show "\<guillemotleft>\<phi> f' \<star>\<^sub>D \<phi> g' : F (G f') \<star>\<^sub>D F (G g') \<Rightarrow>\<^sub>D XLT f' \<star>\<^sub>D XLT g'\<guillemotright>"
using assms G_ide G\<^sub>1_props \<phi>_props C.in_hhom_def
by (intro D.hcomp_in_vhom, auto)
show "\<guillemotleft>CMP f' g' : XLT f' \<star>\<^sub>D XLT g' \<Rightarrow>\<^sub>D XLT (f' \<star>\<^sub>D g')\<guillemotright>"
using assms CMP_in_hom [of f' g'] by simp
show "\<guillemotleft>D.inv (\<phi> (f' \<star>\<^sub>D g')) : XLT (f' \<star>\<^sub>D g') \<Rightarrow>\<^sub>D F (G (f' \<star>\<^sub>D g'))\<guillemotright>"
using assms G_props [of "f' \<star>\<^sub>D g'"] \<phi>_props D.comp_cod_arr D.comp_inv_arr'
by auto
qed
hence "\<exists>\<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"
using assms F.locally_full [of "G f' \<star>\<^sub>C G g'" "G (f' \<star>\<^sub>D g')" "F\<Phi>\<^sub>0 f' g'"]
C.ide_hcomp C.ideD(1) C.hcomp_simps(1-2) D.ide_hcomp
D.ideD(1) D.hcomp_simps(1-2) preserves_ide preserves_src preserves_trg
by presburger
moreover have "\<And>\<mu> \<nu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g' \<and>
\<guillemotleft>\<nu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<nu> = F\<Phi>\<^sub>0 f' g'
\<Longrightarrow> \<mu> = \<nu>"
using assms F.is_faithful C.in_homE by metis
ultimately show ?thesis by auto
qed
have 1: "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'"
using * \<Phi>\<^sub>0_def
the1_equality [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"]
by auto
show "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
using 1 by simp
show "F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'"
using 1 by simp
qed
lemma \<Phi>\<^sub>0_in_hom [intro]:
assumes "D.ide f'" and "D.ide g'" and "src\<^sub>D f' = trg\<^sub>D g'"
shows "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : src\<^sub>C (G g') \<rightarrow>\<^sub>C trg\<^sub>C (G f')\<guillemotright>"
and "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
proof -
show "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
using assms \<Phi>\<^sub>0_props by simp
thus "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : src\<^sub>C (G g') \<rightarrow>\<^sub>C trg\<^sub>C (G f')\<guillemotright>"
using assms C.src_dom C.trg_dom by fastforce
qed
lemma \<Phi>\<^sub>0_simps [simp]:
assumes "D.ide f'" and "D.ide g'" and "src\<^sub>D f' = trg\<^sub>D g'"
shows "C.arr (\<Phi>\<^sub>0 (f', g'))"
and "src\<^sub>C (\<Phi>\<^sub>0 (f', g')) = src\<^sub>C (G g')" and "trg\<^sub>C (\<Phi>\<^sub>0 (f', g')) = trg\<^sub>C (G f')"
and "C.dom (\<Phi>\<^sub>0 (f', g')) = G f' \<star>\<^sub>C G g'" and "C.cod (\<Phi>\<^sub>0 (f', g')) = G (f' \<star>\<^sub>D g')"
using assms \<Phi>\<^sub>0_in_hom
apply auto
by blast+
lemma F\<Phi>\<^sub>0_naturality:
assumes "D.arr \<mu>" and "D.arr \<nu>" and "src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
shows "F\<Phi>\<^sub>0 (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>) =
F (GoH\<^sub>D.map (\<mu>, \<nu>)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (D.dom \<mu>) (D.dom \<nu>)"
proof -
have "F\<Phi>\<^sub>0 (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>) =
D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D
((\<phi> (D.cod \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>))) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
proof -
have "D.inv (\<Phi>\<^sub>F (G (D.cod \<mu>), G (D.cod \<nu>))) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>) =
(F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
proof -
have "\<Phi>\<^sub>F (G (D.cod \<mu>), G (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) =
F (G \<mu> \<star>\<^sub>C G \<nu>) \<cdot>\<^sub>D \<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>))"
using assms C.VV.arr_char F.\<Phi>.naturality [of "(G \<mu>, G \<nu>)"] F.FF_def by simp
moreover have "D.seq (\<Phi>\<^sub>F (G (D.cod \<mu>), G (D.cod \<nu>))) (F (G \<mu>) \<star>\<^sub>D F (G \<nu>))"
- using assms C.hseqI' D.hseqI' F.preserves_hcomp C.VV.arr_char F.FF_def
- by (intro D.seqI D.hseqI, auto)
+ using assms F.preserves_hcomp C.VV.arr_char F.FF_def by auto
ultimately show ?thesis
- using assms F.\<Phi>_components_are_iso D.invert_opposite_sides_of_square by simp
+ using assms D.invert_opposite_sides_of_square by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D
(CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D
(XLT \<mu> \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
(\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
proof -
have "(\<phi> (D.cod \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) =
(XLT \<mu> \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>))"
proof -
have "(\<phi> (D.cod \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) =
\<phi> (D.cod \<mu>) \<cdot>\<^sub>D F (G \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>) \<cdot>\<^sub>D F (G \<nu>)"
using assms D.interchange by simp
also have "... = (XLT \<mu> \<cdot>\<^sub>D \<phi> (D.dom \<mu>)) \<star>\<^sub>D (XLT \<nu> \<cdot>\<^sub>D \<phi> (D.dom \<nu>))"
using assms \<phi>.map_def \<phi>.naturality [of \<mu>] \<phi>.naturality [of \<nu>] by fastforce
also have "... = (XLT \<mu> \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>))"
- using assms D.interchange D.hseqI' by simp
+ using assms D.interchange by simp
finally show ?thesis by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D
XLT (\<mu> \<star>\<^sub>D \<nu>)) \<cdot>\<^sub>D
CMP (D.dom \<mu>) (D.dom \<nu>) \<cdot>\<^sub>D
(\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
using assms CMP_naturality D.comp_assoc by simp
also have "... = F (G (\<mu> \<star>\<^sub>D \<nu>)) \<cdot>\<^sub>D D.inv (\<phi> (D.dom \<mu> \<star>\<^sub>D D.dom \<nu>)) \<cdot>\<^sub>D
CMP (D.dom \<mu>) (D.dom \<nu>) \<cdot>\<^sub>D
(\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
proof -
have "D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D XLT (\<mu> \<star>\<^sub>D \<nu>) =
F (G (\<mu> \<star>\<^sub>D \<nu>)) \<cdot>\<^sub>D D.inv (\<phi> (D.dom \<mu> \<star>\<^sub>D D.dom \<nu>))"
- using assms D.hseqI' \<phi>.naturality [of "\<mu> \<star>\<^sub>D \<nu>"] \<phi>_props(2)
+ using assms \<phi>.naturality [of "\<mu> \<star>\<^sub>D \<nu>"] \<phi>_props(2)
D.invert_opposite_sides_of_square
[of "\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)" "F (G (\<mu> \<star>\<^sub>D \<nu>))" "XLT (\<mu> \<star>\<^sub>D \<nu>)"
"\<phi> (D.dom \<mu> \<star>\<^sub>D D.dom \<nu>)"]
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = F (GoH\<^sub>D.map (\<mu>, \<nu>)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (D.dom \<mu>) (D.dom \<nu>)"
using assms D.comp_assoc by simp
finally show ?thesis by simp
qed
interpretation \<Phi>: transformation_by_components D.VV.comp V\<^sub>C
H\<^sub>DoGG.map GoH\<^sub>D.map \<Phi>\<^sub>0
proof
show 1: "\<And>a. D.VV.ide a \<Longrightarrow> \<guillemotleft>\<Phi>\<^sub>0 a : H\<^sub>DoGG.map a \<Rightarrow>\<^sub>C GoH\<^sub>D.map a\<guillemotright>"
using D.VV.ide_char D.VV.arr_char \<Phi>\<^sub>0_props FF_def by auto
show "\<And>\<mu>\<nu>. D.VV.arr \<mu>\<nu> \<Longrightarrow>
\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu> = GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>)"
proof -
fix \<mu>\<nu>
assume \<mu>\<nu>: "D.VV.arr \<mu>\<nu>"
define \<mu> where "\<mu> = fst \<mu>\<nu>"
define \<nu> where "\<nu> = snd \<mu>\<nu>"
have \<mu>: "D.arr \<mu>"
using \<mu>_def \<mu>\<nu> D.VV.arr_char by simp
have \<nu>: "D.arr \<nu>"
using \<nu>_def \<mu>\<nu> D.VV.arr_char by simp
have \<mu>\<nu>: "src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
using \<mu>_def \<nu>_def \<mu>\<nu> D.VV.arr_char by simp
have "F (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu>) =
F (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>)) \<cdot>\<^sub>D F (H\<^sub>DoGG.map \<mu>\<nu>)"
- using 1 \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.arr_char C.hseqI' FF_def by simp
+ using 1 \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.arr_char FF_def by simp
also have "... = F\<Phi>\<^sub>0 (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>)"
using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.cod_char FF_def by auto
also have "... = F (GoH\<^sub>D.map \<mu>\<nu>) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (D.dom \<mu>) (D.dom \<nu>)"
using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> F\<Phi>\<^sub>0_naturality by simp
also have "... = F (GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>))"
using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.dom_char by auto
finally have "F (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu>) =
F (GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>))"
by simp
moreover have "C.par (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu>)
(GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>))"
- using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> C.hseqI'
- \<Phi>\<^sub>0_props D.VV.arr_char D.VV.dom_char D.VV.cod_char D.VV.ide_char FF_def
+ using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.arr_char D.VV.dom_char D.VV.cod_char
+ D.VV.ide_char FF_def
by auto
ultimately show "\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu> =
GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>)"
using F.is_faithful by blast
qed
qed
abbreviation \<Phi>
where "\<Phi> \<equiv> \<Phi>.map"
lemma \<Phi>_in_hom [intro]:
assumes "D.arr \<mu>'" and "D.arr \<nu>'" and "src\<^sub>D \<mu>' = trg\<^sub>D \<nu>'"
shows "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : src\<^sub>C (G (D.dom \<nu>')) \<rightarrow>\<^sub>C trg\<^sub>C (G (D.cod \<mu>'))\<guillemotright>"
and "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : G (D.dom \<mu>') \<star>\<^sub>C G (D.dom \<nu>') \<Rightarrow>\<^sub>C G (D.cod \<mu>' \<star>\<^sub>D D.cod \<nu>')\<guillemotright>"
proof -
show "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : G (D.dom \<mu>') \<star>\<^sub>C G (D.dom \<nu>') \<Rightarrow>\<^sub>C G (D.cod \<mu>' \<star>\<^sub>D D.cod \<nu>')\<guillemotright>"
- using assms D.VV.arr_char D.VV.dom_char D.VV.cod_char \<Phi>.map_def FF_def
- apply auto
- apply (intro C.comp_in_homI, auto)
- by (intro C.hcomp_in_vhom, auto)
+ using assms D.VV.arr_char D.VV.dom_char D.VV.cod_char \<Phi>.map_def FF_def by simp
thus "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : src\<^sub>C (G (D.dom \<nu>')) \<rightarrow>\<^sub>C trg\<^sub>C (G (D.cod \<mu>'))\<guillemotright>"
- apply (intro C.in_hhomI)
- apply auto
- apply (metis (no_types, lifting) C.arr_dom C.in_homE C.hcomp_simps(1)
- C.src_dom [of "\<Phi> (\<mu>', \<nu>')"])
- by (metis (no_types, lifting) C.in_homE C.trg_cod D.arr_cod D.hseqI'
- D.src_cod D.trg_cod D.trg_hcomp' assms(1-3) preserves_trg)
+ using assms C.src_dom [of "\<Phi> (\<mu>', \<nu>')"] C.trg_dom [of "\<Phi> (\<mu>', \<nu>')"] by auto
qed
lemma \<Phi>_simps [simp]:
assumes "D.arr \<mu>'" and "D.arr \<nu>'" and "src\<^sub>D \<mu>' = trg\<^sub>D \<nu>'"
shows "C.arr (\<Phi> (\<mu>', \<nu>'))"
and "src\<^sub>C (\<Phi> (\<mu>', \<nu>')) = src\<^sub>C (G (D.dom \<nu>'))" and "trg\<^sub>C (\<Phi> (\<mu>', \<nu>')) = trg\<^sub>C (G (D.cod \<mu>'))"
and "C.dom (\<Phi> (\<mu>', \<nu>')) = G (D.dom \<mu>') \<star>\<^sub>C G (D.dom \<nu>')"
and "C.cod (\<Phi> (\<mu>', \<nu>')) = G (D.cod \<mu>' \<star>\<^sub>D D.cod \<nu>')"
using assms \<Phi>_in_hom
apply auto
by blast+
interpretation \<Phi>: natural_isomorphism D.VV.comp V\<^sub>C H\<^sub>DoGG.map GoH\<^sub>D.map \<Phi>
proof
fix fg
assume fg: "D.VV.ide fg"
let ?f = "fst fg"
let ?g = "snd fg"
have f: "D.ide ?f"
using fg D.VV.ide_char by simp
have g: "D.ide ?g"
using fg D.VV.ide_char by simp
have fg: "src\<^sub>D ?f = trg\<^sub>D ?g"
using fg D.VV.ide_char D.VV.arr_char by simp
interpret e_trg_g: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e (trg\<^sub>D ?g)\<close> \<open>d (trg\<^sub>D ?g)\<close> \<open>\<eta> (trg\<^sub>D ?g)\<close> \<open>\<epsilon> (trg\<^sub>D ?g)\<close>
using g G\<^sub>0_props by simp
have "D.iso (F (\<Phi> fg))"
proof -
have "F (\<Phi> fg) =
D.inv (\<phi> (?f \<star>\<^sub>D ?g)) \<cdot>\<^sub>D
(e (trg\<^sub>D ?f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[?f, ?g, d (src\<^sub>D ?g)]) \<cdot>\<^sub>D
(e (trg\<^sub>D ?f) \<star>\<^sub>D ?f \<star>\<^sub>D LUNIT (?g \<star>\<^sub>D d (src\<^sub>D ?g))) \<cdot>\<^sub>D
(e (trg\<^sub>D ?f) \<star>\<^sub>D ?f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D ?g), e (trg\<^sub>D ?g), ?g \<star>\<^sub>D d (src\<^sub>D ?g)]) \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D ?f), ?f, d (trg\<^sub>D ?g) \<star>\<^sub>D XLT ?g] \<cdot>\<^sub>D
\<a>\<^sub>D[e (trg\<^sub>D ?f) \<star>\<^sub>D ?f, d (trg\<^sub>D ?g), XLT ?g] \<cdot>\<^sub>D
(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D ?f), ?f, d (trg\<^sub>D ?g)] \<star>\<^sub>D XLT ?g) \<cdot>\<^sub>D
(\<phi> ?f \<star>\<^sub>D \<phi> ?g) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G ?f, G ?g))"
using CMP_def f g fg \<Phi>\<^sub>0_props [of ?f ?g] D.VV.ide_char D.VV.arr_char D.comp_assoc
by simp
moreover have "D.iso ..."
- using f g fg D.VV.arr_char D.iso_inv_iso F.\<Phi>_components_are_iso \<phi>_props D.hseqI'
- e_trg_g.unit_is_iso iso_LUNIT
- apply (intro D.isos_compose) by simp_all (* 17 subgoals, 40 sec. *)
+ using f g fg D.VV.arr_char D.iso_inv_iso \<phi>_props e_trg_g.unit_is_iso iso_LUNIT
+ apply (intro D.isos_compose) by simp_all (* 17 subgoals, 30 sec. *)
ultimately show ?thesis by simp
qed
thus "C.iso (\<Phi> fg)"
using F.reflects_iso by blast
qed
interpretation G: pseudofunctor V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>
proof
fix f g h
assume f: "D.ide f"
assume g: "D.ide g"
assume h: "D.ide h"
assume fg: "src\<^sub>D f = trg\<^sub>D g"
assume gh: "src\<^sub>D g = trg\<^sub>D h"
show "G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) =
\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]"
proof -
have 1: "\<guillemotleft>\<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) :
(G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G ((f \<star>\<^sub>D g) \<star>\<^sub>D h)\<guillemotright>"
proof (intro C.comp_in_homI)
show "\<guillemotleft>\<Phi> (f, g) \<star>\<^sub>C G h : (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g) \<star>\<^sub>C G h\<guillemotright>"
using f g h fg gh D.VV.arr_char D.VV.ide_char
by (intro C.hcomp_in_vhom, auto)
show "\<guillemotleft>\<Phi> (f \<star>\<^sub>D g, h) : G (f \<star>\<^sub>D g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G ((f \<star>\<^sub>D g) \<star>\<^sub>D h)\<guillemotright>"
using f g h fg gh D.VV.arr_char D.VV.ide_char \<Phi>\<^sub>0_props(1) by simp
qed
have LHS: "\<guillemotleft>G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) :
(G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
proof
show "\<guillemotleft>\<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) :
(G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G ((f \<star>\<^sub>D g) \<star>\<^sub>D h)\<guillemotright>"
using 1 by simp
show "\<guillemotleft>G \<a>\<^sub>D[f, g, h] : G ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
using f g h fg gh D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
G_ide G_props(2)
apply (intro C.in_homI)
by simp_all
qed
have 2: "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) :
G f \<star>\<^sub>C G g \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
proof (intro C.comp_in_homI)
show "\<guillemotleft>G f \<star>\<^sub>C \<Phi> (g, h) : G f \<star>\<^sub>C G g \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G f \<star>\<^sub>C G (g \<star>\<^sub>D h)\<guillemotright>"
using f g h fg gh D.VV.arr_char D.VV.ide_char
by (intro C.hcomp_in_vhom, auto)
show "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) : G f \<star>\<^sub>C G (g \<star>\<^sub>D h) \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
using f g h fg gh D.VV.arr_char D.VV.ide_char by auto
qed
have RHS: "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h] :
(G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
proof -
have "\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h] =
(\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h))) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]"
using C.comp_assoc by simp
moreover
have "\<guillemotleft>(\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h))) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h] :
(G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
proof
show "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) :
G f \<star>\<^sub>C G g \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
using 2 by simp
show "\<guillemotleft>\<a>\<^sub>C[G f, G g, G h] : (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G f \<star>\<^sub>C G g \<star>\<^sub>C G h\<guillemotright>"
using f g h fg gh D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
apply (intro C.in_homI) by auto
qed
ultimately show ?thesis by simp
qed
have "F (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)) =
F (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h])"
proof -
have "F (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)) =
F (G \<a>\<^sub>D[f, g, h]) \<cdot>\<^sub>D F (\<Phi> (f \<star>\<^sub>D g, h)) \<cdot>\<^sub>D F (\<Phi> (f, g) \<star>\<^sub>C G h)"
using f g h fg gh 1 D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
by (metis (no_types, lifting) C.arrI F.preserves_comp LHS)
also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F (\<Phi> (f \<star>\<^sub>D g, h)) \<cdot>\<^sub>D F (\<Phi> (f, g) \<star>\<^sub>C G h)"
using f g h fg gh G_props [of "\<a>\<^sub>D[f, g, h]"] by fastforce
also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D F (\<Phi> (f, g) \<star>\<^sub>C G h)"
using f g h fg gh \<Phi>.map_simp_ide [of "(f \<star>\<^sub>D g, h)"] \<Phi>\<^sub>0_props [of "f \<star>\<^sub>D g" h]
D.VV.arr_char D.VV.cod_char D.VV.ide_char FF_def
by auto
also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
\<Phi>\<^sub>F (C.cod (\<Phi>.map (f, g)), G h) \<cdot>\<^sub>D
(F (\<Phi>.map (f, g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (C.dom (\<Phi>.map (f, g)), G h))"
proof -
have "src\<^sub>C (G\<^sub>1 g) = trg\<^sub>C (G\<^sub>1 h)"
using g h gh G\<^sub>1_props(2) G\<^sub>1_props(2) [of h] by fastforce
hence "C.hseq (\<Phi> (f, g)) (G h)"
using f g h fg gh G_props(2) G_ide
apply (intro C.hseqI, auto)
using g h gh G\<^sub>1_props [of h] by blast
thus ?thesis
using f g h fg gh F.preserves_hcomp [of "\<Phi> (f, g)" "G h"] by auto
qed
also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h) \<cdot>\<^sub>D
(F (\<Phi>.map (f, g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using f g h fg gh \<Phi>\<^sub>0_in_hom [of f g] \<Phi>.map_def D.VV.arr_char FF_def by simp
also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h) \<cdot>\<^sub>D
(F\<Phi>\<^sub>0 f g \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using f g h fg gh \<Phi>.map_simp_ide \<Phi>\<^sub>0_props [of f g] D.VV.arr_char D.VV.ide_char
D.VV.cod_char FF_def
by auto
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<cdot>\<^sub>D
D.inv (\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
(\<phi> (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h) \<cdot>\<^sub>D
(D.inv (\<phi> (f \<star>\<^sub>D g)) \<cdot>\<^sub>D
CMP f g \<cdot>\<^sub>D (\<phi> f \<star>\<^sub>D \<phi> g) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G g))
\<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using D.comp_assoc by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
((\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<cdot>\<^sub>D
D.inv (\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h))) \<cdot>\<^sub>D
CMP (f \<star>\<^sub>D g) h) \<cdot>\<^sub>D
(((\<phi> (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
((D.inv (\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
(D.inv (\<phi> (f \<star>\<^sub>D g)) \<star>\<^sub>D F (G h)))) \<cdot>\<^sub>D
(CMP f g \<star>\<^sub>D F (G h))) \<cdot>\<^sub>D
((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
- proof -
- have "D.inv (\<phi> (f \<star>\<^sub>D g)) \<cdot>\<^sub>D CMP f g \<cdot>\<^sub>D (\<phi> f \<star>\<^sub>D \<phi> g) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G f, G g))
- \<star>\<^sub>D F (G h) =
- (D.inv (\<phi> (f \<star>\<^sub>D g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
- (CMP f g \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
- ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
- (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h))"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.whisker_right
- by auto
- thus ?thesis
- using D.comp_assoc by simp
- qed
+ using f g h fg gh \<phi>_props(2) D.whisker_right D.comp_assoc by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
((XLT (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
(CMP f g \<star>\<^sub>D F (G h))) \<cdot>\<^sub>D
((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
proof -
have "(\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<cdot>\<^sub>D D.inv (\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h))) \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h =
CMP (f \<star>\<^sub>D g) h"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_inv' D.comp_cod_arr
- by simp
+ using f g h fg gh \<phi>_props(2) D.comp_arr_inv' D.comp_cod_arr by simp
moreover have "(\<phi> (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
((D.inv (\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D \<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
(D.inv (\<phi> (f \<star>\<^sub>D g)) \<star>\<^sub>D F (G h))) =
XLT (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h"
- using f g h fg gh F.\<Phi>_in_hom [of "G (f \<star>\<^sub>D g)" "G h"]
- F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
+ using f g h fg gh \<phi>_props(2) D.comp_arr_inv' D.comp_inv_arr'
+ D.comp_arr_dom D.comp_cod_arr
D.interchange [of "\<phi> (f \<star>\<^sub>D g)" "D.inv (\<phi> (f \<star>\<^sub>D g))" "\<phi> h" "F (G h)"]
by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
((CMP f g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h))) \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
proof -
have "(XLT (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D F (G h)) = CMP f g \<star>\<^sub>D \<phi> h"
using f g h fg gh D.comp_arr_dom D.comp_cod_arr
D.interchange [of "XLT (f \<star>\<^sub>D g)" "CMP f g" "\<phi> h" "F (G h)"]
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
proof -
have "(CMP f g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) =
(CMP f g \<star>\<^sub>D XLT h) \<cdot>\<^sub>D ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D \<phi> h)"
- using f g h fg gh D.comp_arr_dom D.comp_cod_arr D.hseqI'
+ using f g h fg gh D.comp_arr_dom D.comp_cod_arr
D.interchange [of "CMP f g" "\<phi> f \<star>\<^sub>D \<phi> g" "\<phi> h" "F (G h)"]
D.interchange [of "CMP f g" "\<phi> f \<star>\<^sub>D \<phi> g" "XLT h" "\<phi> h"]
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
(\<a>\<^sub>D[XLT f, XLT g, XLT h] \<cdot>\<^sub>D
((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using f g h fg gh CMP_coherence [of f g h] D.comp_assoc by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D \<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
(\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h)))"
using f g h fg gh D.assoc_naturality [of "\<phi> f" "\<phi> g" "\<phi> h"] D.comp_assoc
by simp
finally have
A: "F (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)) =
D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D \<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
(\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h)))"
by simp
have "F (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]) =
F (\<Phi> (f, g \<star>\<^sub>D h)) \<cdot>\<^sub>D F (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>D F \<a>\<^sub>C[G f, G g, G h]"
using f g h fg gh 1 D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
by (metis (no_types, lifting) C.arrI C.seqE F.preserves_comp RHS)
also have "... = F\<Phi>\<^sub>0 f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
F (G f \<star>\<^sub>C \<Phi>\<^sub>0 (g, h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using f g h fg gh \<Phi>\<^sub>0_props D.VV.arr_char D.VV.cod_char D.VV.ide_char
F.preserves_assoc(1)
by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
F (G f \<star>\<^sub>C \<Phi>\<^sub>0 (g, h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using f g h fg gh D.VV.arr_char D.VV.ide_char D.comp_assoc by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
(\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D F (\<Phi>\<^sub>0 (g, h))) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h))) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
- using f g h fg gh F.preserves_hcomp D.comp_assoc
- by (simp add: C.hseqI')
+ using f g h fg gh F.preserves_hcomp D.comp_assoc by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
(\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D
D.inv (\<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h))) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
using f g h fg gh \<Phi>\<^sub>0_props by simp
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
((\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))) \<cdot>\<^sub>D
((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)]) \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
- proof -
- have "F (G f) \<star>\<^sub>D
- D.inv (\<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h)) =
- (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
- (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
- (F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h)))"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.whisker_left
- by (simp add: D.comp_assoc)
- thus ?thesis
- using D.comp_assoc by simp
- qed
+ using f g h fg gh \<phi>_props(2) D.whisker_left
+ by (simp add: D.comp_assoc)
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
proof -
have "(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) =
\<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)"
proof -
have "(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) =
((\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
((D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
using D.comp_assoc by simp
also have "... = ((\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h)))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_inv' D.comp_inv_arr' D.comp_cod_arr
+ using f g h fg gh \<phi>_props(2) D.comp_arr_inv' D.comp_inv_arr' D.comp_cod_arr
by simp
also have "... = (\<phi> f \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
+ using f g h fg gh \<phi>_props(2) D.comp_arr_inv' D.comp_inv_arr'
+ D.comp_arr_dom D.comp_cod_arr
D.interchange [of "\<phi> f" "F (G f)" "\<phi> (g \<star>\<^sub>D h)" "D.inv (\<phi> (g \<star>\<^sub>D h))"]
by simp
also have "... = \<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_dom D.comp_cod_arr
+ using f g h fg gh \<phi>_props(2) D.comp_arr_dom D.comp_cod_arr
D.interchange [of "\<phi> f" "F (G f)" "XLT (g \<star>\<^sub>D h)" "CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)"]
- by simp (* 15 sec *)
+ by simp
finally show ?thesis by simp
qed
moreover have "(F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] =
\<a>\<^sub>D[F (G f), F (G g), F (G h)]"
proof -
have "(F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] =
((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
((D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)))) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)]"
using D.comp_assoc by simp
also have "... = ((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
((F (G f) \<star>\<^sub>D F (G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)))) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)]"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
+ using f g h fg gh \<phi>_props(2) D.comp_arr_inv' D.comp_inv_arr'
+ D.comp_arr_dom D.comp_cod_arr
by fastforce
also have "... = ((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
(F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)]"
- proof -
+ proof -
have "D.seq (F (G g \<star>\<^sub>C G h)) (\<Phi>\<^sub>F (G g, G h))"
- using f g h fg gh
- apply (intro D.seqI) by auto
+ using f g h fg gh by force
thus ?thesis
- using f g h fg gh F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI' D.comp_cod_arr
- by auto
+ using f g h fg gh \<phi>_props(2) D.comp_cod_arr by auto
qed
also have "... = \<a>\<^sub>D[F (G f), F (G g), F (G h)]"
- using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
- D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
+ using f g h fg gh \<phi>_props(2) D.comp_arr_inv' D.comp_inv_arr'
+ D.comp_arr_dom D.comp_cod_arr
D.whisker_left [of "F (G f)" "D.inv (\<Phi>\<^sub>F (G g, G h))" "\<Phi>\<^sub>F (G g, G h)"]
by auto
finally show ?thesis by simp
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
(XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
proof -
have "\<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h) =
(XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D (\<phi> f \<star>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
- using f g h fg gh D.hseqI' D.comp_cod_arr
+ using f g h fg gh D.comp_cod_arr
D.interchange [of "XLT f" "\<phi> f" "CMP g h" "\<phi> g \<star>\<^sub>D \<phi> h"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
finally have
B: "F (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]) =
D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
(\<phi> f \<star>\<^sub>D \<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
(D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
by simp
show ?thesis using A B by argo
qed
moreover have "C.par (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h))
(\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h])"
using LHS RHS by (metis (no_types, lifting) C.in_homE)
ultimately show ?thesis
using F.is_faithful [of "G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)"
"\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]"]
by simp
qed
qed
interpretation "faithful_functor" V\<^sub>D V\<^sub>C G
proof
fix \<mu> \<mu>'
assume par: "D.par \<mu> \<mu>'"
assume eq: "G \<mu> = G \<mu>'"
have \<mu>: "\<guillemotleft>\<mu> : src\<^sub>D \<mu> \<rightarrow>\<^sub>D src\<^sub>D (e (trg\<^sub>D \<mu>))\<guillemotright>"
using par by simp
hence \<mu>': "\<guillemotleft>\<mu>' : src\<^sub>D \<mu> \<rightarrow>\<^sub>D src\<^sub>D (e (trg\<^sub>D \<mu>))\<guillemotright>"
using par by (metis D.in_hhom_def D.src_dom D.trg_dom)
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>e (src\<^sub>D \<mu>)\<close> \<open>d (src\<^sub>D \<mu>)\<close> \<open>\<eta> (src\<^sub>D \<mu>)\<close> \<open>\<epsilon> (src\<^sub>D \<mu>)\<close>
using \<mu> G\<^sub>0_props by auto
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>e (trg\<^sub>D \<mu>)\<close> \<open>d (trg\<^sub>D \<mu>)\<close> \<open>\<eta> (trg\<^sub>D \<mu>)\<close> \<open>\<epsilon> (trg\<^sub>D \<mu>)\<close>
using \<mu> G\<^sub>0_props by auto
have d_src: "D.equivalence_map (d (src\<^sub>D \<mu>))"
using e_src.equivalence_in_bicategory_axioms D.equivalence_map_def
D.equivalence_pair_symmetric D.equivalence_pair_def
by blast
have e_trg: "D.equivalence_map (e (trg\<^sub>D \<mu>))"
using e_trg.equivalence_in_bicategory_axioms D.equivalence_map_def by blast
show "\<mu> = \<mu>'"
proof -
have "F (G \<mu>) = F (G \<mu>')"
using eq by simp
hence 1: "D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>) =
D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"
using par G_props [of \<mu>] G_props [of \<mu>']
by (metis D.src_dom D.trg_dom)
have 2: "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>) =
(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"
proof -
have "D.iso (D.inv (\<phi> (D.cod \<mu>)))"
using par \<phi>_props D.iso_inv_iso by simp
moreover have "D.seq (D.inv (\<phi> (D.cod \<mu>)))
((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>))"
proof -
have "D.arr (F (G \<mu>))"
using par by simp
thus ?thesis
using 1 par calculation G_props [of \<mu>] G_props [of \<mu>'] by argo
qed
ultimately show ?thesis
using 1 par \<phi>_props D.comp_arr_dom D.comp_arr_inv' D.comp_assoc D.comp_cod_arr
D.ide_char G_props(2) G_props(3)
D.iso_is_section D.section_is_mono D.iso_inv_iso
D.monoE
[of "D.inv (\<phi> (D.cod \<mu>))" "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"
"(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"]
by metis
qed
have "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) = e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"
proof -
have "D.seq (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) (\<phi> (D.dom \<mu>))"
using par by fastforce
(*
* TODO: epiE and monoE don't need both seq hypotheses.
* Also, they are not stated in the form of elimination rules.
*)
thus ?thesis
- using 2 par \<phi>_props D.iso_is_retraction D.retraction_is_epi
+ using 2 par \<phi>_props D.iso_is_retraction D.retraction_is_epi D.ide_dom
D.epiE [of "\<phi> (D.dom \<mu>)" "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)"
"e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"]
- by auto
+ by metis
qed
hence "\<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) = \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"
using \<mu> \<mu>' e_trg par
D.equivalence_cancel_left [of "e (trg\<^sub>D \<mu>)" "\<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)" "\<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"]
by (metis D.hcomp_simps(3-4) D.hseqE FG'.preserves_arr)
thus ?thesis
using \<mu> \<mu>' D.equivalence_cancel_right d_src
by (metis D.obj_src d_simps(3) par)
qed
qed
interpretation G: equivalence_pseudofunctor
V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>
proof
show "\<And>a. C.obj a \<Longrightarrow> \<exists>a'. D.obj a' \<and> C.equivalent_objects (map\<^sub>0 a') a"
proof
fix a
assume a: "C.obj a"
have "D.obj (F.map\<^sub>0 a)"
using a by simp
moreover have "C.equivalent_objects (map\<^sub>0 (F.map\<^sub>0 a)) a"
using a G\<^sub>0_props [of "F.map\<^sub>0 a"] C.equivalent_objects_symmetric
F.reflects_equivalent_objects G\<^sub>0_preserves_obj(2) map\<^sub>0_simps(1)
by auto
ultimately show "D.obj (F.map\<^sub>0 a) \<and> C.equivalent_objects (map\<^sub>0 (F.map\<^sub>0 a)) a"
by blast
qed
show "\<And>a b g. \<lbrakk> D.obj a; D.obj b; \<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>C map\<^sub>0 b\<guillemotright>; C.ide g \<rbrakk>
\<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.ide f \<and> C.isomorphic (G f) g"
proof -
fix a b g
assume a: "D.obj a"
assume b: "D.obj b"
assume g_in_hhom: "\<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>C map\<^sub>0 b\<guillemotright>"
assume ide_g: "C.ide g"
interpret e\<^sub>a: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e a\<close> \<open>d a\<close> \<open>\<eta> a\<close> \<open>\<epsilon> a\<close>
using a G\<^sub>0_props by auto
interpret e\<^sub>b: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e b\<close> \<open>d b\<close> \<open>\<eta> b\<close> \<open>\<epsilon> b\<close>
using b G\<^sub>0_props by auto
interpret e\<^sub>ae\<^sub>b: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e a\<close> \<open>d a\<close> \<open>\<eta> a\<close> \<open>\<epsilon> a\<close> \<open>e b\<close> \<open>d b\<close> \<open>\<eta> b\<close> \<open>\<epsilon> b\<close>
..
have Fg: "\<guillemotleft>F g : F.map\<^sub>0 (map\<^sub>0 a) \<rightarrow>\<^sub>D F.map\<^sub>0 (map\<^sub>0 b)\<guillemotright>"
using a b g_in_hhom by auto
let ?f = "d b \<star>\<^sub>D F g \<star>\<^sub>D e a"
have f: "\<guillemotleft>?f: a \<rightarrow>\<^sub>D b\<guillemotright>"
using a b g_in_hhom ide_g by auto
have 2: "D.isomorphic (F (G ?f)) (F g)"
proof -
have "D.isomorphic (F (G ?f)) (e b \<star>\<^sub>D ?f \<star>\<^sub>D d a)"
using a b ide_g g_in_hhom f G\<^sub>0_props G\<^sub>1_props [of ?f] G_props
by (metis D.ide_hcomp D.hseqE D.in_hhomE F.preserves_ide G_ide)
also have "D.isomorphic ... (F g)"
using ide_g e\<^sub>ae\<^sub>b.\<psi>_in_hom [of "F g"] e\<^sub>ae\<^sub>b.\<psi>_components_are_iso [of "F g"]
D.isomorphic_symmetric D.isomorphic_def
by (metis D.hseqE D.ide_char D.ide_in_hom(1) D.in_hhomE D.hcomp_simps(2)
F.preserves_ide e\<^sub>b.antipar(2) f)
finally show ?thesis by simp
qed
obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F (G ?f) \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<phi>"
using 2 by auto
have "C.isomorphic (G ?f) g"
- using \<phi> F.reflects_iso
- by (metis C.arrI C.isomorphic_def D.ide_hcomp D.hseqE F.locally_full
- F.preserves_ide d_simps(1) e_simps(1) f g_in_hhom horizontal_homs.in_hhomE
- ide_g preserves_ide preserves_src preserves_trg weak_arrow_of_homs_axioms
+ using f ide_g \<phi> F.reflects_iso F.locally_full
+ by (metis C.arrI C.isomorphic_def D.ide_hcomp D.hseqE
+ F.preserves_ide d_simps(1) e_simps(1) g_in_hhom horizontal_homs.in_hhomE
+ preserves_ide preserves_src preserves_trg weak_arrow_of_homs_axioms
weak_arrow_of_homs_def)
thus "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.ide f \<and> C.isomorphic (G f) g"
using f
by (meson D.ide_hcomp D.hseqE D.in_hhomE F.preserves_ide d_simps(1) e_simps(1)
ide_g)
qed
show "\<And>f' g' \<mu>. \<lbrakk> D.ide f'; D.ide g'; src\<^sub>D f' = src\<^sub>D g'; trg\<^sub>D f' = trg\<^sub>D g';
\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>\<mu>'. \<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and> G \<mu>' = \<mu>"
proof -
fix f' g' \<mu>
assume f': "D.ide f'"
assume g': "D.ide g'"
assume \<mu>: "\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright>"
assume src_eq: "src\<^sub>D f' = src\<^sub>D g'"
assume trg_eq: "trg\<^sub>D f' = trg\<^sub>D g'"
let ?a' = "src\<^sub>D f'"
let ?b' = "trg\<^sub>D f'"
text \<open>
Given \<open>\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright>\<close>, the 2-cell \<open>F \<mu>\<close> is in \<open>hom\<^sub>D (F (G f')) (F (G g'))\<close>.
We have equivalence maps \<open>\<guillemotleft>e\<^sub>a : a' \<rightarrow>\<^sub>D F\<^sub>0 (G\<^sub>0 a')\<guillemotright>\<close>
and \<open>\<guillemotleft>e\<^sub>b : b' \<rightarrow>\<^sub>D F\<^sub>0 (G\<^sub>0 b')\<guillemotright>\<close> and \<open>d\<^sub>a\<close> and \<open>d\<^sub>b\<close> in the opposite directions.
We have shown that the functor from \<open>hom\<^sub>D f' g'\<close> to \<open>hom\<^sub>D (F (G f')) (F (G g'))\<close>
that takes \<open>\<mu>'\<close> to \<open>e b' \<star>\<^sub>D \<mu>' \<star>\<^sub>D d a'\<close> is an equivalence functor, as is also
the functor from \<open>hom\<^sub>D (F (G f')) (F (G g'))\<close> to \<open>hom f' g'\<close> that takes
\<open>\<nu>'\<close> to \<open>d b' \<star>\<^sub>D \<nu>' \<star>\<^sub>D e a'\<close>.
Now, \<open>G\<close> is defined on a 2-cell \<open>\<guillemotleft>\<mu>' : f' \<Rightarrow> g'\<guillemotright>\<close> by the condition:
\[
\<open>\<guillemotleft>G \<mu>' : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright> \<and> F (G \<mu>') = D.inv (\<phi> g') \<cdot>\<^sub>D (e b' \<star>\<^sub>D \<mu>' \<star>\<^sub>D d a') \<cdot>\<^sub>D \<phi> f'\<close>.
\]
To show that \<open>G\<close> is locally full, what we need is, given \<open>\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright>\<close>,
to obtain a 2-cell \<open>\<mu>'\<close> in \<open>hom\<^sub>D f' g'\<close> that satisfies: \<open>F (G \<mu>') = F \<mu>\<close>;
that is: \<open>D.inv (\<phi> g') \<cdot>\<^sub>D (e b' \<star>\<^sub>D \<mu>' \<star>\<^sub>D d a') \<cdot>\<^sub>D \<phi> f' = F \<mu>\<close>.
This then implies \<open>G \<mu>' = \<mu>\<close> by the faithfulness of F.
\<close>
interpret e\<^sub>a: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e ?a'\<close> \<open>d ?a'\<close> \<open>\<eta> ?a'\<close> \<open>\<epsilon> ?a'\<close>
using f' G\<^sub>0_props by auto
interpret d\<^sub>a: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>d ?a'\<close> \<open>e ?a'\<close> \<open>D.inv (\<epsilon> ?a')\<close> \<open>D.inv (\<eta> ?a')\<close>
using e\<^sub>a.dual_equivalence by simp
interpret e\<^sub>b: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>e ?b'\<close> \<open>d ?b'\<close> \<open>\<eta> ?b'\<close> \<open>\<epsilon> ?b'\<close>
using f' G\<^sub>0_props by auto
interpret d\<^sub>b: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>d ?b'\<close> \<open>e ?b'\<close> \<open>D.inv (\<epsilon> ?b')\<close> \<open>D.inv (\<eta> ?b')\<close>
using e\<^sub>b.dual_equivalence by simp
interpret d\<^sub>ad\<^sub>b: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
\<open>d ?a'\<close> \<open>e ?a'\<close> \<open>D.inv (\<epsilon> ?a')\<close> \<open>D.inv (\<eta> ?a')\<close>
\<open>d ?b'\<close> \<open>e ?b'\<close> \<open>D.inv (\<epsilon> ?b')\<close> \<open>D.inv (\<eta> ?b')\<close>
..
interpret hom_a_b: subcategory V\<^sub>D \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : ?a' \<rightarrow>\<^sub>D ?b'\<guillemotright>\<close>
using D.hhom_is_subcategory by simp
interpret hom_FGa_FGb: subcategory V\<^sub>D
\<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : F.map\<^sub>0 (G\<^sub>0 ?a') \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 ?b')\<guillemotright>\<close>
using D.hhom_is_subcategory by simp
interpret d: equivalence_of_categories hom_a_b.comp hom_FGa_FGb.comp
d\<^sub>ad\<^sub>b.F d\<^sub>ad\<^sub>b.G d\<^sub>ad\<^sub>b.\<phi> d\<^sub>ad\<^sub>b.\<psi>
using f' d\<^sub>ad\<^sub>b.induces_equivalence_of_hom_categories by simp
have F\<mu>_in_hom: "\<guillemotleft>F \<mu> : F (G f') \<Rightarrow>\<^sub>D F (G g')\<guillemotright>"
using \<mu> by auto
have F\<mu>_in_hhom: "D.in_hhom (F \<mu>) (F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f'))) (F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f')))"
using f' F\<mu>_in_hom D.src_dom [of "F \<mu>"] D.trg_dom [of "F \<mu>"] by fastforce
have "hom_FGa_FGb.in_hom (F \<mu>) (F (G f')) (F (G g'))"
using F\<mu>_in_hom F\<mu>_in_hhom hom_FGa_FGb.in_hom_char hom_FGa_FGb.arr_char
hom_FGa_FGb.cod_closed hom_FGa_FGb.dom_closed
by (metis D.in_homE)
have \<phi>g': "\<guillemotleft>\<phi> g' : F (G g') \<Rightarrow>\<^sub>D e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<guillemotright>"
using g' \<phi>_props [of g'] by blast
have inv_\<phi>f': "\<guillemotleft>D.inv (\<phi> f') : e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f') \<Rightarrow>\<^sub>D F (G f')\<guillemotright>"
using f' \<phi>_props [of f'] G_props by auto
have 1: "\<guillemotleft>\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f') :
e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f') \<Rightarrow>\<^sub>D e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<guillemotright>"
using F\<mu>_in_hom \<phi>g' inv_\<phi>f' G_ide f' g' by auto
have 2: "hom_FGa_FGb.in_hom (\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f'))
(e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f'))
(e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g'))"
proof -
have "hom_FGa_FGb.arr (\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f'))"
using 1 D.vseq_implies_hpar hom_FGa_FGb.arr_char
by (simp add: D.arrI g' src_eq trg_eq)
thus ?thesis
using 1 hom_FGa_FGb.dom_char hom_FGa_FGb.cod_char
by (metis D.in_homE hom_FGa_FGb.in_homI)
qed
obtain \<mu>' where \<mu>': "hom_a_b.in_hom \<mu>' f' g' \<and> d\<^sub>ad\<^sub>b.G \<mu>' = \<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"
using 1 2 f' g' src_eq trg_eq d.is_full [of g' f' "\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"]
hom_a_b.ide_char hom_a_b.arr_char
by auto
have 3: "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and> F (G \<mu>') = F \<mu>"
proof -
have 4: "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and>
e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f') = \<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"
using \<mu>' f' g' hom_a_b.arr_char hom_a_b.in_hom_char by auto
have "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and>
D.inv (\<phi> g') \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')) = F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"
proof -
have "D.hseq (e (trg\<^sub>D f')) (\<mu>' \<star>\<^sub>D d (src\<^sub>D f'))"
using f' g' \<mu>'
apply (intro D.hseqI, auto)
by force
thus ?thesis
using 4 g' \<phi>_props(2)
D.invert_side_of_triangle(1)
[of "e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')" "\<phi> g'" "F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"]
by metis
qed
moreover have "D.seq (D.inv (\<phi> g')) (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f'))"
proof
show "D.in_hom (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f'))
(e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f'))
(e (trg\<^sub>D f') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D f'))"
using 4 f' g' \<mu>' d_simps e_simps
by (intro D.hcomp_in_vhom, auto)
show "D.in_hom (D.inv (\<phi> g')) (e (trg\<^sub>D f') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D f')) (F (G\<^sub>1 g'))"
using 4 g' \<mu>' \<phi>_props [of g'] D.vconn_implies_hpar by simp
qed
ultimately have "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and>
D.inv (\<phi> g') \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')) \<cdot>\<^sub>D \<phi> f' = F \<mu>"
using f' \<phi>_props(2) D.iso_inv_iso D.inv_inv D.invert_side_of_triangle(2)
D.comp_assoc
by metis
moreover have "D.inv (\<phi> g') \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')) \<cdot>\<^sub>D \<phi> f' = F (G \<mu>')"
using 4 G_props(3) by auto
ultimately show ?thesis by simp
qed
hence "G \<mu>' = \<mu>"
using f' g' \<mu> \<mu>' F.is_faithful
by (metis C.in_homE D.in_homE G_ide G_props(2))
thus "\<exists>\<mu>'. \<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and> G \<mu>' = \<mu>"
using 3 by auto
qed
qed
proposition is_equivalence_pseudofunctor:
shows "equivalence_pseudofunctor V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>"
..
end
sublocale converse_equivalence_pseudofunctor \<subseteq>
equivalence_pseudofunctor V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>
using is_equivalence_pseudofunctor by simp
definition equivalent_bicategories
where "equivalent_bicategories V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C \<equiv>
\<exists>F \<Phi>. equivalence_pseudofunctor
V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C F \<Phi>"
lemma equivalent_bicategories_symmetric:
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"
shows "equivalent_bicategories V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C"
proof -
obtain F \<Phi>\<^sub>F 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>\<^sub>F"
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>\<^sub>F
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>\<^sub>F
..
show ?thesis
using G.is_equivalence_pseudofunctor equivalent_bicategories_def by blast
qed
text \<open>
A gross omission here is that I don't show that equivalence pseudofunctors compose,
and consequently that ``\<open>equivalent_bicategories\<close>'' is a transitive relation.
I have been trying to avoid this as part of the current project; proving only as much
as necessary about pseudofunctors and equivalence pseudofunctors to give confidence
that the definitions have been correctly stated. This will have to be rectified in
future work.
\<close>
end
diff --git a/thys/Bicategory/SpanBicategory.thy b/thys/Bicategory/SpanBicategory.thy
--- a/thys/Bicategory/SpanBicategory.thy
+++ b/thys/Bicategory/SpanBicategory.thy
@@ -1,5549 +1,5546 @@
(* Title: SpanBicategory
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Span Bicategories"
text \<open>
In this section we construct the bicategory \<open>Span(C)\<close>, where \<open>C\<close> is a category with pullbacks.
The $0$-cells of \<open>Span(C)\<close> are the objects of \<open>C\<close>, the $1$-cells of \<open>Span(C)\<close> are pairs
\<open>(f\<^sub>0, f\<^sub>1)\<close> of arrows of \<open>C\<close> having a common domain, and the $2$-cells of \<open>Span(C)\<close>
are ``arrows of spans''. An arrow of spans from \<open>(f\<^sub>0, f\<^sub>1)\<close> to \<open>(g\<^sub>0, g\<^sub>1)\<close> is
an arrow \<open>\<guillemotleft>u: dom f\<^sub>0 \<rightarrow> dom g\<^sub>0\<guillemotright>\<close> of \<open>C\<close>, such that \<open>g\<^sub>0 \<cdot> u = f\<^sub>0\<close> and \<open>g\<^sub>1 \<cdot> u = f\<^sub>1\<close>.
In the present development, a \emph{span} is formalized as a structure \<open>\<lparr>Leg0 = f\<^sub>0, Leg1 = f\<^sub>1\<rparr>\<close>,
where \<open>f\<^sub>0\<close> and \<open>f\<^sub>1\<close> are arrows of \<open>C\<close> with a common domain, which we call the \emph{apex} of
the span.
An \emph{arrow of spans} is formalized as a structure \<open>\<lparr>Chn = u, Dom = S, Cod = T\<rparr>\<close>,
where \<open>S\<close> and \<open>T\<close> are spans, and \<open>\<guillemotleft>u : S.apex \<rightarrow> T.apex\<guillemotright>\<close> satisfies \<open>Leg0 T \<cdot> u = Leg0 S\<close>
and \<open>Leg1 T \<cdot> u = Leg1 S\<close>. We refer to the arrow \<open>u\<close> as the \emph{chine} of the arrow of spans.
Arrows of spans inherit a composition from that of \<open>C\<close>; this is ``vertical composition''.
Spans may be composed via pullback in \<open>C\<close>; this ``horizontal composition'' extends to
arrows of spans, so that it is functorial with respect to vertical composition.
These two compositions determine a bicategory, as we shall show.
\<close>
theory SpanBicategory
imports Bicategory CategoryWithPullbacks InternalAdjunction Category3.FreeCategory
begin
subsection "Spans"
record 'a span_data =
Leg0 :: 'a
Leg1 :: 'a
locale span_in_category =
C: category +
fixes S :: "'a span_data" (structure)
assumes is_span: "C.span (Leg0 S) (Leg1 S)"
begin
abbreviation leg0
where "leg0 \<equiv> Leg0 S"
abbreviation leg1
where "leg1 \<equiv> Leg1 S"
abbreviation src
where "src \<equiv> C.cod leg0"
abbreviation trg
where "trg \<equiv> C.cod leg1"
definition apex
where "apex \<equiv> C.dom leg0"
lemma ide_apex [simp]:
shows "C.ide apex"
using is_span apex_def by simp
lemma leg_in_hom [intro]:
shows "\<guillemotleft>leg0 : apex \<rightarrow> src\<guillemotright>"
and "\<guillemotleft>leg1 : apex \<rightarrow> trg\<guillemotright>"
using is_span apex_def by auto
lemma leg_simps [simp]:
shows "C.arr leg0" and "C.dom leg0 = apex"
and "C.arr leg1" and "C.dom leg1 = apex"
using leg_in_hom by auto
end
record 'a arrow_of_spans_data =
Chn :: 'a
Dom :: "'a span_data"
Cod :: "'a span_data"
locale arrow_of_spans =
C: category C +
dom: span_in_category C \<open>Dom \<mu>\<close> +
cod: span_in_category C \<open>Cod \<mu>\<close>
for C :: "'a comp" (infixr "\<cdot>" 55)
and \<mu> :: "'a arrow_of_spans_data" (structure) +
assumes chine_in_hom [intro]: "\<guillemotleft>Chn \<mu> : dom.apex \<rightarrow> cod.apex\<guillemotright>"
and leg0_commutes [simp]: "cod.leg0 \<cdot> Chn \<mu> = dom.leg0"
and leg1_commutes [simp]: "cod.leg1 \<cdot> (Chn \<mu>) = dom.leg1"
begin
abbreviation chine
where "chine \<equiv> Chn \<mu>"
lemma chine_simps [simp]:
shows "C.arr chine" and "C.dom chine = dom.apex" and "C.cod chine = cod.apex"
using chine_in_hom by auto
lemma cod_src_eq_dom_src [simp]:
shows "cod.src = dom.src"
using dom.is_span cod.is_span
by (metis C.cod_comp leg0_commutes)
lemma cod_trg_eq_dom_trg [simp]:
shows "cod.trg = dom.trg"
using dom.is_span cod.is_span
by (metis C.cod_comp leg1_commutes)
abbreviation dsrc
where "dsrc \<equiv> dom.src"
abbreviation dtrg
where "dtrg \<equiv> dom.trg"
end
locale identity_arrow_of_spans =
arrow_of_spans +
assumes chine_is_identity [simp]: "C.ide (Chn \<mu>)"
begin
abbreviation apex
where "apex \<equiv> dom.apex"
abbreviation leg0
where "leg0 \<equiv> dom.leg0"
abbreviation leg1
where "leg1 \<equiv> dom.leg1"
lemma chine_eq_apex [simp]:
shows "chine = apex"
using chine_is_identity C.ideD(2) chine_simps(2) by presburger
lemma cod_simps [simp]:
shows "cod.apex = apex" and "cod.leg0 = leg0" and "cod.leg1 = leg1"
using chine_is_identity chine_simps(3) C.comp_arr_ide leg0_commutes leg1_commutes
by force+
end
subsection "The Vertical Category of Spans"
text \<open>
The following locale constructs the category of spans and arrows of spans in
an underlying category C, which is not yet assumed to have pullbacks.
The composition is vertical composition of arrows of spans, to which we will
later add horizontal composition to obtain a bicategory.
\<close>
locale span_vertical_category =
C: category
begin
abbreviation Null
where "Null \<equiv> \<lparr>Chn = C.null,
Dom = \<lparr>Leg0 = C.null, Leg1 = C.null\<rparr>,
Cod = \<lparr>Leg0 = C.null, Leg1 = C.null\<rparr>\<rparr>"
lemma not_arr_Null:
shows "\<not> arrow_of_spans C Null"
unfolding arrow_of_spans_def arrow_of_spans_axioms_def
by auto
text \<open>
Arrows of spans are composed simply by composing their chines.
\<close>
definition vcomp
where "vcomp \<nu> \<mu> \<equiv> if arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>
then \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
else Null"
notation vcomp (infixr "\<bullet>" 55)
(*
* TODO: The reason why the this and the subsequent category interpretation are declared
* as V: is that subsequently proved facts with the same names as the partial_magma and
* category locales silently override the latter, resulting in problems proving things.
* The presence of the extra "V" is only an issue up until a later sublocale declaration
* inherits everything from horizontal_homs. I wish I could say that I completely
* understood the inheritance and overriding rules for locales.
*)
interpretation V: partial_magma vcomp
using not_arr_Null vcomp_def
apply unfold_locales
by (metis (no_types, hide_lams))
lemma is_partial_magma:
shows "partial_magma vcomp"
..
lemma null_char:
shows "V.null = Null"
using V.null_def vcomp_def not_arr_Null
by (metis (no_types, lifting) V.comp_null(2))
text \<open>
Identities are arrows of spans whose chines are identities of C.
\<close>
lemma ide_char:
shows "V.ide \<mu> \<longleftrightarrow> arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
proof
show "V.ide \<mu> \<Longrightarrow> arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
proof
assume 0: "V.ide \<mu>"
have 1: "vcomp \<mu> \<mu> \<noteq> Null \<and> (\<forall>\<nu>. (\<nu> \<bullet> \<mu> \<noteq> Null \<longrightarrow> \<nu> \<bullet> \<mu> = \<nu>) \<and>
(\<mu> \<bullet> \<nu> \<noteq> Null \<longrightarrow> \<mu> \<bullet> \<nu> = \<nu>))"
using 0 V.ide_def null_char by simp
show \<mu>: "arrow_of_spans C \<mu>"
using 1 vcomp_def by metis
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> by auto
show "C.ide (Chn \<mu>)"
proof -
have "\<mu>.chine \<cdot> \<mu>.chine \<noteq> C.null"
using 1 vcomp_def
by (metis C.in_homE C.not_arr_null C.seqI \<mu>.chine_in_hom)
moreover have "\<And>f. f \<cdot> Chn \<mu> \<noteq> C.null \<Longrightarrow> f \<cdot> Chn \<mu> = f"
proof -
fix f
assume "f \<cdot> \<mu>.chine \<noteq> C.null"
hence f: "\<guillemotleft>f : \<mu>.cod.apex \<rightarrow> C.cod f\<guillemotright>"
using C.ext C.in_homI by force
let ?cod_\<mu> = "\<lparr>Chn = C.cod \<mu>.chine, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
interpret cod_\<mu>: arrow_of_spans C ?cod_\<mu>
using C.ide_in_hom \<mu>.cod.ide_apex \<mu>.chine_in_hom C.comp_arr_dom
by (unfold_locales, auto)
have "?cod_\<mu> \<bullet> \<mu> = ?cod_\<mu>"
proof -
have "?cod_\<mu> \<bullet> \<mu> \<noteq> Null"
unfolding vcomp_def
using \<mu> cod_\<mu>.arrow_of_spans_axioms \<mu>.cod.is_span C.comp_cod_arr
apply simp
using \<mu>.chine_simps(1) by force
thus ?thesis
using 1 by simp
qed
thus "f \<cdot> \<mu>.chine = f"
unfolding vcomp_def
using f C.comp_arr_ide C.comp_cod_arr \<mu>.arrow_of_spans_axioms
cod_\<mu>.arrow_of_spans_axioms
by auto
qed
moreover have "\<And>f. \<mu>.chine \<cdot> f \<noteq> C.null \<Longrightarrow> \<mu>.chine \<cdot> f = f"
proof -
fix f
assume "\<mu>.chine \<cdot> f \<noteq> C.null"
hence f: "\<guillemotleft>f : C.dom f \<rightarrow> \<mu>.dom.apex\<guillemotright>"
using C.ext C.in_homI by force
let ?dom_\<mu> = "\<lparr>Chn = C.cod f, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
using f C.ide_in_hom \<mu>.dom.ide_apex \<mu>.chine_in_hom C.comp_arr_dom
by (unfold_locales, auto)
have "\<mu> \<bullet> ?dom_\<mu> = ?dom_\<mu>"
proof -
have "\<mu> \<bullet> ?dom_\<mu> \<noteq> Null"
unfolding vcomp_def
using \<mu> dom_\<mu>.arrow_of_spans_axioms \<mu>.cod.is_span by (simp, force)
thus ?thesis
using 1 by simp
qed
hence "\<mu>.chine \<cdot> C.cod f = C.cod f"
unfolding vcomp_def
using \<mu> dom_\<mu>.arrow_of_spans_axioms f 0 C.comp_ide_arr C.comp_arr_ide
by simp
thus "\<mu>.chine \<cdot> f = f"
unfolding vcomp_def
using f C.comp_ide_arr C.comp_arr_dom \<mu>.arrow_of_spans_axioms
dom_\<mu>.arrow_of_spans_axioms
by auto
qed
ultimately show "C.ide \<mu>.chine"
unfolding C.ide_def by simp
qed
qed
show "arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>) \<Longrightarrow> V.ide \<mu>"
proof -
assume \<mu>: "arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> by auto
have 1: "Dom \<mu> = Cod \<mu>"
proof -
have "\<mu>.dom.leg0 = \<mu>.cod.leg0 \<and> \<mu>.dom.leg1 = \<mu>.cod.leg1"
using \<mu> C.comp_arr_ide \<mu>.cod.is_span by force
thus ?thesis by simp
qed
show "V.ide \<mu>"
proof -
have "\<mu> \<bullet> \<mu> \<noteq> V.null"
using \<mu> 1 vcomp_def by (simp add: C.ide_def null_char)
moreover have "\<And>\<nu>. vcomp \<nu> \<mu> \<noteq> V.null \<Longrightarrow> vcomp \<nu> \<mu> = \<nu>"
proof -
fix \<nu> :: "'a arrow_of_spans_data"
assume \<nu>: "\<nu> \<bullet> \<mu> \<noteq> V.null"
have 2: "arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
using \<nu> 1 vcomp_def by (metis V.comp_null(2))
interpret \<nu>: arrow_of_spans C \<nu>
using 2 by auto
show "\<nu> \<bullet> \<mu> = \<nu>"
unfolding vcomp_def
using \<mu> 1 2 C.comp_arr_ide by simp
qed
moreover have "\<And>\<nu>. \<mu> \<bullet> \<nu> \<noteq> V.null \<Longrightarrow> \<mu> \<bullet> \<nu> = \<nu>"
proof -
fix \<nu> :: "'a arrow_of_spans_data"
assume \<nu>: "\<mu> \<bullet> \<nu> \<noteq> V.null"
have 2: "arrow_of_spans C \<nu> \<and> Dom \<mu> = Cod \<nu>"
using \<nu> 1 vcomp_def by (metis V.comp_null(1))
interpret \<nu>: arrow_of_spans C \<nu>
using 2 by auto
show "\<mu> \<bullet> \<nu> = \<nu>"
unfolding vcomp_def
using \<mu> 1 2 C.comp_ide_arr by simp
qed
ultimately show ?thesis
unfolding V.ide_def by blast
qed
qed
qed
lemma has_domain_char:
shows "V.domains \<mu> \<noteq> {} \<longleftrightarrow> arrow_of_spans C \<mu>"
proof
show "V.domains \<mu> \<noteq> {} \<Longrightarrow> arrow_of_spans C \<mu>"
using V.domains_def null_char vcomp_def by fastforce
show "arrow_of_spans C \<mu> \<Longrightarrow> V.domains \<mu> \<noteq> {}"
proof -
assume \<mu>: "arrow_of_spans C \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> by auto
let ?dom_\<mu> = "\<lparr>Chn = \<mu>.dom.apex, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
using C.comp_arr_dom by (unfold_locales, auto)
have "?dom_\<mu> \<in> V.domains \<mu>"
proof -
have "V.ide ?dom_\<mu>"
using ide_char dom_\<mu>.arrow_of_spans_axioms by simp
moreover have "\<mu> \<bullet> ?dom_\<mu> \<noteq> V.null"
using \<mu> vcomp_def \<mu>.cod.span_in_category_axioms dom_\<mu>.arrow_of_spans_axioms
null_char span_in_category.leg_simps(1)
by fastforce
ultimately show ?thesis
unfolding V.domains_def by blast
qed
thus "V.domains \<mu> \<noteq> {}" by blast
qed
qed
lemma has_codomain_char:
shows "V.codomains \<mu> \<noteq> {} \<longleftrightarrow> arrow_of_spans C \<mu>"
proof
show "V.codomains \<mu> \<noteq> {} \<Longrightarrow> arrow_of_spans C \<mu>"
using V.codomains_def null_char vcomp_def by fastforce
show "arrow_of_spans C \<mu> \<Longrightarrow> V.codomains \<mu> \<noteq> {}"
proof -
assume \<mu>: "arrow_of_spans C \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> by auto
let ?cod_f = "\<lparr>Chn = \<mu>.cod.apex, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
interpret cod_f: arrow_of_spans C ?cod_f
using C.comp_arr_dom by (unfold_locales, auto)
have "?cod_f \<in> V.codomains \<mu>"
proof -
have "V.ide ?cod_f"
using ide_char cod_f.arrow_of_spans_axioms by simp
moreover have "?cod_f \<bullet> \<mu> \<noteq> V.null"
using \<mu> vcomp_def \<mu>.cod.span_in_category_axioms cod_f.arrow_of_spans_axioms
null_char span_in_category.leg_simps(1)
by fastforce
ultimately show ?thesis
unfolding V.codomains_def by blast
qed
thus "V.codomains \<mu> \<noteq> {}" by blast
qed
qed
lemma arr_char:
shows "V.arr \<mu> \<longleftrightarrow> arrow_of_spans C \<mu>"
unfolding V.arr_def
using has_domain_char has_codomain_char by simp
lemma seq_char:
shows "V.seq \<nu> \<mu> \<longleftrightarrow> arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
proof
show "V.seq \<nu> \<mu> \<Longrightarrow> arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
using vcomp_def by (metis V.not_arr_null null_char)
show "arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu> \<Longrightarrow> V.seq \<nu> \<mu>"
proof -
assume 1: "arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using 1 by auto
interpret \<nu>: arrow_of_spans C \<nu>
using 1 by auto
show "V.seq \<nu> \<mu>"
proof -
let ?\<nu>\<mu> = "\<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>"
have "\<nu> \<bullet> \<mu> = ?\<nu>\<mu>"
using 1 vcomp_def by metis
moreover have "V.arr ?\<nu>\<mu>"
proof -
interpret Dom: span_in_category C \<open>Dom ?\<nu>\<mu>\<close>
by (simp add: \<mu>.dom.span_in_category_axioms)
interpret Cod: span_in_category C \<open>Cod ?\<nu>\<mu>\<close>
by (simp add: \<nu>.cod.span_in_category_axioms)
have "arrow_of_spans C ?\<nu>\<mu>"
using 1 \<mu>.chine_in_hom \<nu>.chine_in_hom C.comp_reduce
by (unfold_locales, cases ?\<nu>\<mu>, auto)
thus ?thesis
using arr_char by blast
qed
ultimately show ?thesis by simp
qed
qed
qed
interpretation V: category vcomp
proof
show "\<And>\<mu>. (V.domains \<mu> \<noteq> {}) = (V.codomains \<mu> \<noteq> {})"
using has_domain_char has_codomain_char by simp
show "\<And>\<nu> \<mu>. \<nu> \<bullet> \<mu> \<noteq> V.null \<Longrightarrow> V.seq \<nu> \<mu>"
using seq_char vcomp_def null_char by metis
show "\<And>\<pi> \<nu> \<mu>. V.seq \<pi> \<nu> \<Longrightarrow> V.seq (\<pi> \<bullet> \<nu>) \<mu> \<Longrightarrow> V.seq \<nu> \<mu>"
using seq_char vcomp_def by (metis arrow_of_spans_data.select_convs(2))
show "\<And>\<pi> \<nu> \<mu>. V.seq \<pi> (\<nu> \<bullet> \<mu>) \<Longrightarrow> V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu>"
using seq_char vcomp_def by (metis arrow_of_spans_data.select_convs(3))
show "\<And>\<nu> \<mu> \<pi>. V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu> \<Longrightarrow> V.seq (\<pi> \<bullet> \<nu>) \<mu>"
using seq_char vcomp_def by (metis arr_char arrow_of_spans_data.select_convs(2))
show "\<And>\<nu> \<mu> \<pi>. V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu> \<Longrightarrow> (\<pi> \<bullet> \<nu>) \<bullet> \<mu> = \<pi> \<bullet> \<nu> \<bullet> \<mu>"
proof -
fix \<mu> \<nu> \<pi>
assume \<mu>\<nu>: "V.seq \<nu> \<mu>" and \<nu>\<pi>: "V.seq \<pi> \<nu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu>\<nu> seq_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using \<mu>\<nu> seq_char by auto
interpret \<pi>: arrow_of_spans C \<pi>
using \<nu>\<pi> seq_char by auto
show "(\<pi> \<bullet> \<nu>) \<bullet> \<mu> = \<pi> \<bullet> \<nu> \<bullet> \<mu>"
unfolding vcomp_def
using \<mu>\<nu> \<nu>\<pi> seq_char \<mu>.chine_in_hom \<nu>.chine_in_hom \<pi>.chine_in_hom
by (simp add: C.comp_assoc, metis arr_char vcomp_def)
qed
qed
lemma is_category:
shows "category vcomp"
..
lemma dom_char:
shows "V.dom = (\<lambda>\<mu>. if V.arr \<mu> then
\<lparr>Chn = span_in_category.apex C (Dom \<mu>), Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>
else V.null)"
proof
fix \<mu>
have "\<not> V.arr \<mu> \<Longrightarrow> V.dom \<mu> = V.null"
by (simp add: V.arr_def V.dom_def)
moreover have "V.arr \<mu> \<Longrightarrow> V.dom \<mu> = \<lparr>Chn = span_in_category.apex C (Dom \<mu>),
Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
proof (intro V.dom_eqI)
assume \<mu>: "V.arr \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> arr_char by auto
let ?dom_\<mu> = "\<lparr>Chn = \<mu>.dom.apex, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
using C.comp_arr_dom by (unfold_locales, auto)
show "V.ide ?dom_\<mu>"
using ide_char dom_\<mu>.arrow_of_spans_axioms by simp
thus "V.seq \<mu> ?dom_\<mu>"
using seq_char ide_char \<mu>.arrow_of_spans_axioms by simp
qed
ultimately show "V.dom \<mu> = (if V.arr \<mu> then
\<lparr>Chn = span_in_category.apex C (Dom \<mu>),
Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>
else V.null)"
by argo
qed
lemma cod_char:
shows "V.cod = (\<lambda>\<mu>. if V.arr \<mu> then
\<lparr>Chn = span_in_category.apex C (Cod \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>
else V.null)"
proof
fix \<mu>
have "\<not> V.arr \<mu> \<Longrightarrow> V.cod \<mu> = V.null"
by (simp add: V.arr_def V.cod_def)
moreover have "V.arr \<mu> \<Longrightarrow> V.cod \<mu> = \<lparr>Chn = span_in_category.apex C (Cod \<mu>),
Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
proof (intro V.cod_eqI)
assume \<mu>: "V.arr \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> arr_char by auto
let ?cod_\<mu> = "\<lparr>Chn = \<mu>.cod.apex, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
interpret cod_\<mu>: arrow_of_spans C ?cod_\<mu>
using C.comp_arr_dom by (unfold_locales, auto)
show "V.ide ?cod_\<mu>"
using ide_char cod_\<mu>.arrow_of_spans_axioms by simp
thus "V.seq ?cod_\<mu> \<mu>"
using seq_char ide_char \<mu>.arrow_of_spans_axioms by simp
qed
ultimately show "V.cod \<mu> = (if V.arr \<mu> then
\<lparr>Chn = span_in_category.apex C (Cod \<mu>),
Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>
else V.null)"
by argo
qed
lemma vcomp_char:
shows "vcomp = (\<lambda>\<nu> \<mu>. if V.seq \<nu> \<mu> then
\<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
else V.null)"
proof -
have "\<And>\<mu> \<nu>. \<nu> \<bullet> \<mu> = (if V.seq \<nu> \<mu> then
\<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
else V.null)"
using vcomp_def seq_char null_char by simp
thus ?thesis by auto
qed
lemma vcomp_eq:
assumes "V.seq \<nu> \<mu>"
shows "\<nu> \<bullet> \<mu> = \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>"
using assms vcomp_char by meson
lemma Chn_vcomp:
assumes "V.seq \<nu> \<mu>"
shows "Chn (\<nu> \<bullet> \<mu>) = Chn \<nu> \<cdot> Chn \<mu>"
using assms vcomp_eq [of \<nu> \<mu>] by simp
lemma ide_char':
shows "V.ide \<mu> \<longleftrightarrow> identity_arrow_of_spans C \<mu>"
using arr_char ide_char identity_arrow_of_spans_axioms_def identity_arrow_of_spans_def
identity_arrow_of_spans.axioms(1) identity_arrow_of_spans.chine_is_identity
by metis
lemma Chn_in_hom:
assumes "V.in_hom \<tau> f g"
shows "C.in_hom (Chn \<tau>) (Chn f) (Chn g)"
using assms ide_char arr_char dom_char cod_char
by (metis (no_types, lifting) C.ide_char arrow_of_spans.chine_in_hom
arrow_of_spans.chine_simps(3) arrow_of_spans_data.simps(3) V.ide_cod
V.ide_dom V.in_homE)
abbreviation mkIde
where "mkIde f0 f1 \<equiv>
\<lparr>Chn = C.dom f0, Dom = \<lparr>Leg0 = f0, Leg1 = f1\<rparr>, Cod = \<lparr>Leg0 = f0, Leg1 = f1\<rparr>\<rparr>"
lemma ide_mkIde:
assumes "C.span f0 f1"
shows "V.ide (mkIde f0 f1)"
proof -
interpret f: span_in_category C \<open>\<lparr>Leg0 = f0, Leg1 = f1\<rparr>\<close>
using assms by (unfold_locales, auto)
interpret ff: arrow_of_spans C \<open>mkIde f0 f1\<close>
using assms f.apex_def C.comp_arr_dom
by (unfold_locales, auto)
show ?thesis
using assms ff.arrow_of_spans_axioms ide_char by simp
qed
abbreviation mkObj
where "mkObj a \<equiv> mkIde a a"
lemma ide_mkObj:
assumes "C.ide a"
shows "V.ide (mkObj a)"
using assms ide_mkIde [of a a] by auto
lemma inverse_arrows:
assumes "V.arr \<mu>" and "C.iso (Chn \<mu>)"
shows "V.inverse_arrows \<mu> \<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
let ?\<nu> = "\<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
interpret \<nu>: arrow_of_spans C ?\<nu>
using assms C.invert_side_of_triangle(2) [of \<mu>.dom.leg0 \<mu>.cod.leg0 \<mu>.chine]
C.invert_side_of_triangle(2) [of \<mu>.dom.leg1 \<mu>.cod.leg1 \<mu>.chine]
by (unfold_locales, auto)
show "V.inverse_arrows \<mu> ?\<nu>"
proof
show "V.ide (?\<nu> \<bullet> \<mu>)"
proof -
have 1: "V.seq ?\<nu> \<mu>"
using arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
\<nu>.arrow_of_spans_axioms
by (intro V.seqI', auto)
have 2: "?\<nu> \<bullet> \<mu> = \<lparr>Chn = C.inv (Chn \<mu>) \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
using 1 arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
\<nu>.arrow_of_spans_axioms
by simp
moreover have
"V.ide \<lparr>Chn = C.inv (Chn \<mu>) \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
using assms 1 2 arr_char ide_char by (simp add: C.comp_inv_arr')
ultimately show ?thesis by simp
qed
show "V.ide (\<mu> \<bullet> ?\<nu>)"
proof -
have 1: "V.seq \<mu> ?\<nu>"
using arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
\<nu>.arrow_of_spans_axioms
by (intro V.seqI', auto)
have 2: "\<mu> \<bullet> ?\<nu> = \<lparr>Chn = Chn \<mu> \<cdot> C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
using 1 arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
\<nu>.arrow_of_spans_axioms
by simp
moreover have "V.ide \<lparr>Chn = Chn \<mu> \<cdot> C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
using assms 1 2 arr_char ide_char by (simp add: C.comp_arr_inv')
ultimately show ?thesis by simp
qed
qed
qed
lemma iso_char:
shows "V.iso \<mu> \<longleftrightarrow> V.arr \<mu> \<and> C.iso (Chn \<mu>)"
proof
show "V.iso \<mu> \<Longrightarrow> V.arr \<mu> \<and> C.iso (Chn \<mu>)"
using vcomp_eq ide_char
by (metis C.iso_iff_section_and_retraction C.retractionI C.sectionI Chn_vcomp
V.arr_cod V.arr_dom V.comp_arr_inv' V.comp_inv_arr' V.ide_cod V.ide_dom
V.iso_is_arr)
show "V.arr \<mu> \<and> C.iso (Chn \<mu>) \<Longrightarrow> V.iso \<mu>"
using inverse_arrows by auto
qed
lemma inv_eq:
assumes "V.iso \<mu>"
shows "V.inv \<mu> = \<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
using assms inverse_arrows iso_char by (simp add: V.inverse_unique)
end
subsection "Putting Spans in Homs"
context span_vertical_category
begin
interpretation V: category vcomp
using is_category by simp
definition src
where "src \<mu> \<equiv> if V.arr \<mu> then mkObj (C.cod (Leg0 (Dom \<mu>))) else V.null"
lemma ide_src [simp]:
assumes "V.arr \<mu>"
shows "V.ide (src \<mu>)"
using assms src_def arr_char ide_mkObj C.ide_cod
by (simp add: arrow_of_spans_def span_in_category.leg_simps(1))
interpretation src: endofunctor vcomp src
proof
show "\<And>\<mu>. \<not> V.arr \<mu> \<Longrightarrow> src \<mu> = V.null"
using arr_char by (simp add: src_def null_char)
show 1: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.arr (src \<mu>)"
using ide_src by simp
show 2: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.dom (src \<mu>) = src (V.dom \<mu>)"
using 1 arr_char src_def dom_char ide_src V.arr_dom V.ideD(2) by force
show 3: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.cod (src \<mu>) = src (V.cod \<mu>)"
using 1 arr_char src_def cod_char ide_src V.arr_cod V.ideD(3)
arrow_of_spans.cod_src_eq_dom_src
by force
show "\<And>\<mu> \<nu>. V.seq \<nu> \<mu> \<Longrightarrow> src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
proof -
fix \<mu> \<nu>
assume \<mu>\<nu>: "V.seq \<nu> \<mu>"
show "src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
proof -
have "src (\<nu> \<bullet> \<mu>) = mkObj (C.cod (Leg0 (Dom \<mu>)))"
using \<mu>\<nu> src_def vcomp_def
apply simp
using V.not_arr_null null_char by auto
also have
"... = \<lparr>Chn = C.dom (C.cod (Leg0 (Dom \<mu>))) \<cdot> C.dom (C.cod (Leg0 (Dom \<mu>))),
Dom = \<lparr>Leg0 = C.cod (Leg0 (Dom \<mu>)), Leg1 = C.cod (Leg0 (Dom \<mu>))\<rparr>,
Cod = \<lparr>Leg0 = C.cod (Leg0 (Dom \<mu>)), Leg1 = C.cod (Leg0 (Dom \<mu>))\<rparr>\<rparr>"
using \<mu>\<nu> 1
by (simp add: arrow_of_spans_def seq_char span_in_category.leg_simps(1))
also have "... = src \<nu> \<bullet> src \<mu>"
using \<mu>\<nu> 1 src_def vcomp_def
apply (elim V.seqE, simp)
by (metis \<mu>\<nu> arrow_of_spans.cod_src_eq_dom_src ide_char seq_char ide_src)
finally show ?thesis by blast
qed
qed
qed
lemma src_is_endofunctor:
shows "endofunctor vcomp src"
..
lemma src_vcomp:
assumes "V.seq \<nu> \<mu>"
shows "src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
using assms src.preserves_comp by simp
definition trg
where "trg \<mu> \<equiv> if V.arr \<mu> then mkObj (C.cod (Leg1 (Dom \<mu>))) else V.null"
lemma ide_trg [simp]:
assumes "V.arr \<mu>"
shows "V.ide (trg \<mu>)"
using assms trg_def arr_char ide_mkObj C.ide_cod
by (simp add: arrow_of_spans_def span_in_category.leg_simps(3))
interpretation trg: endofunctor vcomp trg
proof
show "\<And>\<mu>. \<not> V.arr \<mu> \<Longrightarrow> trg \<mu> = V.null"
using arr_char by (simp add: trg_def null_char)
show 1: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.arr (trg \<mu>)"
using ide_trg by simp
show 2: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.dom (trg \<mu>) = trg (V.dom \<mu>)"
using 1 arr_char trg_def dom_char ide_trg V.arr_dom V.ideD(2) by force
show 3: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.cod (trg \<mu>) = trg (V.cod \<mu>)"
using 1 arr_char trg_def cod_char ide_trg V.arr_cod V.ideD(3)
arrow_of_spans.cod_trg_eq_dom_trg
by force
show "\<And>\<mu> \<nu>. V.seq \<nu> \<mu> \<Longrightarrow> trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
proof -
fix \<mu> \<nu>
assume \<mu>\<nu>: "V.seq \<nu> \<mu>"
show "trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
proof -
have "trg (\<nu> \<bullet> \<mu>) = mkObj (C.cod (Leg1 (Dom \<mu>)))"
using \<mu>\<nu> trg_def vcomp_def
apply simp
using V.not_arr_null null_char by auto
also have "... = \<lparr>Chn = Chn (trg \<nu>) \<cdot> Chn (trg \<mu>),
Dom = Dom (trg \<mu>), Cod = Cod (trg \<nu>)\<rparr>"
using \<mu>\<nu> 1 trg_def vcomp_def
apply (elim V.seqE, simp)
by (metis C.ide_def \<mu>\<nu> arrow_of_spans.cod_trg_eq_dom_trg select_convs(1) ide_char
ide_trg seq_char)
also have "... = trg \<nu> \<bullet> trg \<mu>"
using \<mu>\<nu> 1 src_def vcomp_def
apply (elim V.seqE, simp)
by (metis "2" "3" V.ideD(2) V.ideD(3) select_convs(2) select_convs(3) ide_char
ide_trg trg_def)
finally show ?thesis by blast
qed
qed
qed
lemma trg_is_endofunctor:
shows "endofunctor vcomp trg"
..
lemma trg_vcomp:
assumes "V.seq \<nu> \<mu>"
shows "trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
using assms trg.preserves_comp by simp
lemma src_trg_simps [simp]:
assumes "V.arr \<mu>"
shows "src (src \<mu>) = src \<mu>"
and "src (trg \<mu>) = trg \<mu>"
and "trg (src \<mu>) = src \<mu>"
and "trg (trg \<mu>) = trg \<mu>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
have 1: "V.arr \<lparr>Chn = \<mu>.dsrc, Dom = \<lparr>Leg0 = \<mu>.dsrc, Leg1 = \<mu>.dsrc\<rparr>,
Cod = \<lparr>Leg0 = \<mu>.dsrc, Leg1 = \<mu>.dsrc\<rparr>\<rparr>"
using ide_mkObj by auto
have 2: "V.arr \<lparr>Chn = \<mu>.dtrg, Dom = \<lparr>Leg0 = \<mu>.dtrg, Leg1 = \<mu>.dtrg\<rparr>,
Cod = \<lparr>Leg0 = \<mu>.dtrg, Leg1 = \<mu>.dtrg\<rparr>\<rparr>"
using ide_mkObj by auto
show "src (src \<mu>) = src \<mu>"
using assms 1 src_def by simp
show "trg (src \<mu>) = src \<mu>"
using assms 1 src_def trg_def by simp
show "src (trg \<mu>) = trg \<mu>"
using assms 2 src_def trg_def by simp
show "trg (trg \<mu>) = trg \<mu>"
using assms 2 trg_def by simp
qed
sublocale horizontal_homs vcomp src trg
by (unfold_locales, simp_all)
lemma has_horizontal_homs:
shows "horizontal_homs vcomp src trg"
..
lemma obj_char:
shows "obj a \<longleftrightarrow> V.ide a \<and> a = mkObj (Chn a)"
proof
show "obj a \<Longrightarrow> V.ide a \<and> a = mkObj (Chn a)"
proof
assume a: "obj a"
show 1: "V.ide a"
using a by auto
show "a = mkObj (Chn a)"
using a 1 obj_def src_def ide_char
apply simp
by (metis arrow_of_spans_data.select_convs(1) arrow_of_spans_def category.dom_cod
span_in_category.is_span)
qed
show "V.ide a \<and> a = mkObj (Chn a) \<Longrightarrow> obj a"
proof -
assume a: "V.ide a \<and> a = mkObj (Chn a)"
show "obj a"
unfolding obj_def src_def
using a
apply simp
by (metis C.ide_char arrow_of_spans_data.select_convs(2) ide_char
span_data.select_convs(1))
qed
qed
end
subsection "Horizontal Composite of Spans"
text \<open>
We now define the horizontal composite \<open>S \<star> T\<close> of spans \<open>S\<close> and \<open>T\<close>,
assuming that \<open>C\<close> is a category with chosen pullbacks.
We think of Leg0 as an input and Leg1 as an output.
The following then defines the composite span \<open>S \<star> T\<close>, with \<open>T\<close> on the ``input side'' of \<open>S\<close>.
The notation is such that the \<open>\<p>\<^sub>0\<close> projections of \<open>C\<close> are used for legs on the input
(\emph{i.e.} the ``0'') side and the \<open>\<p>\<^sub>1\<close> projections are used for legs on the output
(\emph{i.e.} the ``1'') side.
\<close>
locale composite_span =
C: elementary_category_with_pullbacks +
S: span_in_category C S +
T: span_in_category C T
for S (structure)
and T (structure) +
assumes composable: "C.cod (Leg0 S) = C.cod (Leg1 T)"
begin
abbreviation this
where "this \<equiv> \<lparr>Leg0 = T.leg0 \<cdot> \<p>\<^sub>0[S.leg0, T.leg1], Leg1 = S.leg1 \<cdot> \<p>\<^sub>1[S.leg0, T.leg1]\<rparr>"
lemma leg0_prj_in_hom:
shows "\<guillemotleft>T.leg0 \<cdot> \<p>\<^sub>0[S.leg0, T.leg1] : S.leg0 \<down>\<down> T.leg1 \<rightarrow> C.cod (Leg0 T)\<guillemotright>"
using S.is_span T.is_span C.prj0_in_hom [of "Leg0 S" "Leg1 T"] composable by auto
lemma leg1_prj_in_hom:
shows "\<guillemotleft>S.leg1 \<cdot> \<p>\<^sub>1[S.leg0, T.leg1] : S.leg0 \<down>\<down> T.leg1 \<rightarrow> C.cod (Leg1 S)\<guillemotright>"
using S.is_span T.is_span C.prj1_in_hom [of "Leg0 S" "Leg1 T"] composable by auto
lemma is_span [simp]:
shows "span_in_category C this"
using leg0_prj_in_hom leg1_prj_in_hom
by (unfold_locales, fastforce)
sublocale span_in_category C this
using is_span by auto
end
locale span_bicategory =
C: elementary_category_with_pullbacks +
span_vertical_category
begin
definition chine_hcomp
where "chine_hcomp \<nu> \<mu> \<equiv>
\<langle>Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]
\<lbrakk>Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)\<rbrakk>
Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]\<rangle>"
text \<open>
$$\xymatrix{
& & \scriptstyle{{\rm src}({\rm Dom}~\nu)} \;=\; {{\rm trg}({\rm Dom}~\mu)} & &\\
&
\ar[ddl] _{{\rm Leg1}({\rm Dom}~\nu)}
\ar [ur] ^<>(0.4){{\rm Leg0}({\rm Dom}~\nu)\hspace{20pt}}
\ar[dddd] ^{{\rm Chn}~\nu}
&
&
\ar[ul] _<>(0.4){\hspace{20pt}{\rm Leg1}({\rm Dom}~\mu)}
\ar[ddr] ^{{\rm Leg0}({\rm Dom}~\mu)}
\ar[dddd] _{{\rm Chn}~\mu}
\\
& &
\ar[ul] ^{p_1}
\ar[ur] _{p_0}
\ar@ {.>}[dd]^<>(0.3){{\rm chn\_hcomp~\mu~\nu}}
\\
\scriptstyle{{\rm trg}~\nu} & & & & \scriptstyle{{\rm src}~\mu} \\
& &
\ar[dl] _{p_1}
\ar[dr] ^{p_0}
& &
\\
&
\ar[uul] ^{{\rm Leg1}({\rm Cod}~\nu)}
\ar[dr] _<>(0.4){{\rm Leg1}({\rm Cod}~\nu)\hspace{20pt}}
& &
\ar[dl] ^<>(0.4){\hspace{20pt}{\rm Leg1}({\rm Cod}~\mu)}
\ar[uur] _{{\rm Leg0}({\rm Cod}~\mu)}
\\
& & \scriptstyle{{\rm src}({\rm Cod}~\nu)} \;=\; {{\rm trg}({\rm Cod}~\mu)} & &
}$$
\<close>
definition hcomp
where "hcomp \<nu> \<mu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu> then
\<lparr>Chn = chine_hcomp \<nu> \<mu>,
Dom = composite_span.this C prj0 prj1 (Dom \<nu>) (Dom \<mu>),
Cod = composite_span.this C prj0 prj1 (Cod \<nu>) (Cod \<mu>)\<rparr>
else
null"
notation hcomp (infixr "\<star>" 53)
lemma chine_hcomp_props:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "\<guillemotleft>chine_hcomp \<nu> \<mu> :
Leg0 (Dom \<nu>) \<down>\<down> Leg1 (Dom \<mu>) \<rightarrow> Leg0 (Cod \<nu>) \<down>\<down> Leg1 (Cod \<mu>)\<guillemotright>"
and "C.commutative_square (Leg0 (Cod \<nu>)) (Leg1 (Cod \<mu>))
(Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)])
(Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)])"
and "C.commutative_square \<p>\<^sub>1[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] (Chn \<nu>)
(chine_hcomp \<nu> \<mu>) \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
and "C.commutative_square \<p>\<^sub>0[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] (Chn \<mu>)
(chine_hcomp \<nu> \<mu>) \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
and "\<p>\<^sub>0[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] \<cdot> chine_hcomp \<nu> \<mu> =
Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
and "\<p>\<^sub>1[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] \<cdot> chine_hcomp \<nu> \<mu> =
Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using assms arr_char by auto
show 0: "C.commutative_square \<nu>.cod.leg0 \<mu>.cod.leg1
(\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]) (\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
using assms src_def trg_def C.pullback_commutes C.comp_reduce C.commutative_square_def
by auto
show 1: "\<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu> = \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
unfolding chine_hcomp_def
using 0 by simp
show 2: "\<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu> = \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
unfolding chine_hcomp_def
using 0 by simp
show 3: "\<guillemotleft>chine_hcomp \<nu> \<mu> : \<nu>.dom.leg0 \<down>\<down> \<mu>.dom.leg1 \<rightarrow> \<nu>.cod.leg0 \<down>\<down> \<mu>.cod.leg1\<guillemotright>"
unfolding chine_hcomp_def
using assms 0 src_def trg_def C.tuple_in_hom by auto
show "C.commutative_square \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<nu>.chine
(chine_hcomp \<nu> \<mu>) \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms src_def trg_def 1 3 by auto
show "C.commutative_square \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<mu>.chine
(chine_hcomp \<nu> \<mu>) \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms src_def trg_def 2 3 by auto
qed
lemma chine_hcomp_in_hom [intro]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "\<guillemotleft>chine_hcomp \<nu> \<mu> :
Leg0 (Dom \<nu>) \<down>\<down> Leg1 (Dom \<mu>) \<rightarrow> Leg0 (Cod \<nu>) \<down>\<down> Leg1 (Cod \<mu>)\<guillemotright>"
using assms chine_hcomp_props(1) by simp
lemma arrow_of_spans_hcomp:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "arrow_of_spans C (\<nu> \<star> \<mu>)"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using assms arr_char by auto
show ?thesis
proof
show span_Dom: "C.span (Leg0 (Dom (\<nu> \<star> \<mu>))) (Leg1 (Dom (\<nu> \<star> \<mu>)))"
using assms src_def trg_def hcomp_def C.seqI' by auto
interpret Dom: span_in_category C \<open>Dom (\<nu> \<star> \<mu>)\<close>
using span_Dom by (unfold_locales, auto)
show span_Cod: "C.span (Leg0 (Cod (\<nu> \<star> \<mu>))) (Leg1 (Cod (\<nu> \<star> \<mu>)))"
using assms hcomp_def src_def trg_def by auto
interpret Cod: span_in_category C \<open>Cod (\<nu> \<star> \<mu>)\<close>
using span_Cod by (unfold_locales, auto)
show map: "\<guillemotleft>Chn (\<nu> \<star> \<mu>) : Dom.apex \<rightarrow> Cod.apex\<guillemotright>"
using assms src_def trg_def chine_hcomp_props hcomp_def Cod.apex_def Dom.apex_def
by auto
show "Cod.leg0 \<cdot> Chn (\<nu> \<star> \<mu>) = Dom.leg0"
proof -
have "(\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
\<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
proof -
have "(\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu>"
using assms
by (metis (full_types) C.category_axioms C.comp_reduce C.dom_comp C.match_2
C.seqE C.seqI category.ext)
also have "... = \<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms src_def trg_def
by (simp add: chine_hcomp_def chine_hcomp_props(2))
also have "... = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms \<mu>.leg0_commutes C.comp_reduce
by (metis (mono_tags, lifting) C.commutative_squareE \<mu>.dom.leg_simps(1)
chine_hcomp_props(2))
finally show ?thesis by simp
qed
thus ?thesis
using assms src_def trg_def hcomp_def chine_hcomp_props \<mu>.chine_in_hom C.comp_reduce
by auto
qed
show "Cod.leg1 \<cdot> Chn (\<nu> \<star> \<mu>) = Dom.leg1"
proof -
have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
\<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
proof -
have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu>"
using assms
by (metis (full_types) C.category_axioms C.comp_reduce C.dom_comp C.match_2
C.seqE C.seqI category.ext)
also have "... = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms src_def trg_def
by (simp add: chine_hcomp_def chine_hcomp_props(2))
also have "... = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms \<nu>.leg1_commutes C.comp_reduce
by (metis (mono_tags, lifting) C.commutative_squareE \<nu>.dom.leg_simps(3)
chine_hcomp_props(2))
finally show ?thesis by blast
qed
thus ?thesis
using assms src_def trg_def hcomp_def chine_hcomp_props \<nu>.chine_in_hom C.comp_reduce
by auto
qed
qed
qed
lemma chine_hcomp_ide_arr:
assumes "ide f" and "arr \<mu>" and "src f = trg \<mu>"
shows "chine_hcomp f \<mu> =
\<langle>\<p>\<^sub>1[Leg0 (Dom f), Leg1 (Dom \<mu>)]
\<lbrakk>Leg0 (Cod f), Leg1 (Cod \<mu>)\<rbrakk>
Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom f), Leg1 (Dom \<mu>)]\<rangle>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret f: arrow_of_spans C f
using assms ide_char by auto
have 1: "C.cospan f.dom.leg0 \<mu>.dom.leg1"
using assms src_def trg_def by auto
have "chine_hcomp f \<mu> = \<langle>f.chine \<cdot> \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1]
\<lbrakk>f.cod.leg0, \<mu>.cod.leg1\<rbrakk>
\<mu>.chine \<cdot> \<p>\<^sub>0[f.dom.leg0, \<mu>.dom.leg1]\<rangle>"
unfolding chine_hcomp_def
using assms ide_char by simp
moreover have "f.chine \<cdot> \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1] = \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1]"
using assms 1 C.comp_ide_arr ide_char by auto
ultimately show ?thesis by argo
qed
lemma chine_hcomp_arr_ide:
assumes "arr \<mu>" and "ide f" and "src \<mu> = trg f"
shows "chine_hcomp \<mu> f =
\<langle>Chn \<mu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<mu>), Leg1 (Dom f)]
\<lbrakk>Leg0 (Cod \<mu>), Leg1 (Cod f)\<rbrakk>
\<p>\<^sub>0[Leg0 (Dom \<mu>), Leg1 (Dom f)]\<rangle>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret f: arrow_of_spans C f
using assms ide_char by auto
have 1: "C.cospan \<mu>.dom.leg0 f.dom.leg1"
using assms src_def trg_def by auto
have "chine_hcomp \<mu> f = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, f.dom.leg1]
\<lbrakk>\<mu>.cod.leg0, f.cod.leg1\<rbrakk>
f.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1]\<rangle>"
unfolding chine_hcomp_def
using assms ide_char by simp
moreover have "f.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1] = \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1]"
using assms 1 C.comp_ide_arr ide_char by auto
ultimately show ?thesis by argo
qed
lemma chine_hcomp_ide_ide:
assumes "ide g" and "ide f" and "src g = trg f"
shows "chine_hcomp g f = Leg0 (Dom g) \<down>\<down> Leg1 (Dom f)"
proof -
interpret g: identity_arrow_of_spans C g
using assms ide_char' by auto
interpret f: identity_arrow_of_spans C f
using assms ide_char' by auto
have 1: "C.cospan g.dom.leg0 f.dom.leg1"
using assms src_def trg_def by auto
have "chine_hcomp g f = \<langle>g.chine \<cdot> \<p>\<^sub>1[g.dom.leg0, f.dom.leg1]
\<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
\<p>\<^sub>0[g.dom.leg0, f.dom.leg1]\<rangle>"
using assms chine_hcomp_arr_ide by simp
moreover have "g.chine \<cdot> \<p>\<^sub>1[g.dom.leg0, f.dom.leg1] = \<p>\<^sub>1[g.dom.leg0, f.dom.leg1]"
using assms 1 C.comp_ide_arr ide_char by auto
ultimately have "chine_hcomp g f = \<langle>\<p>\<^sub>1[g.dom.leg0, f.dom.leg1]
\<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
\<p>\<^sub>0[g.dom.leg0, f.dom.leg1]\<rangle>"
by simp
also have "... =
\<langle>\<p>\<^sub>1[g.dom.leg0, f.dom.leg1] \<cdot> (g.dom.leg0 \<down>\<down> f.dom.leg1)
\<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
\<p>\<^sub>0[g.dom.leg0, f.dom.leg1] \<cdot> (g.dom.leg0 \<down>\<down> f.dom.leg1)\<rangle>"
using assms 1 C.comp_arr_dom by simp
also have "... = g.dom.leg0 \<down>\<down> f.dom.leg1"
using 1 C.pullback_commutes C.tuple_prj by simp
finally show ?thesis by simp
qed
lemma chine_hcomp_trg_arr:
assumes "arr \<mu>"
shows "chine_hcomp (trg \<mu>) \<mu> =
\<langle>\<p>\<^sub>1[C.cod (Leg1 (Dom \<mu>)), Leg1 (Dom \<mu>)]
\<lbrakk>C.cod (Leg1 (Dom \<mu>)), Leg1 (Cod \<mu>)\<rbrakk>
Chn \<mu> \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom \<mu>)), Leg1 (Dom \<mu>)]\<rangle>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret trg_\<mu>: arrow_of_spans C \<open>trg \<mu>\<close>
using assms ide_trg ide_char by simp
have "trg_\<mu>.dom.leg0 = C.cod \<mu>.dom.leg1 \<and> trg_\<mu>.cod.leg0 = C.cod \<mu>.dom.leg1 \<and>
trg_\<mu>.dom.leg0 = C.cod \<mu>.dom.leg1"
using assms ide_char src_def trg_def by simp
thus ?thesis
using assms chine_hcomp_ide_arr [of "trg \<mu>" \<mu>] by auto
qed
lemma chine_hcomp_trg_ide:
assumes "ide f"
shows "chine_hcomp (trg f) f = C.cod (Leg1 (Dom f)) \<down>\<down> Leg1 (Dom f)"
proof -
interpret f: arrow_of_spans C f
using assms arr_char by auto
interpret trg_f: arrow_of_spans C \<open>trg f\<close>
using assms ide_trg ide_char by simp
have "trg_f.dom.leg0 = C.cod f.dom.leg1"
using assms trg_def by simp
thus ?thesis
using assms chine_hcomp_ide_ide [of "trg f" f] by auto
qed
lemma chine_hcomp_arr_src:
assumes "arr \<mu>"
shows "chine_hcomp \<mu> (src \<mu>) =
\<langle>Chn \<mu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<mu>), C.cod (Leg0 (Dom \<mu>))]
\<lbrakk>Leg0 (Cod \<mu>), C.cod (Leg0 (Dom \<mu>))\<rbrakk>
\<p>\<^sub>0[Leg0 (Dom \<mu>), C.cod (Leg0 (Dom \<mu>))]\<rangle>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret src_\<mu>: arrow_of_spans C \<open>src \<mu>\<close>
using assms ide_src ide_char by simp
have "src_\<mu>.dom.leg1 = \<mu>.dsrc \<and> src_\<mu>.cod.leg1 = \<mu>.dsrc"
using assms ide_char src_def trg_def by simp
thus ?thesis
using assms chine_hcomp_arr_ide by auto
qed
lemma chine_hcomp_ide_src:
assumes "ide f"
shows "chine_hcomp f (src f) = Leg0 (Dom f) \<down>\<down> C.cod (Leg0 (Dom f))"
proof -
interpret f: arrow_of_spans C f
using assms arr_char by auto
interpret src_f: arrow_of_spans C \<open>src f\<close>
using assms ide_src ide_char by simp
have "C.cod f.dom.leg0 = src_f.dom.leg1"
using assms src_def by simp
thus ?thesis
using assms chine_hcomp_ide_ide by auto
qed
lemma src_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "src (\<nu> \<star> \<mu>) = src \<mu>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using assms arr_char by auto
have "C.cod (\<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]) = C.cod \<mu>.dom.leg0"
using assms C.commutative_squareE chine_hcomp_props(2)
by (metis (mono_tags, lifting) C.cod_comp C.match_3 \<mu>.leg0_commutes \<mu>.dom.is_span)
thus ?thesis
using assms arr_char hcomp_def src_def C.comp_cod_arr C.comp_arr_dom arrow_of_spans_hcomp
by simp
qed
lemma trg_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "trg (\<nu> \<star> \<mu>) = trg \<nu>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using assms arr_char by auto
have "C.cod (\<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]) = \<nu>.dtrg"
using assms C.commutative_squareE chine_hcomp_props(2)
by (metis (mono_tags, lifting) C.cod_comp C.match_3 \<nu>.leg1_commutes \<nu>.dom.is_span)
thus ?thesis
using assms arr_char hcomp_def trg_def C.comp_cod_arr C.comp_arr_dom arrow_of_spans_hcomp
by simp
qed
lemma dom_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using assms arr_char by auto
interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
using assms arr_char arrow_of_spans_hcomp by simp
have 1: "C.cospan \<mu>.dom.leg1 \<nu>.dom.leg0"
using assms \<mu>.dom.is_span \<nu>.dom.is_span src_def trg_def by auto
have "dom (\<nu> \<star> \<mu>) =
\<lparr>Chn = \<nu>.dom.leg0 \<down>\<down> \<mu>.dom.leg1,
Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>\<rparr>"
using assms \<nu>\<mu>.arrow_of_spans_axioms \<nu>\<mu>.dom.leg_simps(2) \<nu>\<mu>.dom.is_span
arr_char dom_char hcomp_def
by auto
also have "... =
\<lparr>Chn = chine_hcomp (dom \<nu>) (dom \<mu>),
Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>\<rparr>"
using assms src_dom trg_dom ide_dom dom_char chine_hcomp_ide_ide by auto
also have "... = dom \<nu> \<star> dom \<mu>"
using assms src_dom trg_dom arr_dom dom_char hcomp_def by auto
finally show ?thesis by blast
qed
lemma cod_hcomp [simp]:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
shows "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
proof -
interpret \<mu>: arrow_of_spans C \<mu>
using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu>
using assms arr_char by auto
interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
using assms arr_char arrow_of_spans_hcomp by simp
have 1: "C.cospan \<mu>.cod.leg1 \<nu>.cod.leg0"
using assms \<mu>.cod.is_span \<nu>.cod.is_span src_def trg_def by simp
have 2: "cod (\<nu> \<star> \<mu>) =
\<lparr>Chn = \<nu>.cod.leg0 \<down>\<down> \<mu>.cod.leg1,
Dom = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>\<rparr>"
using assms \<nu>\<mu>.arrow_of_spans_axioms \<nu>\<mu>.cod.leg_simps(2) \<nu>\<mu>.cod.is_span
arr_char cod_char hcomp_def
by auto
also have "... =
\<lparr>Chn = chine_hcomp (cod \<nu>) (cod \<mu>),
Dom = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>\<rparr>"
using assms src_cod trg_cod ide_cod cod_char chine_hcomp_ide_ide by auto
also have "... = cod \<nu> \<star> cod \<mu>"
using assms src_cod trg_cod arr_cod cod_char hcomp_def by auto
finally show ?thesis by simp
qed
lemma hcomp_vcomp:
assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
and "arr \<mu>'" and "arr \<nu>'" and "src \<nu>' = trg \<mu>'"
and "seq \<mu>' \<mu>" and "seq \<nu>' \<nu>"
shows "(\<nu>' \<bullet> \<nu>) \<star> (\<mu>' \<bullet> \<mu>) = (\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>)"
proof -
interpret \<mu>: arrow_of_spans C \<mu> using assms arr_char by auto
interpret \<nu>: arrow_of_spans C \<nu> using assms arr_char by auto
interpret \<mu>': arrow_of_spans C \<mu>' using assms arr_char by auto
interpret \<nu>': arrow_of_spans C \<nu>' using assms arr_char by auto
interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
using assms arr_char arrow_of_spans_hcomp by auto
interpret \<nu>'\<mu>': arrow_of_spans C \<open>hcomp \<nu>' \<mu>'\<close>
using assms arr_char arrow_of_spans_hcomp by auto
have 1: "Dom \<nu>' = Cod \<nu> \<and> Dom \<mu>' = Cod \<mu>"
using assms src_def trg_def seq_char by blast
have 2: "Dom (\<mu>' \<bullet> \<mu>) = Dom \<mu> \<and> Dom (\<nu>' \<bullet> \<nu>) = Dom \<nu> \<and>
Cod (\<mu>' \<bullet> \<mu>) = Cod \<mu>' \<and> Cod (\<nu>' \<bullet> \<nu>) = Cod \<nu>'"
using assms seq_char arr_char vcomp_def
by (metis arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
have 3: "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
\<langle>Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]
\<lbrakk>\<nu>'.cod.leg0, \<mu>'.cod.leg1\<rbrakk>
Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rangle>"
unfolding chine_hcomp_def using 2 by simp
have C1: "C.commutative_square \<nu>'.cod.leg0 \<mu>'.cod.leg1
(Chn \<nu>' \<cdot> \<p>\<^sub>1[\<nu>'.dom.leg0, \<mu>'.dom.leg1])
(Chn \<mu>' \<cdot> \<p>\<^sub>0[\<nu>'.dom.leg0, \<mu>'.dom.leg1])"
using assms 1 vcomp_def seq_char arr_char chine_hcomp_props(2) by blast
have C2: "C.commutative_square \<nu>'.cod.leg0 \<mu>'.cod.leg1
(Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
(Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
(* using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2) src_vcomp trg_vcomp
by smt *)
proof
show 3: "C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1"
using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
src_vcomp trg_vcomp
by (meson C.commutative_squareE)
show 4: "C.span (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
(Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
using assms 1 2 3 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
src_vcomp trg_vcomp
by simp
show "C.dom \<nu>'.cod.leg0 = C.cod (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])"
using assms 1 2 4 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
src_vcomp trg_vcomp
by simp
show "\<nu>'.cod.leg0 \<cdot> Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1] =
\<mu>'.cod.leg1 \<cdot> Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
src_vcomp trg_vcomp
by (metis (mono_tags, lifting) C.comp_assoc C.pullback_commutes' Chn_vcomp
\<mu>'.cod_trg_eq_dom_trg \<mu>'.leg1_commutes \<mu>.cod_trg_eq_dom_trg \<mu>.dom.leg_simps(3)
\<mu>.leg1_commutes \<nu>'.cod_src_eq_dom_src \<nu>'.leg0_commutes \<nu>.cod_src_eq_dom_src
\<nu>.dom.leg_simps(1) \<nu>.leg0_commutes \<open>C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1\<close>)
qed
have "(\<nu>' \<bullet> \<nu>) \<star> (\<mu>' \<bullet> \<mu>) =
\<lparr>Chn = chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>),
Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
proof -
have "\<nu>' \<bullet> \<nu> \<star> \<mu>' \<bullet> \<mu> =
\<lparr>Chn = chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>),
Dom =
\<lparr>Leg0 = Leg0 (Dom (\<mu>' \<bullet> \<mu>)) \<cdot> \<p>\<^sub>0[Leg0 (Dom (\<nu>' \<bullet> \<nu>)), Leg1 (Dom (\<mu>' \<bullet> \<mu>))],
Leg1 = Leg1 (Dom (\<nu>' \<bullet> \<nu>)) \<cdot> \<p>\<^sub>1[Leg0 (Dom (\<nu>' \<bullet> \<nu>)), Leg1 (Dom (\<mu>' \<bullet> \<mu>))]\<rparr>,
Cod = \<lparr>Leg0 = Leg0 (Cod (\<mu>' \<bullet> \<mu>)) \<cdot> \<p>\<^sub>0[Leg0 (Cod (\<nu>' \<bullet> \<nu>)), Leg1 (Cod (\<mu>' \<bullet> \<mu>))],
Leg1 = Leg1 (Cod (\<nu>' \<bullet> \<nu>)) \<cdot> \<p>\<^sub>1[Leg0 (Cod (\<nu>' \<bullet> \<nu>)), Leg1 (Cod (\<mu>' \<bullet> \<mu>))]\<rparr>\<rparr>"
by (simp add: assms(3) assms(6-8) hcomp_def)
then show ?thesis
by (metis "2")
qed
moreover
have "(\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>) =
\<lparr>Chn = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>,
Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
proof -
have "arr (\<nu>' \<star> \<mu>') \<and> arr (\<nu> \<star> \<mu>)"
using assms arrow_of_spans_hcomp arr_char by simp
moreover have "Dom (\<nu>' \<star> \<mu>') = Cod (\<nu> \<star> \<mu>)"
using assms src_def trg_def seq_char hcomp_def src_hcomp trg_hcomp by simp
ultimately show ?thesis
using assms seq_char arr_char vcomp_eq hcomp_def by auto
qed
moreover have "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
proof -
have "C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1"
using assms src_def trg_def by simp
moreover have "C.seq \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] (chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>))"
using assms 2 C2 chine_hcomp_props [of "\<mu>' \<bullet> \<mu>" "\<nu>' \<bullet> \<nu>"] by auto
moreover have "C.seq \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] (chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>)"
using assms 1 chine_hcomp_props [of \<mu> \<nu>] chine_hcomp_props [of \<mu>' \<nu>'] by auto
moreover have "\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
proof -
have "\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using C2 3 by simp
also have "... = (\<mu>'.chine \<cdot> \<mu>.chine) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms vcomp_def seq_char arr_char
by (metis arrow_of_spans_data.select_convs(1))
also have "... = \<mu>'.chine \<cdot> \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using C.comp_assoc by simp
also have "... = (\<mu>'.chine \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu>"
using assms 1
C.prj_tuple(1)
[of "\<nu>.cod.leg0" "\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
"\<mu>.cod.leg1" "\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"]
by (metis (mono_tags, lifting) C.commutative_squareE C.comp_assoc chine_hcomp_props(4))
also have "... = (\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>') \<cdot> chine_hcomp \<nu> \<mu>"
using assms 1
by (metis (mono_tags, lifting) C.commutative_squareE chine_hcomp_props(4))
also have "... = \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
using C.comp_assoc by simp
finally show ?thesis by blast
qed
moreover have "\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
proof -
have "\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot>
\<langle>Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]
\<lbrakk>Leg0 (Cod \<nu>'), Leg1 (Cod \<mu>')\<rbrakk>
Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rangle>"
using 3 by simp
also have "... = Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using C2 C.prj_tuple(2) [of "Leg0 (Cod \<nu>')"
"Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
"Leg1 (Cod \<mu>')"
"Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"]
by simp
also have "... = (\<nu>'.chine \<cdot> \<nu>.chine) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using assms vcomp_def seq_char arr_char
by (metis (no_types, lifting) arrow_of_spans_data.select_convs(1))
also have "... = \<nu>'.chine \<cdot> \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
using C.comp_assoc by simp
also have "... = (\<nu>'.chine \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu>"
proof -
have "C.commutative_square \<nu>.cod.leg0 \<mu>.cod.leg1
(\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
(\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
using assms 1 vcomp_def seq_char arr_char chine_hcomp_props(2) by auto
thus ?thesis
using assms 1 \<nu>'.leg0_commutes C.prj_tuple(2) apply (simp add: C.comp_assoc)
by (metis (mono_tags, lifting) C.commutative_squareE chine_hcomp_props(3))
qed
also have "... = (\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>') \<cdot> chine_hcomp \<nu> \<mu>"
unfolding chine_hcomp_def using C1 1 C.prj_tuple(2) by simp
also have "... = \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
using C.comp_assoc by simp
finally show ?thesis by blast
qed
ultimately show ?thesis
using C.prj_joint_monic
[of "\<nu>'.cod.leg0" "\<mu>'.cod.leg1"
"chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>)" "chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"]
by simp
qed
ultimately show ?thesis by auto
qed
interpretation VxV: product_category vcomp vcomp ..
interpretation VV: subcategory VxV.comp
\<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and> src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
by (unfold_locales, simp_all)
interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>\<close>
proof
show "\<And>\<nu>\<mu>. \<not> VV.arr \<nu>\<mu> \<Longrightarrow> fst \<nu>\<mu> \<star> snd \<nu>\<mu> = null"
using hcomp_def VV.arr_char null_char by auto
show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow> arr (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
using arr_char arrow_of_spans_hcomp VV.arr_char by simp
show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow>
dom (fst \<nu>\<mu> \<star> snd \<nu>\<mu>) = fst (VV.dom \<nu>\<mu>) \<star> snd (VV.dom \<nu>\<mu>)"
using VV.arr_char VV.dom_char dom_hcomp by auto
show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow> cod (fst \<nu>\<mu> \<star> snd \<nu>\<mu>) = fst (VV.cod \<nu>\<mu>) \<star> snd (VV.cod \<nu>\<mu>)"
using VV.arr_char VV.cod_char cod_hcomp by auto
show "\<And>\<nu>\<mu>' \<nu>\<mu>. VV.seq \<nu>\<mu>' \<nu>\<mu> \<Longrightarrow> fst (VV.comp \<nu>\<mu>' \<nu>\<mu>) \<star> snd (VV.comp \<nu>\<mu>' \<nu>\<mu>) =
(fst \<nu>\<mu>' \<star> snd \<nu>\<mu>') \<bullet> (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
proof -
fix \<nu>\<mu>' \<nu>\<mu>
assume 1: "VV.seq \<nu>\<mu>' \<nu>\<mu>"
have "VV.comp \<nu>\<mu>' \<nu>\<mu> = (fst \<nu>\<mu>' \<bullet> fst \<nu>\<mu>, snd \<nu>\<mu>' \<bullet> snd \<nu>\<mu>)"
using 1 VV.comp_char VV.seq_char VxV.comp_char by auto
thus "fst (VV.comp \<nu>\<mu>' \<nu>\<mu>) \<star> snd (VV.comp \<nu>\<mu>' \<nu>\<mu>) =
(fst \<nu>\<mu>' \<star> snd \<nu>\<mu>') \<bullet> (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
using 1 hcomp_vcomp VV.seq_char VV.arr_char VV.comp_char
by (metis (no_types, lifting) fst_conv snd_conv)
qed
qed
lemma hcomp_is_functor:
shows "functor VV.comp vcomp (\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
..
lemma ide_hcomp:
assumes "ide f" and "ide g" and "src f = trg g"
shows "ide (f \<star> g)"
using assms VV.ide_char VV.arr_char H.preserves_ide [of "(f, g)"] by auto
sublocale horizontal_composition vcomp hcomp src trg
using src_hcomp trg_hcomp VV.arr_char not_arr_null hcomp_def null_char
by (unfold_locales, auto)
lemma has_horizontal_composition:
shows "horizontal_composition vcomp hcomp src trg"
..
end
subsection "The Bicategory Span(C)"
context span_bicategory
begin
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 HoHV
using functor_HoHV by blast
interpretation HoVH: "functor" VVV.comp vcomp HoVH
using functor_HoVH by blast
lemma arr_eqI:
assumes "par \<mu> \<mu>'" and "Chn \<mu> = Chn \<mu>'"
shows "\<mu> = \<mu>'"
using assms dom_char cod_char by auto
interpretation L: endofunctor vcomp L
using endofunctor_L by auto
abbreviation \<l>
where "\<l> f \<equiv> \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
Dom = Dom (L f), Cod = Cod f\<rparr>"
interpretation \<ll>: transformation_by_components vcomp vcomp L map \<l>
proof
have *: "\<And>f. ide f \<Longrightarrow> arrow_of_spans C (\<l> f)"
proof -
fix f
assume f: "ide f"
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
interpret \<l>f: arrow_of_spans C \<open>\<l> f\<close>
proof
show Dom: "C.span (Leg0 (Dom (\<l> f))) (Leg1 (Dom (\<l> f)))"
using f
by (simp add: arrow_of_spans_hcomp arrow_of_spans.axioms(2)
span_in_category.is_span)
interpret Dom: span_in_category C \<open>Dom (\<l> f)\<close>
using Dom by (unfold_locales, auto)
show Cod: "C.span (Leg0 (Cod (\<l> f))) (Leg1 (Cod (\<l> f)))"
using f hcomp_def trg_def src_def ide_mkObj C.pullback_commutes by force
interpret Cod: span_in_category C \<open>Cod (\<l> f)\<close>
using Cod by (unfold_locales, auto)
show "\<guillemotleft>Chn (\<l> f) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
proof -
have "C.dom Dom.leg0 = C.cod f.dom.leg1 \<down>\<down> f.dom.leg1"
proof -
have "arr (trg f)"
using f by simp
hence "Dom (\<l> f) = \<lparr>Leg0 = f.dom.leg0 \<cdot> \<p>\<^sub>0[C.cod f.dom.leg1, f.dom.leg1],
Leg1 = C.cod f.dom.leg1 \<cdot> \<p>\<^sub>1[C.cod f.dom.leg1, f.dom.leg1]\<rparr>"
using f src_def trg_def hcomp_def by simp
thus ?thesis
using f Dom hcomp_def by auto
qed
thus ?thesis
using f ide_char Dom.apex_def Cod.apex_def by simp
qed
show "Cod.leg0 \<cdot> Chn (\<l> f) = Dom.leg0"
using f ide_char hcomp_def src_def trg_def C.comp_arr_ide ide_mkObj by simp
show "Cod.leg1 \<cdot> Chn (\<l> f) = Dom.leg1"
using f ide_char hcomp_def src_def trg_def C.pullback_commutes ide_mkObj
C.comp_arr_ide
by (simp add: C.commutative_square_def)
qed
show "arrow_of_spans C (\<l> f)" ..
qed
show 0: "\<And>f. ide f \<Longrightarrow> \<guillemotleft>\<l> f : L f \<rightarrow> map f\<guillemotright>"
proof -
fix f
assume f: "ide f"
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
interpret \<l>f: arrow_of_spans C \<open>\<l> f\<close>
using f * by blast
show "in_hom (\<l> f) (L f) (map f)"
proof
show 1: "arr (\<l> f)"
using f * arr_char by blast
show "dom (\<l> f) = L f"
using f 1 dom_char ideD(2) by auto
show "cod (\<l> f) = map f"
using f 1 cod_char ideD(3) by auto
qed
qed
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> \<l> (cod \<mu>) \<bullet> L \<mu> = map \<mu> \<bullet> \<l> (dom \<mu>)"
proof -
fix \<mu>
assume \<mu>: "arr \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> arr_char by auto
interpret \<l>_dom_\<mu>: arrow_of_spans C \<open>\<l> (dom \<mu>)\<close>
using \<mu> * [of "dom \<mu>"] by fastforce
interpret \<l>_cod_\<mu>: arrow_of_spans C \<open>\<l> (cod \<mu>)\<close>
using \<mu> * [of "cod \<mu>"] by fastforce
interpret L\<mu>: arrow_of_spans C \<open>L \<mu>\<close>
using \<mu> arr_char by blast
show "\<l> (cod \<mu>) \<bullet> L \<mu> = map \<mu> \<bullet> \<l> (dom \<mu>)"
proof (intro arr_eqI)
show par: "par (\<l> (cod \<mu>) \<bullet> L \<mu>) (map \<mu> \<bullet> \<l> (dom \<mu>))"
- using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] hseqI' by fastforce
+ using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] by fastforce
show "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) = Chn (map \<mu> \<bullet> \<l> (dom \<mu>))"
proof -
have "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) =
\<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot>
\<langle>\<p>\<^sub>1[\<mu>.dtrg, \<mu>.dom.leg1] \<lbrakk>\<mu>.dtrg, \<mu>.cod.leg1\<rbrakk> \<mu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dtrg, \<mu>.dom.leg1]\<rangle>"
proof -
have "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) = \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot> Chn (trg \<mu> \<star> \<mu>)"
proof -
have "Dom (trg \<mu> \<star> cod \<mu>) = Cod (trg \<mu> \<star> \<mu>)"
using \<mu> seq_char by fastforce
moreover have "\<p>\<^sub>0[C.cod (Leg1 (Dom (cod \<mu>))), Leg1 (Dom (cod \<mu>))] \<cdot>
Chn (trg \<mu> \<star> \<mu>) =
\<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot> Chn (trg \<mu> \<star> \<mu>)"
by (simp add: \<mu> cod_char)
moreover have "arrow_of_spans (\<cdot>)
\<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom (cod \<mu>))), Leg1 (Dom (cod \<mu>))],
Dom = Cod (trg \<mu> \<star> \<mu>), Cod = Cod (cod \<mu>)\<rparr>"
using \<mu> par seq_char by auto
ultimately show ?thesis
using \<mu> vcomp_def L\<mu>.arrow_of_spans_axioms by auto
qed
moreover
have "Chn (trg \<mu> \<star> \<mu>) = \<langle>\<p>\<^sub>1[\<mu>.dtrg, \<mu>.dom.leg1]
\<lbrakk>\<mu>.dtrg, \<mu>.cod.leg1\<rbrakk>
\<mu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dtrg, \<mu>.dom.leg1]\<rangle>"
using \<mu> hcomp_def chine_hcomp_trg_arr by simp
ultimately show ?thesis
using \<mu> by (auto simp add: cod_char)
qed
also have "... = \<mu>.chine \<cdot> \<p>\<^sub>0[C.cod \<mu>.dom.leg1, \<mu>.dom.leg1]"
using \<mu> C.in_homE C.pullback_commutes [of "C.cod \<mu>.dom.leg1" "\<mu>.dom.leg1"]
C.comp_reduce ide_char C.prj_tuple(1)
by auto
also have "... = Chn (map \<mu> \<bullet> \<l> (dom \<mu>))"
using \<mu> par seq_char dom_char vcomp_eq map_simp by simp
finally show ?thesis by blast
qed
qed
qed
qed
interpretation \<ll>: natural_isomorphism vcomp vcomp L map \<ll>.map
proof
fix f
assume f: "ide f"
show "iso (\<ll>.map f)"
proof -
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
have 1: "\<ll>.map f = \<lparr>Chn = \<p>\<^sub>0[f.dtrg, f.leg1], Dom = Dom (trg f \<star> f), Cod = Dom f\<rparr>"
using f ide_char cod_char by simp
interpret \<l>f: arrow_of_spans C \<open>\<ll>.map f\<close>
using f arr_char \<ll>.preserves_reflects_arr by fastforce
let ?\<l>f' = "\<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> C.dom f.leg1\<rangle>,
Dom = Dom f, Cod = Dom (trg f \<star> f)\<rparr>"
have 2: "C.inverse_arrows \<l>f.chine (Chn ?\<l>f')"
using 1 C.pullback_arr_cod(2) [of "f.leg1"] by simp
interpret \<l>f': arrow_of_spans C ?\<l>f'
proof
show Dom: "C.span (Leg0 (Dom ?\<l>f')) (Leg1 (Dom ?\<l>f'))"
using f 1 by auto
interpret Dom: span_in_category C \<open>Dom ?\<l>f'\<close>
using Dom by (unfold_locales, auto)
show Cod: "C.span (Leg0 (Cod ?\<l>f')) (Leg1 (Cod ?\<l>f'))"
using f 1 \<l>f.dom.is_span by auto
interpret Cod: span_in_category C \<open>Cod ?\<l>f'\<close>
using Cod by (unfold_locales, auto)
show "\<guillemotleft>Chn ?\<l>f' : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
using f src_def trg_def hcomp_def ide_mkObj Cod.apex_def Dom.apex_def
C.comp_arr_dom C.comp_cod_arr
by auto
show "Cod.leg0 \<cdot> Chn ?\<l>f' = Dom.leg0"
using 2 \<l>f.leg0_commutes C.invert_side_of_triangle
by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<l>f.dom.is_span
arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
show "Cod.leg1 \<cdot> Chn ?\<l>f' = Dom.leg1"
using 2 \<l>f.leg1_commutes C.invert_side_of_triangle
by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<l>f.dom.is_span
arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
qed
have "inverse_arrows (\<ll>.map f) ?\<l>f'"
proof
show "ide (?\<l>f' \<bullet> \<ll>.map f)"
proof -
have "?\<l>f' \<bullet> \<ll>.map f = dom (\<ll>.map f)"
proof -
have "?\<l>f' \<bullet> \<ll>.map f =
\<lparr>Chn = f.dtrg \<down>\<down> f.leg1, Dom = Dom (\<ll>.map f), Cod = Dom (\<ll>.map f)\<rparr>"
using f 1 2 f.arrow_of_spans_axioms \<l>f.arrow_of_spans_axioms
\<l>f'.arrow_of_spans_axioms vcomp_def ide_char arr_char
by (simp add: vcomp_def C.comp_inv_arr)
also have "... = dom (\<ll>.map f)"
proof -
have "C.cod f.dom.leg1 \<down>\<down> f.dom.leg1 = C.dom (Leg1 (Dom (hcomp (trg f) f)))"
using f f.arrow_of_spans_axioms hcomp_def src_def trg_def ide_mkObj
by auto
thus ?thesis
using 1 f.arrow_of_spans_axioms arr_char dom_char \<l>f.dom.is_span
\<l>f.arrow_of_spans_axioms \<l>f'.cod.apex_def
by auto
qed
finally show ?thesis by blast
qed
thus ?thesis
using \<l>f.arrow_of_spans_axioms arr_char by simp
qed
show "ide (\<ll>.map f \<bullet> ?\<l>f')"
proof -
have "\<ll>.map f \<bullet> ?\<l>f' = dom ?\<l>f'"
proof -
have "\<ll>.map f \<bullet> ?\<l>f' = \<lparr>Chn = Chn f, Dom = Dom ?\<l>f', Cod = Dom ?\<l>f'\<rparr>"
using f 1 2 f.arrow_of_spans_axioms \<l>f.arrow_of_spans_axioms
\<l>f'.arrow_of_spans_axioms vcomp_def ide_char arr_char
by fastforce
also have "... = dom ?\<l>f'"
using 1 \<l>f'.arrow_of_spans_axioms arr_char dom_char by simp
finally show ?thesis by blast
qed
thus ?thesis
using \<l>f'.arrow_of_spans_axioms arr_char by simp
qed
qed
thus ?thesis by auto
qed
qed
lemma \<ll>_is_natural_isomorphism:
shows "natural_isomorphism vcomp vcomp L map \<ll>.map"
..
interpretation equivalence_functor vcomp vcomp L
using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
lemma equivalence_functor_L:
shows "equivalence_functor vcomp vcomp L"
..
interpretation R: endofunctor vcomp R
using endofunctor_R by auto
abbreviation \<r>
where "\<r> f \<equiv> \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
Dom = Dom (R f), Cod = Cod f\<rparr>"
interpretation \<rho>: transformation_by_components vcomp vcomp R map \<r>
proof
have *: "\<And>f. ide f \<Longrightarrow> arrow_of_spans C (\<r> f)"
proof -
fix f
assume f: "ide f"
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
interpret \<r>f: arrow_of_spans C \<open>\<r> f\<close>
proof
show Dom: "C.span (Leg0 (Dom (\<r> f))) (Leg1 (Dom (\<r> f)))"
using f
by (simp add: arrow_of_spans_hcomp arrow_of_spans.axioms(2)
span_in_category.is_span)
interpret Dom: span_in_category C \<open>Dom (\<r> f)\<close>
using Dom by (unfold_locales, auto)
show Cod: "C.span (Leg0 (Cod (\<r> f))) (Leg1 (Cod (\<r> f)))"
using f hcomp_def trg_def src_def ide_mkObj C.pullback_commutes by force
interpret Cod: span_in_category C \<open>Cod (\<r> f)\<close>
using Cod by (unfold_locales, auto)
show "\<guillemotleft>Chn (\<r> f) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
proof -
have "C.dom Dom.leg0 = f.dom.leg0 \<down>\<down> C.cod f.dom.leg0"
proof -
have "arr (src f)"
using f by simp
hence "Dom (\<r> f) = \<lparr>Leg0 = C.cod f.dom.leg0 \<cdot> \<p>\<^sub>0[f.dom.leg0, C.cod f.dom.leg0],
Leg1 = f.dom.leg1 \<cdot> \<p>\<^sub>1[f.dom.leg0, C.cod f.dom.leg0]\<rparr>"
using f src_def trg_def by (simp add: hcomp_def)
thus ?thesis
using f ide_char Dom.apex_def Cod.apex_def by simp
qed
thus ?thesis
using f ide_char Dom.apex_def Cod.apex_def by simp
qed
show "Cod.leg0 \<cdot> Chn (\<r> f) = Dom.leg0"
using f ide_char hcomp_def src_def trg_def C.pullback_commutes
ide_mkObj C.comp_arr_ide
by (simp add: C.commutative_square_def)
show "Cod.leg1 \<cdot> Chn (\<r> f) = Dom.leg1"
using f ide_char hcomp_def src_def trg_def ide_mkObj C.comp_arr_ide
by (simp add: C.commutative_square_def)
qed
show "arrow_of_spans C (\<r> f)" ..
qed
show 0: "\<And>f. ide f \<Longrightarrow> in_hom (\<r> f) (R f) (map f)"
proof -
fix f
assume f: "ide f"
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
interpret \<r>f: arrow_of_spans C \<open>\<r> f\<close>
using f * by blast
show "in_hom (\<r> f) (R f) (map f)"
proof
show 1: "arr (\<r> f)"
using f * arr_char by blast
show "dom (\<r> f) = R f"
using f 1 dom_char ideD(2) by auto
show "cod (\<r> f) = map f"
using f 1 cod_char ideD(3) by auto
qed
qed
show "\<And>\<mu>. arr \<mu> \<Longrightarrow> \<r> (cod \<mu>) \<bullet> R \<mu> = map \<mu> \<bullet> \<r> (dom \<mu>)"
proof -
fix \<mu>
assume \<mu>: "arr \<mu>"
interpret \<mu>: arrow_of_spans C \<mu>
using \<mu> arr_char by auto
interpret \<r>_dom_\<mu>: arrow_of_spans C \<open>\<r> (dom \<mu>)\<close>
using \<mu> * [of "dom \<mu>"] by fastforce
interpret \<r>_cod_\<mu>: arrow_of_spans C \<open>\<r> (cod \<mu>)\<close>
using \<mu> * [of "cod \<mu>"] by fastforce
interpret R\<mu>: arrow_of_spans C \<open>R \<mu>\<close>
using \<mu> arr_char by blast
show "\<r> (cod \<mu>) \<bullet> R \<mu> = map \<mu> \<bullet> \<r> (dom \<mu>)"
proof (intro arr_eqI)
show par: "par (\<r> (cod \<mu>) \<bullet> R \<mu>) (map \<mu> \<bullet> \<r> (dom \<mu>))"
- using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] hseqI' by force
+ using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] by force
show "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) = Chn (map \<mu> \<bullet> \<r> (dom \<mu>))"
proof -
have "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) =
\<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.cod.src] \<cdot>
\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<mu>.dsrc] \<lbrakk>\<mu>.cod.leg0, \<mu>.cod.src\<rbrakk> \<p>\<^sub>0[\<mu>.dom.leg0, \<mu>.dsrc]\<rangle>"
proof -
have "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) = \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.cod.src] \<cdot> Chn (\<mu> \<star> src \<mu>)"
proof -
have "Dom (cod \<mu> \<star> src \<mu>) = Cod (\<mu> \<star> src \<mu>)"
using \<mu> seq_char by fastforce
moreover have "\<p>\<^sub>1[Leg0 (Dom (cod \<mu>)), C.cod (Leg0 (Dom (cod \<mu>)))] \<cdot>
Chn (\<mu> \<star> src \<mu>) =
\<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.dsrc] \<cdot> Chn (\<mu> \<star> src \<mu>)"
by (simp add: \<mu> cod_char)
moreover have "arrow_of_spans (\<cdot>)
\<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom (cod \<mu>)), C.cod (Leg0 (Dom (cod \<mu>)))],
Dom = Cod (\<mu> \<star> src \<mu>), Cod = Cod (cod \<mu>)\<rparr>"
using \<mu> par seq_char by auto
ultimately show ?thesis
using \<mu> vcomp_def R\<mu>.arrow_of_spans_axioms by auto
qed
moreover
have "Chn (\<mu> \<star> src \<mu>) = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<mu>.dsrc]
\<lbrakk>\<mu>.cod.leg0, \<mu>.dsrc\<rbrakk>
\<p>\<^sub>0[\<mu>.dom.leg0, \<mu>.dsrc]\<rangle>"
using \<mu> hcomp_def chine_hcomp_arr_src by simp
ultimately show ?thesis
using \<mu> by (auto simp add: cod_char)
qed
also have "... = \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, C.cod \<mu>.dom.leg0]"
using \<mu> ide_char C.prj_tuple(2)
C.in_homE C.pullback_commutes [of "\<mu>.dom.leg0" "C.cod \<mu>.dom.leg0"]
C.comp_reduce
by auto
also have "... = Chn (map \<mu> \<bullet> \<r> (dom \<mu>))"
using \<mu> par seq_char dom_char vcomp_eq map_simp by simp
finally show ?thesis by blast
qed
qed
qed
qed
interpretation \<rho>: natural_isomorphism vcomp vcomp R map \<rho>.map
proof
fix f
assume f: "ide f"
show "iso (\<rho>.map f)"
proof -
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
have 1: "\<rho>.map f = \<lparr>Chn = \<p>\<^sub>1[f.leg0, f.dsrc], Dom = Dom (f \<star> src f), Cod = Dom f\<rparr>"
using f ide_char by auto
interpret \<rho>f: arrow_of_spans C \<open>\<rho>.map f\<close>
using f arr_char \<rho>.preserves_reflects_arr by fastforce
let ?\<rho>f' = "\<lparr>Chn = \<langle>C.dom f.leg0 \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>,
Dom = Dom f, Cod = Dom (f \<star> src f)\<rparr>"
have 2: "C.inverse_arrows (Chn (\<rho>.map f)) (Chn ?\<rho>f')"
using 1 C.pullback_arr_cod(1) [of "f.dom.leg0"] by simp
interpret \<rho>f': arrow_of_spans C ?\<rho>f'
proof
show Dom: "C.span (Leg0 (Dom ?\<rho>f')) (Leg1 (Dom ?\<rho>f'))"
using f 1 by auto
interpret Dom: span_in_category C \<open>Dom ?\<rho>f'\<close>
using Dom by (unfold_locales, auto)
show Cod: "C.span (Leg0 (Cod ?\<rho>f')) (Leg1 (Cod ?\<rho>f'))"
using f 1 \<rho>f.dom.is_span by auto
interpret Cod: span_in_category C \<open>Cod ?\<rho>f'\<close>
using Cod by (unfold_locales, auto)
show "\<guillemotleft>Chn ?\<rho>f' : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
using f src_def trg_def hcomp_def ide_mkObj Cod.apex_def Dom.apex_def
C.comp_arr_dom C.comp_cod_arr
by auto
show "Cod.leg0 \<cdot> Chn ?\<rho>f' = Dom.leg0"
using 2 \<rho>f.leg0_commutes C.invert_side_of_triangle
by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<rho>f.dom.is_span
arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
show "Cod.leg1 \<cdot> Chn ?\<rho>f' = Dom.leg1"
using 2 \<rho>f.leg1_commutes C.invert_side_of_triangle
by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<rho>f.dom.is_span
arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
qed
have "inverse_arrows (\<rho>.map f) ?\<rho>f'"
proof
show "ide (?\<rho>f' \<bullet> \<rho>.map f)"
proof -
have "?\<rho>f' \<bullet> \<rho>.map f = dom (\<rho>.map f)"
proof -
have "?\<rho>f' \<bullet> \<rho>.map f =
\<lparr>Chn = f.leg0 \<down>\<down> f.dsrc, Dom = Dom (\<rho>.map f), Cod = Dom (\<rho>.map f)\<rparr>"
using f 1 2 f.arrow_of_spans_axioms
\<rho>f.arrow_of_spans_axioms \<rho>f'.arrow_of_spans_axioms
vcomp_def ide_char arr_char C.comp_inv_arr
by (simp add: vcomp_def)
also have "... = dom (\<rho>.map f)"
proof -
have "C.dom (Leg0 (Dom (f \<star> src f))) = C.dom (Leg1 (Dom (f \<star> src f)))"
using f f.arrow_of_spans_axioms hcomp_def src_def trg_def ide_mkObj
by auto
thus ?thesis
using 1 f.arrow_of_spans_axioms arr_char dom_char \<rho>f.dom.is_span
\<rho>f.arrow_of_spans_axioms \<rho>f'.cod.apex_def \<rho>f.chine_simps(2)
by auto
qed
finally show ?thesis by blast
qed
thus ?thesis
using \<rho>f.arrow_of_spans_axioms arr_char by simp
qed
show "ide (\<rho>.map f \<bullet> ?\<rho>f')"
proof -
have "\<rho>.map f \<bullet> ?\<rho>f' = dom ?\<rho>f'"
proof -
have "\<rho>.map f \<bullet> ?\<rho>f' = \<lparr>Chn = Chn f, Dom = Dom ?\<rho>f', Cod = Dom ?\<rho>f'\<rparr>"
using f 1 2 f.arrow_of_spans_axioms
\<rho>f.arrow_of_spans_axioms \<rho>f'.arrow_of_spans_axioms
vcomp_def ide_char arr_char
by fastforce
also have "... = dom ?\<rho>f'"
using 1 \<rho>f'.arrow_of_spans_axioms arr_char dom_char by simp
finally show ?thesis by blast
qed
thus ?thesis
using \<rho>f'.arrow_of_spans_axioms arr_char by simp
qed
qed
thus ?thesis by auto
qed
qed
lemma \<rho>_is_natural_isomorphism:
shows "natural_isomorphism vcomp vcomp R map \<rho>.map"
..
interpretation equivalence_functor vcomp vcomp R
using R.isomorphic_to_identity_is_equivalence \<rho>.natural_isomorphism_axioms by simp
lemma equivalence_functor_R:
shows "equivalence_functor vcomp vcomp R"
..
definition unit ("\<i>[_]")
where "\<i>[a] \<equiv> \<lparr>Chn = \<p>\<^sub>0[Chn a, Chn a], Dom = Dom (a \<star> a), Cod = Cod a\<rparr>"
lemma unit_in_hom [intro]:
assumes "obj a"
shows "in_hhom \<i>[a] a a"
and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
proof -
show "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
proof (intro in_homI)
interpret a: identity_arrow_of_spans C a
using assms obj_char ide_char' by auto
have 0: "src a = trg a"
using assms arr_char obj_char src_def trg_def by (elim objE, auto)
interpret aa: arrow_of_spans C \<open>a \<star> a\<close>
using assms 0 a.arrow_of_spans_axioms arrow_of_spans_hcomp by auto
interpret aa: identity_arrow_of_spans C \<open>a \<star> a\<close>
proof
have "ide (a \<star> a)"
using assms 0 obj_char H.preserves_ide by simp
thus "C.ide aa.chine" using ide_char by auto
qed
have 1: "\<guillemotleft>\<p>\<^sub>0[a.chine, a.chine] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C a.chine\<guillemotright> \<and>
\<guillemotleft>\<p>\<^sub>1[a.chine, a.chine] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C a.chine\<guillemotright>"
by auto
have 2: "a.dom.leg0 = a.chine \<and> a.dom.leg1 = a.chine \<and>
a.cod.leg0 = a.chine \<and> a.cod.leg1 = a.chine"
using assms obj_char by (cases a, simp_all)
have 3: "a \<star> a = \<lparr>Chn = a.chine \<down>\<down> a.chine,
Dom = \<lparr>Leg0 = \<p>\<^sub>0[a.chine, a.chine], Leg1 = \<p>\<^sub>1[a.chine, a.chine]\<rparr>,
Cod = \<lparr>Leg0 = \<p>\<^sub>0[a.chine, a.chine], Leg1 = \<p>\<^sub>1[a.chine, a.chine]\<rparr>\<rparr>"
using assms 0 1 2 chine_hcomp_ide_ide hcomp_def C.comp_cod_arr
a.identity_arrow_of_spans_axioms ide_char'
by auto
have "aa.apex = a.chine \<down>\<down> a.chine"
using 3 aa.chine_eq_apex by auto
interpret \<i>a: arrow_of_spans C \<open>\<i>[a]\<close>
proof
have 4: "Dom \<i>[a] = Dom (a \<star> a)"
using assms hcomp_def unit_def by simp
have 5: "Cod \<i>[a] = Cod a"
using assms unit_def by simp
show Dom: "C.span (Leg0 (Dom \<i>[a])) (Leg1 (Dom \<i>[a]))"
using 4 by simp
interpret Dom: span_in_category C \<open>Dom \<i>[a]\<close>
using Dom by (unfold_locales, auto)
show Cod: "C.span (Leg0 (Cod \<i>[a])) (Leg1 (Cod \<i>[a]))"
using 5 by simp
interpret Cod: span_in_category C \<open>Cod \<i>[a]\<close>
using Cod by (unfold_locales, auto)
show "\<guillemotleft>Chn \<i>[a] : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
proof -
have "\<guillemotleft>Chn \<i>[a] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C C.dom a.chine\<guillemotright>"
using assms obj_char ide_char unit_def by simp
moreover have "C.dom (Leg0 (Dom \<i>[a])) = Chn a \<down>\<down> Chn a"
using assms 3 unit_def obj_char ide_char by simp
moreover have "C.dom a.chine = C.dom Cod.leg0"
using unit_def by auto
ultimately show ?thesis by simp
qed
show "Cod.leg0 \<cdot> Chn \<i>[a] = Dom.leg0"
unfolding unit_def using 1 2 3 C.comp_cod_arr by auto
show "Cod.leg1 \<cdot> Chn \<i>[a] = Dom.leg1"
unfolding unit_def using 1 2 3 C.comp_cod_arr C.pullback_ide_self by auto
qed
show "arr \<i>[a]"
using \<i>a.arrow_of_spans_axioms arr_char by simp
show "dom \<i>[a] = hcomp a a"
using 3 unit_def \<i>a.arrow_of_spans_axioms arr_char dom_char \<i>a.dom.apex_def
by auto
show "cod \<i>[a] = a"
using assms 3 obj_char arr_char dom_char cod_char unit_def
\<i>a.arrow_of_spans_axioms
by auto
qed
thus "in_hhom \<i>[a] a a"
using assms
by (metis arrI in_hhom_def objE vconn_implies_hpar(1) vconn_implies_hpar(2-4))
qed
lemma unit_simps [simp]:
assumes "obj a"
shows "src \<i>[a] = a" and "trg \<i>[a] = a"
and "dom \<i>[a] = hcomp a a" and "cod \<i>[a] = a"
using assms unit_in_hom by auto
lemma iso_unit:
assumes "obj a"
shows "iso \<i>[a]"
proof -
have "Chn \<i>[a] = \<p>\<^sub>0[Chn a, Chn a]"
unfolding unit_def by simp
moreover have "C.iso \<p>\<^sub>0[Chn a, Chn a]"
using assms C.ide_is_iso C.iso_is_arr C.iso_pullback_ide ide_char by blast
ultimately show ?thesis
using assms unit_in_hom iso_char by auto
qed
end
locale two_composable_arrows_of_spans =
span_bicategory +
\<mu>: arrow_of_spans C \<mu> +
\<nu>: arrow_of_spans C \<nu>
for \<mu> (structure)
and \<nu> (structure) +
assumes composable: "src \<mu> = trg \<nu>"
begin
lemma are_arrows [simp]:
shows "arr \<mu>" and "arr \<nu>"
using arr_char \<mu>.arrow_of_spans_axioms \<nu>.arrow_of_spans_axioms by auto
lemma legs_form_cospan:
shows "C.cospan \<mu>.dom.leg0 \<nu>.dom.leg1" and "C.cospan \<mu>.cod.leg0 \<nu>.cod.leg1"
using composable src_def trg_def by auto
interpretation \<mu>\<nu>: arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
using arrow_of_spans_hcomp composable by auto
lemma composite_is_arrow [simp]:
shows "arr (\<mu> \<star> \<nu>)"
using \<mu>\<nu>.arrow_of_spans_axioms arr_char by auto
lemma composite_in_hom [intro]:
shows "\<guillemotleft>\<mu> \<star> \<nu> : dom \<mu> \<star> dom \<nu> \<Rightarrow> cod \<mu> \<star> cod \<nu>\<guillemotright>"
using composable by auto
lemma composite_simps [simp]:
shows "src (\<mu> \<star> \<nu>) = src \<nu>" and "trg (\<mu> \<star> \<nu>) = trg \<mu>"
and "dom (\<mu> \<star> \<nu>) = dom \<mu> \<star> dom \<nu>" and "cod (\<mu> \<star> \<nu>) = cod \<mu> \<star> cod \<nu>"
- by auto
+ by (simp_all add: composable)
lemma chine_composite:
shows "Chn (\<mu> \<star> \<nu>) = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
\<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle>"
unfolding hcomp_def chine_hcomp_def using composable by simp
lemma chine_composite_in_hom [intro]:
shows "\<guillemotleft>Chn (\<mu> \<star> \<nu>) : \<mu>.dom.leg0 \<down>\<down> \<nu>.dom.leg1 \<rightarrow>\<^sub>C \<mu>.cod.leg0 \<down>\<down> \<nu>.cod.leg1\<guillemotright>"
using hcomp_def chine_hcomp_props(1) composable by auto
end
sublocale two_composable_arrows_of_spans \<subseteq> arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
proof -
interpret Dom\<mu>_Dom\<nu>: composite_span C prj0 prj1 \<open>Dom \<mu>\<close> \<open>Dom \<nu>\<close>
using legs_form_cospan(1) by (unfold_locales, auto)
interpret Cod\<mu>_Cod\<nu>: composite_span C prj0 prj1 \<open>Cod \<mu>\<close> \<open>Cod \<nu>\<close>
using legs_form_cospan(1) by (unfold_locales, auto)
interpret Dom_\<mu>\<nu>: span_in_category C \<open>Dom (\<mu> \<star> \<nu>)\<close>
apply unfold_locales apply (unfold hcomp_def)
using Dom\<mu>_Dom\<nu>.apex_def Dom\<mu>_Dom\<nu>.leg_simps(1) are_arrows(1) composable by auto
interpret Cod_\<mu>\<nu>: span_in_category C \<open>Cod (\<mu> \<star> \<nu>)\<close>
apply unfold_locales apply (unfold hcomp_def)
using Cod\<mu>_Cod\<nu>.apex_def Cod\<mu>_Cod\<nu>.leg_simps(1) are_arrows(1) composable by auto
show "arrow_of_spans C (\<mu> \<star> \<nu>)"
proof
show "\<guillemotleft>Chn (hcomp \<mu> \<nu>) : Dom_\<mu>\<nu>.apex \<rightarrow>\<^sub>C Cod_\<mu>\<nu>.apex\<guillemotright>"
unfolding hcomp_def
using are_arrows(1) are_arrows(2) arrow_of_spans_hcomp composable hcomp_def
arrow_of_spans.chine_in_hom Cod\<mu>_Cod\<nu>.leg_simps(4) Dom\<mu>_Dom\<nu>.leg_simps(3)
Dom\<mu>_Dom\<nu>.leg_simps(4) chine_composite_in_hom
by auto
show "Cod_\<mu>\<nu>.leg0 \<cdot> Chn (hcomp \<mu> \<nu>) = Dom_\<mu>\<nu>.leg0"
proof (unfold hcomp_def)
have "arrow_of_spans C
\<lparr>Chn = chine_hcomp \<mu> \<nu>, Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>"
using arrow_of_spans_hcomp composable hcomp_def by auto
thus "Leg0 (Cod (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
\<lparr>Chn = chine_hcomp \<mu> \<nu>,
Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
else null)) \<cdot>
Chn (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
\<lparr>Chn = chine_hcomp \<mu> \<nu>,
Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
else null) =
Leg0 (Dom (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
\<lparr>Chn = chine_hcomp \<mu> \<nu>,
Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
else null))"
using arrow_of_spans.leg0_commutes composable by fastforce
qed
show "Cod_\<mu>\<nu>.leg1 \<cdot> Chn (hcomp \<mu> \<nu>) = Dom_\<mu>\<nu>.leg1"
proof (unfold hcomp_def)
have "arrow_of_spans C
\<lparr>Chn = chine_hcomp \<mu> \<nu>, Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>"
using arrow_of_spans_hcomp composable hcomp_def by force
thus "Leg1 (Cod (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
\<lparr>Chn = chine_hcomp \<mu> \<nu>,
Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
else null)) \<cdot>
Chn (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
\<lparr>Chn = chine_hcomp \<mu> \<nu>,
Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
else null) =
Leg1 (Dom (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
\<lparr>Chn = chine_hcomp \<mu> \<nu>,
Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
else null))"
using arrow_of_spans.leg1_commutes composable by force
qed
qed
qed
locale two_composable_identity_arrows_of_spans =
two_composable_arrows_of_spans +
\<mu>: identity_arrow_of_spans C \<mu> +
\<nu>: identity_arrow_of_spans C \<nu>
begin
lemma are_identities [simp]:
shows "ide \<mu>" and "ide \<nu>"
using ide_char \<mu>.arrow_of_spans_axioms \<nu>.arrow_of_spans_axioms by auto
interpretation VxV: product_category vcomp vcomp ..
interpretation VV: subcategory VxV.comp \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and>
src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
by (unfold_locales, simp_all)
interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>\<close>
using hcomp_is_functor by auto
interpretation \<mu>\<nu>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
proof
have "VV.ide (\<mu>, \<nu>)"
using VV.ide_char composable by auto
hence "ide (hcomp \<mu> \<nu>)"
using H.preserves_ide [of "(\<mu>, \<nu>)"] by simp
thus "C.ide chine"
using ide_char by simp
qed
lemma ide_composite [simp]:
shows "ide (\<mu> \<star> \<nu>)"
using \<mu>\<nu>.identity_arrow_of_spans_axioms arrow_of_spans_axioms ide_char by auto
lemma apex_composite:
shows "\<mu>\<nu>.apex = \<mu>.leg0 \<down>\<down> \<nu>.leg1"
using dom.apex_def hcomp_def chine_hcomp_ide_ide composable legs_form_cospan
by simp
lemma leg0_composite:
shows "\<mu>\<nu>.leg0 = \<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]"
using dom.apex_def hcomp_def composable legs_form_cospan by simp
lemma leg1_composite:
shows "\<mu>\<nu>.leg1 = \<mu>.leg1 \<cdot> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1]"
using dom.apex_def hcomp_def composable legs_form_cospan by simp
lemma chine_composite:
shows "Chn (\<mu> \<star> \<nu>) = \<mu>.leg0 \<down>\<down> \<nu>.leg1"
unfolding hcomp_def using chine_hcomp_ide_ide composable by simp
abbreviation prj\<^sub>0
where "prj\<^sub>0 \<equiv> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]"
abbreviation prj\<^sub>1
where "prj\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1]"
lemma prj_in_hom [intro]:
shows "\<guillemotleft>prj\<^sub>1 : \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
and "\<guillemotleft>prj\<^sub>0 : \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
using legs_form_cospan by auto
lemma prj_simps [simp]:
shows "C.arr prj\<^sub>1" and "C.dom prj\<^sub>1 = \<mu>.leg0 \<down>\<down> \<nu>.leg1" and "C.cod prj\<^sub>1 = \<mu>.apex"
and "C.arr prj\<^sub>0" and "C.dom prj\<^sub>0 = \<mu>.leg0 \<down>\<down> \<nu>.leg1" and "C.cod prj\<^sub>0 = \<nu>.apex"
using prj_in_hom by auto
sublocale identity_arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
using apex_composite dom.ide_apex chine_composite by (unfold_locales, auto)
end
locale three_composable_arrows_of_spans =
span_bicategory +
\<mu>: arrow_of_spans C \<mu> +
\<nu>: arrow_of_spans C \<nu> +
\<pi>: arrow_of_spans C \<pi> +
\<mu>\<nu>: two_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
\<nu>\<pi>: two_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi>
for \<mu> (structure)
and \<nu> (structure)
and \<pi> (structure)
begin
interpretation \<mu>\<nu>\<pi>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
using \<mu>.arrow_of_spans_axioms \<nu>\<pi>.arrow_of_spans_axioms
arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
by force
interpretation \<mu>\<nu>_\<pi>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
using \<mu>\<nu>.arrow_of_spans_axioms \<pi>.arrow_of_spans_axioms
arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
by force
lemma composites_are_arrows [simp]:
shows "arr (\<mu> \<star> \<nu> \<star> \<pi>)" and "arr ((\<mu> \<star> \<nu>) \<star> \<pi>)"
using \<mu>\<nu>\<pi>.arrow_of_spans_axioms \<mu>\<nu>_\<pi>.arrow_of_spans_axioms arr_char by auto
lemma composite_in_hom [intro]:
shows "\<guillemotleft>\<mu> \<star> \<nu> \<star> \<pi> : dom \<mu> \<star> dom \<nu> \<star> dom \<pi> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<pi>\<guillemotright>"
and "\<guillemotleft>(\<mu> \<star> \<nu>) \<star> \<pi> : (dom \<mu> \<star> dom \<nu>) \<star> dom \<pi> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>\<guillemotright>"
using \<mu>\<nu>.composable \<nu>\<pi>.composable by auto
lemma composite_simps [simp]:
shows "src (\<mu> \<star> \<nu> \<star> \<pi>) = src \<pi>"
and "src ((\<mu> \<star> \<nu>) \<star> \<pi>) = src \<pi>"
and "trg (\<mu> \<star> \<nu> \<star> \<pi>) = trg \<mu>"
and "trg ((\<mu> \<star> \<nu>) \<star> \<pi>) = trg \<mu>"
and "dom (\<mu> \<star> \<nu> \<star> \<pi>) = dom \<mu> \<star> dom \<nu> \<star> dom \<pi>"
and "dom ((\<mu> \<star> \<nu>) \<star> \<pi>) = (dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>"
and "cod (\<mu> \<star> \<nu> \<star> \<pi>) = cod \<mu> \<star> cod \<nu> \<star> cod \<pi>"
and "cod ((\<mu> \<star> \<nu>) \<star> \<pi>) = (cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>"
- by auto
+ by (auto simp add: \<mu>\<nu>.composable \<nu>\<pi>.composable)
lemma chine_composite:
shows "\<mu>\<nu>\<pi>.chine =
\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
\<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
\<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle> \<cdot>
\<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]\<rangle>"
and "\<mu>\<nu>_\<pi>.chine =
\<langle>\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
\<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle> \<cdot>
\<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]
\<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]\<rangle>"
proof -
show "\<mu>\<nu>\<pi>.chine =
\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
\<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
\<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle> \<cdot>
\<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]\<rangle>"
unfolding hcomp_def chine_hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable
using trg_def \<nu>\<pi>.are_arrows(1-2) \<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow
\<nu>\<pi>.composite_simps(2) hcomp_def
by (simp add: chine_hcomp_def)
show "\<mu>\<nu>_\<pi>.chine =
\<langle>\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
\<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle> \<cdot>
\<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]
\<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]\<rangle>"
unfolding hcomp_def chine_hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable
using src_def \<mu>\<nu>.are_arrows(1-2) \<mu>\<nu>.composable \<mu>\<nu>.composite_is_arrow
\<mu>\<nu>.composite_simps(1) hcomp_def \<nu>\<pi>.composable
by (simp add: chine_hcomp_def)
qed
end
locale three_composable_identity_arrows_of_spans =
three_composable_arrows_of_spans +
\<mu>: identity_arrow_of_spans C \<mu> +
\<nu>: identity_arrow_of_spans C \<nu> +
\<pi>: identity_arrow_of_spans C \<pi> +
\<mu>\<nu>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi>
begin
lemma composites_are_identities [simp]:
shows "ide (\<mu> \<star> \<nu> \<star> \<pi>)" and "ide ((\<mu> \<star> \<nu>) \<star> \<pi>)"
proof -
interpret \<mu>_H\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close>
using \<mu>\<nu>.composable \<nu>\<pi>.composable
by (unfold_locales, simp)
show "ide (\<mu> \<star> \<nu> \<star> \<pi>)"
by auto
interpret H\<mu>\<nu>_\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi>
using \<mu>\<nu>.composable \<nu>\<pi>.composable
by (unfold_locales, simp)
show "ide ((\<mu> \<star> \<nu>) \<star> \<pi>)"
by auto
qed
interpretation \<mu>\<nu>\<pi>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
using composites_are_identities ide_char' by auto
interpretation \<mu>\<nu>_\<pi>: identity_arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
using composites_are_identities ide_char' by auto
abbreviation Prj\<^sub>1\<^sub>1
where "Prj\<^sub>1\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
abbreviation Prj\<^sub>0\<^sub>1
where "Prj\<^sub>0\<^sub>1 \<equiv> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
abbreviation Prj\<^sub>0
where "Prj\<^sub>0 \<equiv> \<p>\<^sub>0[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
abbreviation Prj\<^sub>1
where "Prj\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
abbreviation Prj\<^sub>1\<^sub>0
where "Prj\<^sub>1\<^sub>0 \<equiv> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1] \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
abbreviation Prj\<^sub>0\<^sub>0
where "Prj\<^sub>0\<^sub>0 \<equiv> \<p>\<^sub>0[\<nu>.leg0, \<pi>.leg1] \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
lemma leg0_composite:
shows "\<mu>\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0\<^sub>0"
and "\<mu>\<nu>_\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0"
proof -
show "\<mu>\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0\<^sub>0"
using hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composite_is_arrow \<nu>\<pi>.composite_simps(2)
C.comp_assoc
by auto
show "\<mu>\<nu>_\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0"
using hcomp_def \<mu>\<nu>.composite_is_arrow \<mu>\<nu>.composite_simps(1) \<nu>\<pi>.composable by auto
qed
lemma leg1_composite:
shows "\<mu>\<nu>\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1"
and "\<mu>\<nu>_\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1\<^sub>1"
proof -
show "\<mu>\<nu>\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1"
using hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composite_is_arrow \<nu>\<pi>.composite_simps(2) by auto
show "\<mu>\<nu>_\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1\<^sub>1"
using hcomp_def \<mu>\<nu>.composite_is_arrow \<mu>\<nu>.composite_simps(1) \<nu>\<pi>.composable
C.comp_assoc
by auto
qed
definition chine_assoc
where "chine_assoc \<equiv>
\<langle>Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]\<rbrakk> \<langle>Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>.leg1\<rbrakk> Prj\<^sub>0\<rangle>\<rangle>"
definition chine_assoc'
where "chine_assoc' \<equiv>
\<langle>\<langle>Prj\<^sub>1 \<lbrakk>\<mu>.leg0, \<nu>.leg1\<rbrakk> Prj\<^sub>1\<^sub>0\<rangle> \<lbrakk>\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1\<rbrakk> Prj\<^sub>0\<^sub>0\<rangle>"
(*
* Don't be fooled by how short the following proofs look -- there's a heck of a lot
* going on behind the scenes here!
*)
lemma chine_composite:
shows "\<mu>\<nu>_\<pi>.chine = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<down>\<down> \<pi>.leg1"
and "\<mu>\<nu>\<pi>.chine = \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1"
proof -
show "\<mu>\<nu>_\<pi>.chine = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<down>\<down> \<pi>.leg1"
using hcomp_def chine_hcomp_arr_ide [of "hcomp \<mu> \<nu>" \<pi>] chine_hcomp_ide_ide
src_def trg_def \<mu>\<nu>.composable \<nu>\<pi>.composable \<mu>\<nu>.ide_composite
\<mu>\<nu>.are_identities \<nu>\<pi>.are_identities(2)
by simp
show "\<mu>\<nu>\<pi>.chine = \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1"
using hcomp_def chine_hcomp_ide_arr [of \<mu> "hcomp \<nu> \<pi>"] chine_hcomp_ide_ide
src_def trg_def \<mu>\<nu>.composable \<nu>\<pi>.composable \<nu>\<pi>.ide_composite
\<mu>\<nu>.are_identities \<nu>\<pi>.are_identities(2)
by simp
qed
lemma prj_in_hom [intro]:
shows "\<guillemotleft>Prj\<^sub>1\<^sub>1 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
and "\<guillemotleft>Prj\<^sub>0\<^sub>1 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
and "\<guillemotleft>Prj\<^sub>0 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<pi>.apex\<guillemotright>"
and "\<guillemotleft>Prj\<^sub>1 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
and "\<guillemotleft>Prj\<^sub>1\<^sub>0 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
and "\<guillemotleft>Prj\<^sub>0\<^sub>0 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<pi>.apex\<guillemotright>"
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite by auto
lemma prj_simps [simp]:
shows "C.arr Prj\<^sub>1\<^sub>1"
and "C.arr Prj\<^sub>0\<^sub>1"
and "C.arr Prj\<^sub>0"
and "C.dom Prj\<^sub>1\<^sub>1 = \<mu>\<nu>_\<pi>.chine"
and "C.dom Prj\<^sub>0\<^sub>1 = \<mu>\<nu>_\<pi>.chine"
and "C.dom Prj\<^sub>0 = \<mu>\<nu>_\<pi>.chine"
and "C.cod Prj\<^sub>1\<^sub>1 = \<mu>.apex"
and "C.cod Prj\<^sub>0\<^sub>1 = \<nu>.apex"
and "C.cod Prj\<^sub>0 = \<pi>.apex"
and "C.arr Prj\<^sub>1"
and "C.arr Prj\<^sub>1\<^sub>0"
and "C.arr Prj\<^sub>0\<^sub>0"
and "C.dom Prj\<^sub>1 = \<mu>\<nu>\<pi>.chine"
and "C.dom Prj\<^sub>1\<^sub>0 = \<mu>\<nu>\<pi>.chine"
and "C.dom Prj\<^sub>0\<^sub>0 = \<mu>\<nu>\<pi>.chine"
and "C.cod Prj\<^sub>1 = \<mu>.apex"
and "C.cod Prj\<^sub>1\<^sub>0 = \<nu>.apex"
and "C.cod Prj\<^sub>0\<^sub>0 = \<pi>.apex"
using prj_in_hom by auto
lemma chine_assoc_props:
shows "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
and "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
and "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
and "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
proof -
have 1: "\<nu>.leg0 \<cdot> Prj\<^sub>0\<^sub>1 = \<pi>.leg1 \<cdot> Prj\<^sub>0"
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
C.pullback_commutes [of "\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]" \<pi>.leg1] C.comp_assoc
by auto
have 2: "\<mu>.leg0 \<cdot> Prj\<^sub>1\<^sub>1 = \<nu>.leg1 \<cdot> Prj\<^sub>0\<^sub>1"
proof -
have "\<mu>.leg0 \<cdot> Prj\<^sub>1\<^sub>1 = (\<mu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>1) \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1]"
using C.comp_assoc by auto
also have "... = \<nu>.leg1 \<cdot> Prj\<^sub>0\<^sub>1"
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
C.pullback_commutes
by (auto simp add: C.commutative_square_def C.comp_assoc)
finally show ?thesis by simp
qed
show "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
unfolding chine_assoc_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def chine_composite C.comp_assoc by auto
show "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
unfolding chine_assoc_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def C.comp_assoc
by auto
show "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
unfolding chine_assoc_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def C.comp_assoc
by auto
show "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
unfolding chine_assoc_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def C.comp_assoc
by auto
qed
lemma chine_assoc_in_hom [intro]:
shows "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
using chine_assoc_props(1) by simp
lemma prj_chine_assoc [simp]:
shows "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
and "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
and "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
using chine_assoc_props(2-4) by auto
lemma chine_assoc'_props:
shows "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
and "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
and "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
and "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
proof -
have 1: "\<mu>.leg0 \<cdot> Prj\<^sub>1 = \<nu>.leg1 \<cdot> Prj\<^sub>1\<^sub>0"
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable
src_def trg_def C.pullback_commutes [of \<mu>.leg0 "\<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]"]
C.comp_assoc
by auto
have 2: "\<nu>.leg0 \<cdot> Prj\<^sub>1\<^sub>0 = \<pi>.leg1 \<cdot> Prj\<^sub>0\<^sub>0"
proof -
have "\<nu>.leg0 \<cdot> Prj\<^sub>1\<^sub>0 = (\<nu>.leg0 \<cdot> \<nu>\<pi>.prj\<^sub>1) \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1]"
using C.comp_assoc by simp
also have "... = \<pi>.leg1 \<cdot> Prj\<^sub>0\<^sub>0"
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
C.pullback_commutes
by (auto simp add: C.commutative_square_def C.comp_assoc)
finally show ?thesis by auto
qed
show "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
unfolding chine_assoc'_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def chine_composite C.comp_assoc
by auto
show "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
unfolding chine_assoc'_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def C.comp_assoc
by auto
show "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
unfolding chine_assoc'_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def C.comp_assoc
by auto
show "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
unfolding chine_assoc'_def
using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
src_def trg_def C.comp_assoc
by auto
qed
lemma chine_assoc'_in_hom [intro]:
shows "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
using chine_assoc'_props(1) by simp
lemma prj_chine_assoc' [simp]:
shows "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
and "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
and "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
using chine_assoc'_props(2-4) by auto
lemma prj_joint_monic:
assumes "\<guillemotleft>h: a \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>" and "\<guillemotleft>h': a \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
and "Prj\<^sub>1\<^sub>1 \<cdot> h = Prj\<^sub>1\<^sub>1 \<cdot> h'" and "Prj\<^sub>0\<^sub>1 \<cdot> h = Prj\<^sub>0\<^sub>1 \<cdot> h'" and "Prj\<^sub>0 \<cdot> h = Prj\<^sub>0 \<cdot> h'"
shows "h = h'"
proof -
have "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
proof -
have "\<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(1)
C.comp_assoc
by force
moreover
have "\<mu>\<nu>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(1)
C.comp_assoc
by force
ultimately show ?thesis
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
chine_composite(1) cod_char
C.prj_joint_monic
[of \<mu>.leg0 \<nu>.leg1 "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h"
"\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"]
by auto
qed
moreover have "Prj\<^sub>0 \<cdot> h = Prj\<^sub>0 \<cdot> h'"
using assms cod_char by simp
ultimately show ?thesis
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
chine_composite(1) cod_char
C.prj_joint_monic [of "\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0" \<pi>.leg1 h h']
by auto
qed
lemma prj'_joint_monic:
assumes "\<guillemotleft>h: a \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>" and "\<guillemotleft>h': a \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
and "Prj\<^sub>1 \<cdot> h = Prj\<^sub>1 \<cdot> h'" and "Prj\<^sub>1\<^sub>0 \<cdot> h = Prj\<^sub>1\<^sub>0 \<cdot> h'" and "Prj\<^sub>0\<^sub>0 \<cdot> h = Prj\<^sub>0\<^sub>0 \<cdot> h'"
shows "h = h'"
proof -
have "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
proof -
have "\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
C.comp_assoc
by force
moreover
have "\<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
C.comp_assoc
by force
ultimately show ?thesis
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
chine_composite(2) cod_char
C.prj_joint_monic
[of \<nu>.leg0 \<pi>.leg1 "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h"
"\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"]
by auto
qed
moreover have "Prj\<^sub>1 \<cdot> h = Prj\<^sub>1 \<cdot> h'"
using assms cod_char by simp
ultimately show ?thesis
using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
C.prj_joint_monic [of \<mu>.leg0 "\<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1" h h']
by auto
qed
lemma chine_assoc_inverse:
shows "C.inverse_arrows chine_assoc chine_assoc'"
proof
show "C.ide (chine_assoc' \<cdot> chine_assoc)"
proof -
have 1: "C.ide \<mu>\<nu>_\<pi>.chine"
using chine_assoc_props(1) C.ide_dom by fastforce
have "chine_assoc' \<cdot> chine_assoc = \<mu>\<nu>_\<pi>.chine"
proof -
have 2: "C.seq chine_assoc' chine_assoc"
using chine_assoc_props(1) chine_assoc'_props(1) by auto
have 3: "C.seq Prj\<^sub>1\<^sub>1 chine_assoc' \<and> C.seq Prj\<^sub>0\<^sub>1 chine_assoc' \<and> C.seq Prj\<^sub>0 chine_assoc'"
using prj_in_hom chine_assoc'_props(1) by auto
have "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine"
proof -
have "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc') \<cdot> chine_assoc"
using C.comp_assoc by metis
thus ?thesis using 1 C.comp_arr_dom by simp
qed
moreover have "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine"
proof -
have "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc') \<cdot> chine_assoc"
using C.comp_assoc by metis
thus ?thesis using 1 C.comp_arr_dom by simp
qed
moreover have "Prj\<^sub>0 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.chine"
proof -
have "Prj\<^sub>0 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>0 \<cdot> chine_assoc') \<cdot> chine_assoc"
using C.comp_assoc by metis
thus ?thesis using 1 C.comp_arr_dom C.comp_arr_ide prj_in_hom(3) by auto
qed
moreover have "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
using chine_assoc_props(1) C.ide_dom [of chine_assoc]
by (elim C.in_homE, auto)
ultimately show ?thesis
using chine_assoc_props(1) chine_assoc'_props(1)
prj_joint_monic [of "chine_assoc' \<cdot> chine_assoc" "\<mu>\<nu>_\<pi>.chine" "\<mu>\<nu>_\<pi>.chine"]
by auto
qed
thus ?thesis
using 1 by simp
qed
show "C.ide (chine_assoc \<cdot> chine_assoc')"
proof -
have 1: "C.ide \<mu>\<nu>\<pi>.chine"
using chine_assoc_props(1) C.ide_cod by fastforce
have "chine_assoc \<cdot> chine_assoc' = \<mu>\<nu>\<pi>.chine"
proof -
have 2: "C.seq chine_assoc chine_assoc'"
using chine_assoc_props(1) chine_assoc'_props(1) by auto
have 3: "C.seq Prj\<^sub>1 chine_assoc \<and> C.seq Prj\<^sub>1\<^sub>0 chine_assoc \<and> C.seq Prj\<^sub>0\<^sub>0 chine_assoc"
using prj_in_hom chine_assoc_props(1) by auto
have "Prj\<^sub>1 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine"
proof -
have "Prj\<^sub>1 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>1 \<cdot> chine_assoc) \<cdot> chine_assoc'"
using C.comp_assoc by metis
thus ?thesis using 1 C.comp_arr_dom prj_in_hom(4) by auto
qed
moreover have "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine"
proof -
have "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc) \<cdot> chine_assoc'"
using C.comp_assoc by metis
thus ?thesis using 1 C.comp_arr_dom by simp
qed
moreover have "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine"
proof -
have "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc) \<cdot> chine_assoc'"
using C.comp_assoc by metis
thus ?thesis using 1 C.comp_arr_dom by simp
qed
moreover have "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
using chine_assoc'_props(1) C.ide_dom [of chine_assoc']
by (elim C.in_homE, auto)
ultimately show ?thesis
using chine_assoc_props(1) chine_assoc'_props(1)
prj'_joint_monic [of "chine_assoc \<cdot> chine_assoc'" "\<mu>\<nu>\<pi>.chine" "\<mu>\<nu>\<pi>.chine"]
by auto
qed
thus ?thesis
using 1 by simp
qed
qed
end
context three_composable_arrows_of_spans
begin
interpretation V: category vcomp
using is_category by auto
interpretation H: horizontal_homs vcomp src trg
using has_horizontal_homs by auto
interpretation dom_\<mu>: arrow_of_spans C \<open>dom \<mu>\<close>
using \<mu>.arrow_of_spans_axioms arr_char [of "dom \<mu>"] by auto
interpretation dom_\<nu>: arrow_of_spans C \<open>dom \<nu>\<close>
using \<nu>.arrow_of_spans_axioms arr_char [of "dom \<nu>"] by auto
interpretation dom_\<pi>: arrow_of_spans C \<open>dom \<pi>\<close>
using \<pi>.arrow_of_spans_axioms arr_char [of "dom \<pi>"] by auto
interpretation doms: three_composable_identity_arrows_of_spans C prj0 prj1
\<open>dom \<mu>\<close> \<open>dom \<nu>\<close> \<open>dom \<pi>\<close>
using \<mu>\<nu>.composable \<nu>\<pi>.composable ide_char [of "dom \<mu>"] ide_char [of "dom \<nu>"]
ide_char [of "dom \<pi>"]
by (unfold_locales, auto)
interpretation cod_\<mu>: arrow_of_spans C \<open>cod \<mu>\<close>
using \<mu>.arrow_of_spans_axioms arr_char [of "cod \<mu>"] by auto
interpretation cod_\<nu>: arrow_of_spans C \<open>cod \<nu>\<close>
using \<nu>.arrow_of_spans_axioms arr_char [of "cod \<nu>"] by auto
interpretation cod_\<pi>: arrow_of_spans C \<open>cod \<pi>\<close>
using \<pi>.arrow_of_spans_axioms arr_char [of "cod \<pi>"] by auto
interpretation cods: three_composable_identity_arrows_of_spans C prj0 prj1
\<open>cod \<mu>\<close> \<open>cod \<nu>\<close> \<open>cod \<pi>\<close>
using \<mu>\<nu>.composable \<nu>\<pi>.composable ide_char [of "cod \<mu>"] ide_char [of "cod \<nu>"]
ide_char [of "cod \<pi>"]
by (unfold_locales, auto)
interpretation \<mu>\<nu>\<pi>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
using \<mu>.arrow_of_spans_axioms \<nu>\<pi>.arrow_of_spans_axioms
arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
by force
interpretation \<mu>\<nu>_\<pi>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
using \<mu>\<nu>.arrow_of_spans_axioms \<pi>.arrow_of_spans_axioms
arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
by force
lemma chine_composite':
shows "\<mu>\<nu>\<pi>.chine = \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
\<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>\<rangle>"
and "\<mu>\<nu>_\<pi>.chine = \<langle>\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>
\<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> doms.Prj\<^sub>0\<rangle>"
proof -
show "\<mu>\<nu>_\<pi>.chine = \<langle>\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>
\<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> doms.Prj\<^sub>0\<rangle>"
proof -
have "arr (\<mu> \<star> \<nu>)" by simp
thus ?thesis
unfolding hcomp_def chine_hcomp_def dom_char
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char chine_hcomp_props
C.comp_tuple_arr C.pullback_commutes C.comp_assoc
by auto
qed
show "\<mu>\<nu>\<pi>.chine = \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
\<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>\<rangle>"
proof -
have "arr (\<nu> \<star> \<pi>)" by simp
thus ?thesis
unfolding hcomp_def chine_hcomp_def dom_char
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char chine_hcomp_props
C.comp_tuple_arr C.pullback_commutes C.comp_assoc
by auto
qed
qed
lemma chine_composite_in_hom [intro]:
shows "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn ((cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>)\<guillemotright>"
and "\<guillemotleft>\<mu>\<nu>\<pi>.chine : Chn (dom \<mu> \<star> dom \<nu> \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
proof -
interpret \<mu>\<nu>: arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
using arrow_of_spans_hcomp \<mu>\<nu>.composable by auto
interpret \<nu>\<pi>: arrow_of_spans C \<open>\<nu> \<star> \<pi>\<close>
using arrow_of_spans_hcomp \<nu>\<pi>.composable by auto
show "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn ((cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>)\<guillemotright>"
proof -
have "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<mu>\<nu>.dom.leg0 \<down>\<down> \<pi>.dom.leg1 \<rightarrow>\<^sub>C \<mu>\<nu>.cod.leg0 \<down>\<down> \<pi>.cod.leg1\<guillemotright>"
proof -
have "src (\<mu> \<star> \<nu>) = trg \<pi>"
using \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
moreover have "arr (\<mu> \<star> \<nu>)"
using \<mu>\<nu>.arrow_of_spans_axioms by auto
ultimately show ?thesis
using hcomp_def chine_hcomp_props(1) [of \<pi> "\<mu> \<star> \<nu>"] by auto
qed
hence "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1] \<down>\<down> \<pi>.dom.leg1 \<rightarrow>\<^sub>C
\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1] \<down>\<down> \<pi>.cod.leg1\<guillemotright>"
unfolding hcomp_def using \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
thus ?thesis
using doms.chine_composite(1) cods.chine_composite(1) dom_char cod_char
by auto
qed
show "\<guillemotleft>\<mu>\<nu>\<pi>.chine : Chn (dom \<mu> \<star> dom \<nu> \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
proof -
have "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>.dom.leg0 \<down>\<down> \<nu>\<pi>.dom.leg1 \<rightarrow>\<^sub>C \<mu>.cod.leg0 \<down>\<down> \<nu>\<pi>.cod.leg1\<guillemotright>"
proof -
have "src \<mu> = trg (\<nu> \<star> \<pi>)"
using trg_hcomp \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
moreover have "arr (\<nu> \<star> \<pi>)"
using \<mu>\<nu>.arrow_of_spans_axioms by auto
ultimately show ?thesis
using hcomp_def chine_hcomp_props(1) [of "\<nu> \<star> \<pi>" \<mu>] by auto
qed
hence "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>.dom.leg0 \<down>\<down> \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1] \<rightarrow>\<^sub>C
\<mu>.cod.leg0 \<down>\<down> \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<guillemotright>"
unfolding hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
thus ?thesis
using doms.chine_composite(2) cods.chine_composite(2) dom_char cod_char
by auto
qed
qed
lemma cospan_\<mu>\<nu>:
shows "C.cospan \<mu>.dom.leg0 \<nu>.dom.leg1"
using \<mu>\<nu>.legs_form_cospan by simp
lemma cospan_\<nu>\<pi>:
shows "C.cospan \<nu>.dom.leg0 \<pi>.dom.leg1"
using \<nu>\<pi>.legs_form_cospan by simp
lemma commutativities:
shows "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
and "\<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0 =
(\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
proof -
have AB: "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>1"
proof -
have "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>1 =
(\<mu>.dom.leg0 \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
\<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
by simp
also have "... = (\<nu>.dom.leg1 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
\<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
using C.pullback_commutes' \<mu>\<nu>.legs_form_cospan by auto
also have "... = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>1"
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
by simp
finally show ?thesis by auto
qed
have BC: "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>0\<^sub>1 = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0"
proof -
have "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>0\<^sub>1 =
(\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
\<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
by simp
also have "... = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0"
using C.pullback_commutes' dom_char cod_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan
by auto
finally show ?thesis by simp
qed
show 1: "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
using AB C.comp_assoc [of \<mu>.cod.leg0 \<mu>.chine]
C.comp_assoc [of \<nu>.cod.leg1 \<nu>.chine doms.Prj\<^sub>0\<^sub>1]
by simp
show "\<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0 =
(\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
proof -
have "(\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle> =
\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
using 1 \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc by simp
also have "... = \<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
using 1 dom_char \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def by simp
also have "... = (\<nu>.cod.leg0 \<cdot> \<nu>.chine) \<cdot> doms.Prj\<^sub>0\<^sub>1"
using C.comp_assoc [of \<nu>.cod.leg0 \<nu>.chine doms.Prj\<^sub>0\<^sub>1] by simp
also have "... = (\<pi>.cod.leg1 \<cdot> \<pi>.chine) \<cdot> doms.Prj\<^sub>0"
using BC by simp
also have "... = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0"
using C.comp_assoc by blast
finally show ?thesis by simp
qed
qed
lemma prj_chine_composite:
shows "cods.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine = \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1"
and "cods.Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine = \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
and "cods.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.chine = \<pi>.chine \<cdot> doms.Prj\<^sub>0"
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char cod_char commutativities
chine_composite' C.comp_assoc
by auto
lemma commutativities':
shows "\<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
and "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1 =
(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
\<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
proof -
have AB: "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1 = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>1\<^sub>0"
using C.pullback_commutes' dom_char cod_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan
C.comp_assoc
by auto
have BC: "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>0"
proof -
have "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>0 =
(\<nu>.dom.leg0 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]) \<cdot>
\<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]"
using dom_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan C.comp_assoc by simp
also have "... = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>0"
using C.pullback_commutes' dom_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan C.comp_assoc
by simp
finally show ?thesis by auto
qed
show 1: "\<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
using BC C.comp_assoc [of \<nu>.cod.leg0 \<nu>.chine doms.Prj\<^sub>1\<^sub>0]
C.comp_assoc [of \<pi>.cod.leg1 \<pi>.chine doms.Prj\<^sub>0\<^sub>0]
doms.prj_in_hom(5-6) dom_char
by force
show "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1 =
(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
\<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
proof -
have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
\<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle> =
\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1] \<cdot>
\<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
using 1 \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc by simp
also have "... = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0"
using 1 dom_char \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
by simp
also have "... = (\<nu>.cod.leg1 \<cdot> \<nu>.chine) \<cdot> doms.Prj\<^sub>1\<^sub>0"
using C.comp_assoc [of \<nu>.cod.leg1 \<nu>.chine doms.Prj\<^sub>1\<^sub>0] by auto
also have "... = (\<mu>.cod.leg0 \<cdot> \<mu>.chine) \<cdot> doms.Prj\<^sub>1"
using AB by simp
also have "... = \<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1"
using C.comp_assoc [of \<mu>.cod.leg0 \<mu>.chine doms.Prj\<^sub>1] doms.prj_in_hom(4) dom_char
by auto
finally show ?thesis by simp
qed
qed
lemma prj'_chine_composite:
shows "cods.Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine = \<mu>.chine \<cdot> doms.Prj\<^sub>1"
and "cods.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine = \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0"
and "cods.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine = \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char cod_char commutativities'
chine_composite' C.comp_assoc
by auto
lemma chine_assoc_naturality:
shows "cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine = \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
proof -
have "\<guillemotleft>cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine :
Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
using cods.chine_assoc_props(1) chine_composite_in_hom(1) by blast
moreover have "\<guillemotleft>\<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc :
Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
using doms.chine_assoc_props(1) chine_composite_in_hom(2) by blast
moreover
have "cods.Prj\<^sub>1 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
cods.Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
using C.comp_assoc doms.chine_assoc_props(2) cods.chine_assoc_props(2)
prj_chine_composite prj'_chine_composite
by metis
moreover have "cods.Prj\<^sub>1\<^sub>0 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
cods.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
using C.comp_assoc doms.chine_assoc_props(3) cods.chine_assoc_props(3)
prj_chine_composite prj'_chine_composite
by metis
moreover have "cods.Prj\<^sub>0\<^sub>0 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
cods.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
using C.comp_assoc doms.chine_assoc_props(4) cods.chine_assoc_props(4)
prj_chine_composite prj'_chine_composite
by metis
ultimately show ?thesis
using cods.prj'_joint_monic by auto
qed
end
context span_bicategory
begin
interpretation VxV: product_category vcomp vcomp ..
interpretation VV: subcategory VxV.comp \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and>
src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
by (unfold_locales, simp_all)
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 H: horizontal_composition vcomp hcomp src trg
using has_horizontal_composition by auto
interpretation HoHV: "functor" VVV.comp vcomp HoHV
using functor_HoHV by blast
interpretation HoVH: "functor" VVV.comp vcomp HoVH
using functor_HoVH by blast
abbreviation (input) assoc\<^sub>S\<^sub>B
where "assoc\<^sub>S\<^sub>B f g h \<equiv> \<lparr>Chn = three_composable_identity_arrows_of_spans.chine_assoc
C prj0 prj1 f g h,
Dom = Dom ((f \<star> g) \<star> h), Cod = Cod (f \<star> g \<star> h)\<rparr>"
abbreviation (input) assoc'\<^sub>S\<^sub>B
where "assoc'\<^sub>S\<^sub>B f g h \<equiv> \<lparr>Chn = three_composable_identity_arrows_of_spans.chine_assoc'
C prj0 prj1 f g h,
Dom = Cod (f \<star> g \<star> h), Cod = Dom ((f \<star> g) \<star> h)\<rparr>"
lemma assoc_props:
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "src (assoc\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
and "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
and "src (assoc'\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
and "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
proof -
have fgh: "VVV.ide (f, g, h)"
using assms VVV.ide_char VV.ide_char VVV.arr_char VV.arr_char by simp
interpret f: arrow_of_spans C f
using assms arr_char by fastforce
interpret g: arrow_of_spans C g
using assms arr_char by fastforce
interpret h: arrow_of_spans C h
using assms arr_char by fastforce
interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
using assms arr_char by (unfold_locales, auto)
interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
using assms ide_char by (unfold_locales, auto)
interpret HHfgh: arrow_of_spans C \<open>(f \<star> g) \<star> h\<close>
using assms fgh.composites_are_arrows arrow_of_spans_hcomp by simp
interpret HfHgh: arrow_of_spans C \<open>f \<star> g \<star> h\<close>
using assms fgh.composites_are_arrows arrow_of_spans_hcomp by simp
interpret assoc_fgh: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B f g h\<close>
apply unfold_locales
apply simp_all
apply (metis C.ideD(2) C.ideD(3) HHfgh.chine_simps(2) HfHgh.chine_simps(3)
fgh.composites_are_identities(1) fgh.composites_are_identities(2)
fgh.chine_assoc_in_hom ide_char)
proof -
have 1: "arr (f \<star> g)" using fgh.\<mu>\<nu>.composite_is_arrow by simp
have 2: "arr (g \<star> h)" using fgh.\<nu>\<pi>.composite_is_arrow by simp
show "HfHgh.cod.leg0 \<cdot> fgh.chine_assoc = HHfgh.dom.leg0"
using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
fgh.chine_assoc_props(4) C.comp_assoc
by simp
show "HfHgh.cod.leg1 \<cdot> fgh.chine_assoc = HHfgh.dom.leg1"
using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
fgh.chine_assoc_props(2) C.comp_assoc
by simp
qed
interpret assoc'_fgh: arrow_of_spans C \<open>assoc'\<^sub>S\<^sub>B f g h\<close>
apply unfold_locales
apply simp_all
apply (metis C.ideD(2) C.ideD(3) HHfgh.chine_simps(2) HfHgh.chine_simps(3)
fgh.composites_are_identities(1) fgh.composites_are_identities(2)
fgh.chine_assoc'_in_hom ide_char)
proof -
have 1: "arr (f \<star> g)" using fgh.\<mu>\<nu>.composite_is_arrow by simp
have 2: "arr (g \<star> h)" using fgh.\<nu>\<pi>.composite_is_arrow by simp
show "HHfgh.dom.leg0 \<cdot> fgh.chine_assoc' = HfHgh.cod.leg0"
using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
C.comp_assoc fgh.chine_assoc'_props(4)
by simp
show "HHfgh.dom.leg1 \<cdot> fgh.chine_assoc' = HfHgh.cod.leg1"
using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
C.comp_assoc fgh.chine_assoc'_props(2)
by auto
qed
show 1: "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
proof
show 1: "arr (assoc\<^sub>S\<^sub>B f g h)"
using assoc_fgh.arrow_of_spans_axioms arr_char by blast
show "dom (assoc\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
using fgh 1 dom_char fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable ideD(2)
by auto
show "cod (assoc\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
using fgh 1 HoVH_def cod_char fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable ideD(3)
by auto
qed
show 2: "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
proof
show 1: "arr (assoc'\<^sub>S\<^sub>B f g h)"
using assoc'_fgh.arrow_of_spans_axioms arr_char by blast
show "dom (assoc'\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
using fgh 1 dom_char cod_char ideD(3) by auto
show "cod (assoc'\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
using fgh 1 cod_char dom_char ideD(2) by auto
qed
show 3: "src (assoc\<^sub>S\<^sub>B f g h) = src h"
proof -
have 4: "src (assoc\<^sub>S\<^sub>B f g h) =
\<lparr>Chn = assoc_fgh.dsrc, Dom = \<lparr>Leg0 = assoc_fgh.dsrc, Leg1 = assoc_fgh.dsrc\<rparr>,
Cod = \<lparr>Leg0 = assoc_fgh.dsrc, Leg1 = assoc_fgh.dsrc\<rparr>\<rparr>"
unfolding src_def using 1 by auto
also have "... = src h"
using fgh.composite_simps(2) src_def by auto
finally show ?thesis by blast
qed
show "src (assoc'\<^sub>S\<^sub>B f g h) = src h"
proof -
have "src (assoc'\<^sub>S\<^sub>B f g h) =
\<lparr>Chn = assoc'_fgh.dsrc, Dom = \<lparr>Leg0 = assoc'_fgh.dsrc, Leg1 = assoc'_fgh.dsrc\<rparr>,
Cod = \<lparr>Leg0 = assoc'_fgh.dsrc, Leg1 = assoc'_fgh.dsrc\<rparr>\<rparr>"
unfolding src_def using 2 by auto
also have "... = src h"
using 1 3 assoc_fgh.cod_src_eq_dom_src arrI src_def by auto
finally show ?thesis by blast
qed
show 4: "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
proof -
have 5: "trg (assoc\<^sub>S\<^sub>B f g h) =
\<lparr>Chn = assoc_fgh.dtrg, Dom = \<lparr>Leg0 = assoc_fgh.dtrg, Leg1 = assoc_fgh.dtrg\<rparr>,
Cod = \<lparr>Leg0 = assoc_fgh.dtrg, Leg1 = assoc_fgh.dtrg\<rparr>\<rparr>"
unfolding trg_def using 1 by auto
also have "... = trg f"
using fgh.composite_simps(4) trg_def by auto
finally show ?thesis by blast
qed
show "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
proof -
have 5: "trg (assoc'\<^sub>S\<^sub>B f g h) =
\<lparr>Chn = assoc'_fgh.dtrg, Dom = \<lparr>Leg0 = assoc'_fgh.dtrg, Leg1 = assoc'_fgh.dtrg\<rparr>,
Cod = \<lparr>Leg0 = assoc'_fgh.dtrg, Leg1 = assoc'_fgh.dtrg\<rparr>\<rparr>"
unfolding trg_def using 2 by auto
also have "... = trg f"
using 1 4 assoc_fgh.cod_trg_eq_dom_trg arrI trg_def by auto
finally show ?thesis by blast
qed
qed
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 "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright> "
using assms assoc_props 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 "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright> "
using assms assoc_props by auto
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 (assoc\<^sub>S\<^sub>B f g h)" and "dom (assoc\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
and "cod (assoc\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
and "src (assoc\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
using assms assoc_props(1-3) by (fast, fast, fast, auto)
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 (assoc'\<^sub>S\<^sub>B f g h)" and "dom (assoc'\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
and "cod (assoc'\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
and "src (assoc'\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
using assms assoc_props(4-6) by (fast, fast, fast, auto)
lemma inverse_assoc_assoc':
assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
shows "inverse_arrows (assoc\<^sub>S\<^sub>B f g h) (assoc'\<^sub>S\<^sub>B f g h)"
proof -
interpret f: arrow_of_spans C f using assms arr_char ideD(1) by simp
interpret g: arrow_of_spans C g using assms arr_char ideD(1) by simp
interpret h: arrow_of_spans C h using assms arr_char ideD(1) by simp
interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
using assms arr_char by (unfold_locales, auto)
interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
using assms ide_char
apply unfold_locales
apply blast
apply blast
by blast
interpret afgh: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B f g h\<close>
using assms assoc_props(3) arr_char by blast
interpret a'fgh: arrow_of_spans C \<open>assoc'\<^sub>S\<^sub>B f g h\<close>
using assms assoc_props(6) arr_char by blast
show ?thesis
proof -
have "inverse_arrows (assoc\<^sub>S\<^sub>B f g h)
\<lparr>Chn = C.inv (Chn (assoc\<^sub>S\<^sub>B f g h)),
Dom = Cod (assoc\<^sub>S\<^sub>B f g h), Cod = Dom (assoc\<^sub>S\<^sub>B f g h)\<rparr>"
using inverse_arrows [of "assoc\<^sub>S\<^sub>B f g h"] afgh.arrow_of_spans_axioms
arr_char fgh.chine_assoc_inverse
by auto
moreover have "C.inv (Chn (assoc\<^sub>S\<^sub>B f g h)) = fgh.chine_assoc'"
using fgh.chine_assoc_inverse C.inv_is_inverse C.inverse_arrow_unique by auto
ultimately show ?thesis by simp
qed
qed
interpretation \<alpha>: transformation_by_components VVV.comp vcomp HoHV HoVH
\<open>\<lambda>fgh. assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))\<close>
proof
show *: "\<And>fgh. VVV.ide fgh \<Longrightarrow> \<guillemotleft>assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)) :
HoHV fgh \<Rightarrow> HoVH fgh\<guillemotright>"
proof -
fix fgh
assume fgh: "VVV.ide fgh"
show "\<guillemotleft>assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)) : HoHV fgh \<Rightarrow> HoVH fgh\<guillemotright>"
unfolding HoHV_def HoVH_def
using fgh assoc_in_hom [of "fst fgh" "fst (snd fgh)" "snd (snd fgh)"]
VVV.arr_char VVV.ide_char VV.arr_char
by simp
qed
show "\<And>\<mu>\<nu>\<pi>. VVV.arr \<mu>\<nu>\<pi> \<Longrightarrow>
assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
(snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
HoHV \<mu>\<nu>\<pi> =
HoVH \<mu>\<nu>\<pi> \<bullet> assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
(snd (snd (VVV.dom \<mu>\<nu>\<pi>)))"
proof -
fix \<mu>\<nu>\<pi>
assume \<mu>\<nu>\<pi>: "VVV.arr \<mu>\<nu>\<pi>"
interpret \<mu>: arrow_of_spans C \<open>fst \<mu>\<nu>\<pi>\<close>
using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char arr_char by auto
interpret \<nu>: arrow_of_spans C \<open>fst (snd \<mu>\<nu>\<pi>)\<close>
using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
interpret \<pi>: arrow_of_spans C \<open>snd (snd \<mu>\<nu>\<pi>)\<close>
using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
interpret \<mu>\<nu>\<pi>: three_composable_arrows_of_spans C prj0 prj1
\<open>fst \<mu>\<nu>\<pi>\<close> \<open>fst (snd \<mu>\<nu>\<pi>)\<close> \<open>snd (snd \<mu>\<nu>\<pi>)\<close>
using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char
by (unfold_locales, auto)
interpret HoHV_\<mu>\<nu>\<pi>: arrow_of_spans C \<open>(fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>)) \<star> snd (snd \<mu>\<nu>\<pi>)\<close>
proof -
have "arr (HoHV \<mu>\<nu>\<pi>)"
using \<mu>\<nu>\<pi> by simp
thus "arrow_of_spans C ((fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>)) \<star> snd (snd \<mu>\<nu>\<pi>))"
using \<mu>\<nu>\<pi> HoHV_def arr_char by auto
qed
interpret HoVH_\<mu>\<nu>\<pi>: arrow_of_spans C \<open>fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>) \<star> snd (snd \<mu>\<nu>\<pi>)\<close>
proof -
have "arr (HoVH \<mu>\<nu>\<pi>)"
using \<mu>\<nu>\<pi> by simp
thus "arrow_of_spans C (fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>) \<star> snd (snd \<mu>\<nu>\<pi>))"
using \<mu>\<nu>\<pi> HoVH_def arr_char by auto
qed
have dom_\<mu>\<nu>\<pi>: "VVV.ide (VVV.dom \<mu>\<nu>\<pi>)"
using \<mu>\<nu>\<pi> VVV.ide_dom by blast
interpret dom_\<mu>: identity_arrow_of_spans C \<open>fst (VVV.dom \<mu>\<nu>\<pi>)\<close>
using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
interpret dom_\<nu>: identity_arrow_of_spans C \<open>fst (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
interpret dom_\<pi>: identity_arrow_of_spans C \<open>snd (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
interpret dom_\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1
\<open>fst (VVV.dom \<mu>\<nu>\<pi>)\<close> \<open>fst (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
\<open>snd (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
using dom_\<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char
by (unfold_locales, auto)
interpret assoc_dom_\<mu>\<nu>\<pi>: arrow_of_spans C
\<open>assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
(snd (snd (VVV.dom \<mu>\<nu>\<pi>)))\<close>
using \<mu>\<nu>\<pi> VVV.ide_dom * arr_char by fast
have cod_\<mu>\<nu>\<pi>: "VVV.ide (VVV.cod \<mu>\<nu>\<pi>)"
using \<mu>\<nu>\<pi> VVV.ide_cod by blast
interpret cod_\<mu>: identity_arrow_of_spans C \<open>fst (VVV.cod \<mu>\<nu>\<pi>)\<close>
using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
interpret cod_\<nu>: identity_arrow_of_spans C \<open>fst (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
interpret cod_\<pi>: identity_arrow_of_spans C \<open>snd (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
interpret cod_\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1
\<open>fst (VVV.cod \<mu>\<nu>\<pi>)\<close> \<open>fst (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
\<open>snd (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
using cod_\<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char
by (unfold_locales, auto)
interpret assoc_cod_\<mu>\<nu>\<pi>: arrow_of_spans C
\<open>assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
(snd (snd (VVV.cod \<mu>\<nu>\<pi>)))\<close>
using \<mu>\<nu>\<pi> VVV.ide_cod * arr_char by fast
have dom_legs:
"dom_\<mu>.leg0 = \<mu>.dom.leg0 \<and> dom_\<nu>.leg0 = \<nu>.dom.leg0 \<and> dom_\<pi>.leg0 = \<pi>.dom.leg0 \<and>
dom_\<mu>.leg1 = \<mu>.dom.leg1 \<and> dom_\<nu>.leg1 = \<nu>.dom.leg1 \<and> dom_\<pi>.leg1 = \<pi>.dom.leg1"
using VVV.arr_char VVV.dom_char dom_char \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable
by auto
have cod_legs:
"cod_\<mu>.leg0 = \<mu>.cod.leg0 \<and> cod_\<nu>.leg0 = \<nu>.cod.leg0 \<and> cod_\<pi>.leg0 = \<pi>.cod.leg0 \<and>
cod_\<mu>.leg1 = \<mu>.cod.leg1 \<and> cod_\<nu>.leg1 = \<nu>.cod.leg1 \<and> cod_\<pi>.leg1 = \<pi>.cod.leg1"
using \<mu>\<nu>\<pi> VVV.cod_char cod_char by auto
have Prj\<^sub>1\<^sub>1_dom: "dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 =
\<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1] \<cdot>
\<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
using dom_legs by argo
have Prj\<^sub>1\<^sub>1_cod: "cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 =
\<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
\<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
using cod_legs by argo
have Prj\<^sub>0_dom: "dom_\<mu>\<nu>\<pi>.Prj\<^sub>0 = \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
using dom_legs by argo
have Prj\<^sub>0_cod: "cod_\<mu>\<nu>\<pi>.Prj\<^sub>0 = \<p>\<^sub>0[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
using cod_legs by argo
have Dom: "Dom ((fst (VVV.dom \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.dom \<mu>\<nu>\<pi>))) \<star>
snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
\<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>"
proof -
have "arr (dom (fst \<mu>\<nu>\<pi>) \<star> dom (fst (snd \<mu>\<nu>\<pi>)))"
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
thus ?thesis
using \<mu>\<nu>\<pi> hcomp_def dom_legs ide_dom dom_char
apply simp
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
by auto
qed
have Cod: "Cod (fst (VVV.dom \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.dom \<mu>\<nu>\<pi>)) \<star>
snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
\<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>"
proof -
have "arr (dom (fst (snd \<mu>\<nu>\<pi>)) \<star> dom (snd (snd \<mu>\<nu>\<pi>)))"
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
thus ?thesis
using \<mu>\<nu>\<pi> hcomp_def dom_legs ide_dom dom_char
apply simp
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
by auto
qed
have Dom': "Dom ((fst (VVV.cod \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.cod \<mu>\<nu>\<pi>))) \<star>
snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
\<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>"
proof -
have "arr (cod (fst \<mu>\<nu>\<pi>) \<star> cod (fst (snd \<mu>\<nu>\<pi>)))"
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
moreover have "\<mu>.dsrc = \<nu>.dtrg"
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable src_def trg_def cod_char by simp
moreover have "\<nu>.dsrc = \<pi>.dtrg"
using \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char by simp
ultimately show ?thesis
using \<mu>\<nu>\<pi> hcomp_def cod_legs ide_cod cod_char
apply simp
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char C.comp_assoc
by simp
qed
have Cod': "Cod (fst (VVV.cod \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.cod \<mu>\<nu>\<pi>)) \<star>
snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
\<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>"
proof -
have "arr (cod (fst (snd \<mu>\<nu>\<pi>)) \<star> cod (snd (snd \<mu>\<nu>\<pi>)))"
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
moreover have "\<mu>.dsrc = \<nu>.dtrg"
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable src_def trg_def cod_char by simp
ultimately show ?thesis
using \<mu>\<nu>\<pi> hcomp_def cod_legs ide_cod cod_char
apply simp
using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char C.comp_assoc
by auto
qed
have assoc_dom:
"assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
(snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
\<lparr>Chn = dom_\<mu>\<nu>\<pi>.chine_assoc,
Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
using Dom Cod by simp
have assoc_cod:
"assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
(snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
\<lparr>Chn = cod_\<mu>\<nu>\<pi>.chine_assoc,
Dom = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
using Dom' Cod' by simp
have HoHV_\<mu>\<nu>\<pi>:
"HoHV \<mu>\<nu>\<pi> =
\<lparr>Chn = HoHV_\<mu>\<nu>\<pi>.chine,
Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>\<rparr>"
proof -
have "arr \<lparr>Chn = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
\<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
\<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle>,
Dom = \<lparr>Leg0 = \<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1],
Leg1 = \<mu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1],
Leg1 = \<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1]\<rparr>\<rparr>"
unfolding hcomp_def chine_hcomp_def
using \<mu>\<nu>\<pi> hcomp_def dom_legs cod_legs ide_dom ide_cod dom_char cod_char
\<mu>\<nu>\<pi>.\<mu>\<nu>.composable
by (metis (no_types, lifting) hseq_char(1) \<mu>\<nu>\<pi>.\<mu>\<nu>.composite_is_arrow chine_hcomp_def)
moreover have "(\<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
\<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1] =
\<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
\<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
using C.comp_assoc by simp
ultimately show ?thesis
unfolding HoHV_def hcomp_def chine_hcomp_def
using \<mu>\<nu>\<pi> \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_legs cod_legs
C.comp_assoc
by simp
qed
have HoVH_\<mu>\<nu>\<pi>:
"HoVH \<mu>\<nu>\<pi> =
\<lparr>Chn = HoVH_\<mu>\<nu>\<pi>.chine,
Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
proof -
have "arr \<lparr>Chn = \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
\<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
\<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle>,
Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1],
Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1],
Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rparr>\<rparr>"
unfolding hcomp_def chine_hcomp_def
using \<mu>\<nu>\<pi> hcomp_def dom_legs cod_legs ide_dom ide_cod dom_char cod_char
\<mu>\<nu>\<pi>.\<nu>\<pi>.composable
by (metis (no_types, lifting) hseq_char \<mu>\<nu>\<pi>.\<nu>\<pi>.composite_is_arrow chine_hcomp_def)
moreover have "(\<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot>
\<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]] =
\<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1] \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot>
\<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]]"
using C.comp_assoc by simp
ultimately show ?thesis
unfolding HoVH_def hcomp_def chine_hcomp_def
using \<mu>\<nu>\<pi> \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_legs cod_legs
C.comp_assoc
by simp
qed
have "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
(snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
HoHV \<mu>\<nu>\<pi> =
\<lparr>Chn = cod_\<mu>\<nu>\<pi>.chine_assoc \<cdot> HoHV_\<mu>\<nu>\<pi>.chine,
Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
proof -
have "arr (HoHV \<mu>\<nu>\<pi>)"
using \<mu>\<nu>\<pi> by simp
thus ?thesis
using vcomp_def HoHV_\<mu>\<nu>\<pi> HoHV_\<mu>\<nu>\<pi>.arrow_of_spans_axioms
assoc_cod_\<mu>\<nu>\<pi>.arrow_of_spans_axioms assoc_cod dom_legs cod_legs
arr_char
by simp
qed
moreover
have "HoVH \<mu>\<nu>\<pi> \<bullet>
assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
(snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
\<lparr>Chn = HoVH_\<mu>\<nu>\<pi>.chine \<cdot> dom_\<mu>\<nu>\<pi>.chine_assoc,
Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
proof -
have "arr (HoVH \<mu>\<nu>\<pi>)"
using \<mu>\<nu>\<pi> by simp
thus ?thesis
using vcomp_def HoVH_\<mu>\<nu>\<pi> HoVH_\<mu>\<nu>\<pi>.arrow_of_spans_axioms
assoc_dom_\<mu>\<nu>\<pi>.arrow_of_spans_axioms assoc_dom dom_legs cod_legs
arr_char
by simp
qed
moreover
have "cod_\<mu>\<nu>\<pi>.chine_assoc \<cdot> HoHV_\<mu>\<nu>\<pi>.chine = HoVH_\<mu>\<nu>\<pi>.chine \<cdot> dom_\<mu>\<nu>\<pi>.chine_assoc"
using \<mu>\<nu>\<pi> HoHV_def HoVH_def \<mu>\<nu>\<pi>.chine_assoc_naturality by simp
ultimately show "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
(snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
HoHV \<mu>\<nu>\<pi> =
HoVH \<mu>\<nu>\<pi> \<bullet>
assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
(snd (snd (VVV.dom \<mu>\<nu>\<pi>)))"
by argo
qed
qed
definition assoc ("\<a>[_, _, _]")
where "assoc \<equiv> \<lambda>\<mu> \<nu> \<pi>. \<alpha>.map (\<mu>, \<nu>, \<pi>)"
abbreviation (input) \<alpha>\<^sub>S\<^sub>B
where "\<alpha>\<^sub>S\<^sub>B \<equiv> \<lambda>\<mu>\<nu>\<pi>. assoc (fst \<mu>\<nu>\<pi>) (fst (snd \<mu>\<nu>\<pi>)) (snd (snd \<mu>\<nu>\<pi>))"
lemma \<alpha>_ide:
assumes "ide f" and "ide g" and "ide h"
and "src f = trg g" and "src g = trg h"
shows "\<alpha>\<^sub>S\<^sub>B (f, g, h) = assoc\<^sub>S\<^sub>B f g h"
using assms assoc_def \<alpha>.map_simp_ide VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
by simp
lemma natural_transformation_\<alpha>:
shows "natural_transformation VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B"
using assoc_def \<alpha>.natural_transformation_axioms by auto
interpretation \<alpha>: natural_transformation VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
using natural_transformation_\<alpha> by simp
interpretation \<alpha>: natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
proof
show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<alpha>\<^sub>S\<^sub>B fgh)"
proof -
fix fgh
assume fgh: "VVV.ide fgh"
interpret f: arrow_of_spans C \<open>fst fgh\<close>
using fgh VVV.ide_char VVV.arr_char arr_char by auto
interpret g: arrow_of_spans C \<open>fst (snd fgh)\<close>
using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
interpret h: arrow_of_spans C \<open>snd (snd fgh)\<close>
using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
interpret fgh: three_composable_arrows_of_spans C prj0 prj1
\<open>fst fgh\<close> \<open>fst (snd fgh)\<close> \<open>snd (snd fgh)\<close>
using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char
by (unfold_locales, auto)
interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1
\<open>fst fgh\<close> \<open>fst (snd fgh)\<close> \<open>snd (snd fgh)\<close>
using fgh VVV.ide_char VV.ide_char ide_char
apply unfold_locales
apply blast
apply blast
by blast
have 1: "arr (\<alpha>\<^sub>S\<^sub>B fgh)"
using fgh \<alpha>.preserves_reflects_arr VVV.ideD(1) by blast
have 2: "\<alpha>\<^sub>S\<^sub>B fgh = assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"
using fgh assoc_def \<alpha>_ide [of "fst fgh" "fst (snd fgh)" "snd (snd fgh)"]
VVV.ide_char VV.ide_char VVV.arr_char VV.arr_char
by simp
moreover have "iso ..."
using 1 2 iso_char [of "assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"]
fgh.chine_assoc_inverse by auto
ultimately show "iso (\<alpha>\<^sub>S\<^sub>B fgh)" by argo
qed
qed
lemma natural_isomorphism_\<alpha>:
shows "natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B"
..
end
locale four_composable_arrows_of_spans =
span_bicategory +
\<mu>: arrow_of_spans C \<mu> +
\<nu>: arrow_of_spans C \<nu> +
\<pi>: arrow_of_spans C \<pi> +
\<rho>: arrow_of_spans C \<rho> +
\<mu>\<nu>: two_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
\<nu>\<pi>: two_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi> +
\<pi>\<rho>: two_composable_arrows_of_spans C prj0 prj1 \<pi> \<rho> +
\<mu>\<nu>\<pi>: three_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<pi> +
\<nu>\<pi>\<rho>: three_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi> \<rho>
for \<mu> (structure)
and \<nu> (structure)
and \<pi> (structure)
and \<rho> (structure)
locale four_composable_identity_arrows_of_spans =
four_composable_arrows_of_spans +
\<mu>: identity_arrow_of_spans C \<mu> +
\<nu>: identity_arrow_of_spans C \<nu> +
\<pi>: identity_arrow_of_spans C \<pi> +
\<rho>: identity_arrow_of_spans C \<rho> +
\<mu>\<nu>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi> +
\<pi>\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<pi> \<rho> +
\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<pi> +
\<nu>\<pi>\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi> \<rho>
begin
interpretation H: horizontal_composition vcomp hcomp src trg
using has_horizontal_composition by auto
text \<open>
The following interpretations provide us with some systematic names
for a lot of things.
\<close>
interpretation H\<mu>H\<nu>\<pi>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
using \<mu>\<nu>\<pi>.composites_are_identities ide_char' by auto
interpretation HH\<mu>\<nu>\<pi>: identity_arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
using \<mu>\<nu>\<pi>.composites_are_identities ide_char' by auto
interpretation H\<nu>H\<pi>\<rho>: identity_arrow_of_spans C \<open>\<nu> \<star> \<pi> \<star> \<rho>\<close>
using \<nu>\<pi>\<rho>.composites_are_identities ide_char' by auto
interpretation HH\<nu>\<pi>\<rho>: identity_arrow_of_spans C \<open>(\<nu> \<star> \<pi>) \<star> \<rho>\<close>
using \<nu>\<pi>\<rho>.composites_are_identities ide_char' by auto
interpretation H\<mu>H\<nu>H\<pi>\<rho>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<close>
using arrow_of_spans_hcomp \<mu>\<nu>.composable \<nu>\<pi>\<rho>.composites_are_arrows(1) by auto
interpretation H\<mu>HH\<nu>\<pi>\<rho>: arrow_of_spans C \<open>\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<close>
using arrow_of_spans_hcomp \<mu>\<nu>.composable \<nu>\<pi>\<rho>.composites_are_arrows(1) by auto
interpretation HH\<mu>\<nu>H\<pi>\<rho>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<close>
using hseq_char' match_4 \<mu>\<nu>\<pi>.composites_are_arrows(2) \<pi>\<rho>.composite_is_arrow arr_char
by auto
interpretation HH\<mu>H\<nu>\<pi>\<rho>: arrow_of_spans C \<open>(\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<close>
using arrow_of_spans_hcomp \<pi>\<rho>.composable \<mu>\<nu>\<pi>.composites_are_arrows(1) by auto
interpretation HHH\<mu>\<nu>\<pi>\<rho>: arrow_of_spans C \<open>((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho>\<close>
using arrow_of_spans_hcomp \<pi>\<rho>.composable \<mu>\<nu>\<pi>.composites_are_arrows(2) by auto
interpretation assoc\<mu>\<nu>\<pi>: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>\<close>
using arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable assoc_simps(1) by auto
interpretation assoc\<nu>\<pi>\<rho>: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>\<close>
using arr_char \<nu>\<pi>.composable \<pi>\<rho>.composable assoc_simps(1) by auto
interpretation \<mu>_\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close>
using \<mu>\<nu>.composable \<nu>\<pi>.composable by (unfold_locales, auto)
interpretation \<mu>\<nu>_\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi>
using \<mu>\<nu>.composable \<nu>\<pi>.composable by (unfold_locales, auto)
interpretation \<nu>_\<pi>\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<open>\<pi> \<star> \<rho>\<close>
using \<nu>\<pi>.composable \<pi>\<rho>.composable by (unfold_locales, auto)
interpretation \<nu>\<pi>_\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<nu> \<star> \<pi>\<close> \<rho>
using \<nu>\<pi>.composable \<pi>\<rho>.composable by (unfold_locales, auto)
(* The two other cases, \<mu>\<nu>\<pi> and \<nu>\<pi>\<rho>, are part of the locale assumptions. *)
interpretation \<mu>_\<nu>\<pi>_\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close> \<rho> ..
interpretation \<mu>_\<nu>_\<pi>\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<open>\<pi> \<star> \<rho>\<close> ..
interpretation \<mu>\<nu>_\<pi>_\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi> \<rho> ..
lemma chines_eq:
shows "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
and "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.leg1"
and "H\<mu>H\<nu>H\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> H\<nu>H\<pi>\<rho>.leg1"
proof -
show "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
using hcomp_def [of \<mu> "hcomp (hcomp \<nu> \<pi>) \<rho>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
by simp
show "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.leg1"
proof -
have "hseq \<nu> \<pi> \<and> arr \<mu> \<and> src \<mu> = trg (hcomp \<nu> \<pi>)"
using \<mu>_\<nu>\<pi>.are_arrows(1) \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow by blast
then have "assoc\<mu>\<nu>\<pi>.cod.leg0 = \<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0"
using \<nu>\<pi>.composable by (simp add: hcomp_def)
then show ?thesis
by (simp add: \<mu>_\<nu>\<pi>_\<rho>.chine_composite(1))
qed
show "H\<mu>H\<nu>H\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> H\<nu>H\<pi>\<rho>.leg1"
using hcomp_def [of \<mu> "hcomp \<nu> (hcomp \<pi> \<rho>)"] chine_hcomp_ide_ide \<mu>\<nu>.composable
by simp
qed
lemma cospan_\<mu>0_H\<nu>H\<pi>\<rho>1:
shows "C.cospan \<mu>.leg0 H\<nu>H\<pi>\<rho>.leg1"
proof -
have "H\<nu>H\<pi>\<rho>.leg1 = \<nu>.leg1 \<cdot> \<nu>\<pi>\<rho>.Prj\<^sub>1"
using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable \<pi>\<rho>.composable
apply auto
by (auto simp add: hcomp_def)
thus ?thesis
using \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan \<pi>\<rho>.legs_form_cospan by simp
qed
(* TODO: Better name for this. *)
lemma assoc_in_homs:
shows "\<guillemotleft>\<mu> \<star> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> : (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) : (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
and "\<guillemotleft>assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<guillemotright>"
proof -
show "\<guillemotleft>\<mu> \<star> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
- using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable hseqI' by auto
+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> : (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
using assoc_in_hom \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by simp
show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
- using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable hseqI' by auto
+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) : (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
by auto
show "\<guillemotleft>assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<guillemotright>"
using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
qed
lemma chine_composites:
shows "Chn (\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
and "Chn (assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho>) = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc"
and "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>) = chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
and "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>)) = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc"
and "Chn (assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>) = \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
show "Chn (\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
using hcomp_def [of \<mu> "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>"] chine_hcomp_def [of \<mu> "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>"]
\<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
by auto
show "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>) = chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using assoc_in_homs(2-3) hcomp_def
by (metis arrI arrow_of_spans_data.select_convs(1) hseqE)
show "Chn (assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho>) = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc"
using hcomp_def
by (meson arrow_of_spans_data.select_convs(1))
show "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>)) = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc"
using hcomp_def
by (meson arrow_of_spans_data.select_convs(1))
show "Chn (assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>) = \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using hcomp_def
by (meson arrow_of_spans_data.select_convs(1))
qed
lemma prj_in_homs [intro, simp]:
shows "\<guillemotleft>\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<nu>\<pi>\<rho>.chine\<guillemotright>"
and "\<guillemotleft>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] : H\<mu>H\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
and "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
and "\<guillemotleft>\<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<rho>.chine\<guillemotright>"
and "\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
and "\<guillemotleft>\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
and "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
and "\<guillemotleft>\<mu>_\<nu>\<pi>.prj\<^sub>0 : H\<mu>H\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>\<pi>.apex\<guillemotright>"
proof -
show "\<guillemotleft>\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<nu>\<pi>\<rho>.chine\<guillemotright>"
proof
show "C.cospan \<mu>.leg0 HH\<nu>\<pi>\<rho>.leg1"
using hcomp_def [of "hcomp \<nu> \<pi>" \<rho>] \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu> \<pi>\<rho>.composable \<nu>\<pi>_\<rho>.legs_form_cospan
by auto
show "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
using hcomp_def [of \<mu> "hcomp (hcomp \<nu> \<pi>) \<rho>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
by simp
show "HH\<nu>\<pi>\<rho>.chine = C.dom HH\<nu>\<pi>\<rho>.leg1"
by simp
qed
show "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
proof
show "C.cospan assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1"
using hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] hcomp_def [of \<nu> \<pi>]
by (metis C.cod_comp H\<mu>H\<nu>\<pi>.cod.leg_simps(1) \<nu>\<pi>.cod_simps(2) \<mu>_\<nu>\<pi>.are_arrows(1)
\<mu>_\<nu>\<pi>.composable \<mu>_\<nu>\<pi>_\<rho>.cospan_\<nu>\<pi> \<nu>\<pi>.composite_is_arrow \<rho>.cod_simps(3)
arrow_of_spans_data.select_convs(3) span_data.select_convs(1))
show "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.cod.leg1"
using chines_eq(2) by simp
show "H\<mu>H\<nu>\<pi>.chine = C.dom assoc\<mu>\<nu>\<pi>.cod.leg0"
by auto
qed
show "\<guillemotleft>\<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<rho>.chine\<guillemotright>"
proof
show "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
by simp
show "HHH\<mu>\<nu>\<pi>\<rho>.chine = HH\<mu>\<nu>\<pi>.leg0 \<down>\<down> \<rho>.leg1"
using chine_hcomp_ide_ide hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] \<pi>\<rho>.composable
by simp
show "\<rho>.chine = C.dom \<rho>.leg1 " by simp
qed
show "\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
proof
show "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
by simp
show "HHH\<mu>\<nu>\<pi>\<rho>.chine = HH\<mu>\<nu>\<pi>.leg0 \<down>\<down> \<rho>.leg1"
using chine_hcomp_ide_ide hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] \<pi>\<rho>.composable
by simp
show "HH\<mu>\<nu>\<pi>.chine = C.dom HH\<mu>\<nu>\<pi>.leg0" by simp
qed
show "\<guillemotleft>\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
proof
show "C.cospan (\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0) \<rho>.leg1"
using \<mu>_\<nu>\<pi>.prj_in_hom(2) C.seqI' \<mu>_\<nu>\<pi>_\<rho>.cospan_\<nu>\<pi> by auto
show "HH\<mu>H\<nu>\<pi>\<rho>.chine = \<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<down>\<down> \<rho>.leg1"
using chines_eq(2) hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] \<mu>\<nu>.composable by simp
show "H\<mu>H\<nu>\<pi>.chine = C.dom (\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0)"
using \<mu>_\<nu>\<pi>.prj_in_hom(2) hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
by auto
qed
show "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
proof
show "C.cospan assoc\<mu>\<nu>\<pi>.dom.leg0 \<rho>.leg1"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
by simp
show "HHH\<mu>\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.dom.leg0 \<down>\<down> \<rho>.leg1"
using hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] chine_hcomp_ide_ide \<pi>\<rho>.composable
by simp
show "HH\<mu>\<nu>\<pi>.chine = C.dom assoc\<mu>\<nu>\<pi>.dom.leg0"
using assoc\<mu>\<nu>\<pi>.dom.apex_def assoc\<mu>\<nu>\<pi>.chine_in_hom by fastforce
qed
show "\<guillemotleft>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] : H\<mu>H\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 chine_hcomp_ide_ide hcomp_def [of \<mu> "hcomp \<nu> (hcomp \<pi> \<rho>)"]
\<mu>\<nu>.composable
by auto
show "\<guillemotleft>\<mu>_\<nu>\<pi>.prj\<^sub>0 : H\<mu>H\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>\<pi>.apex\<guillemotright>"
using \<mu>_\<nu>\<pi>.prj_in_hom(2) chine_hcomp_ide_ide hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] \<mu>\<nu>.composable
by simp
qed
lemma chine_in_homs [intro, simp]:
shows "\<guillemotleft>assoc\<mu>\<nu>\<pi>.chine : HH\<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
and "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine : HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
and "\<guillemotleft>chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
and "\<guillemotleft>chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>H\<nu>\<pi>\<rho>.chine\<guillemotright>"
proof -
show 1: "\<guillemotleft>assoc\<mu>\<nu>\<pi>.chine : HH\<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
using \<mu>\<nu>\<pi>.chine_assoc_in_hom by simp
show "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine : HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using \<nu>\<pi>\<rho>.chine_assoc_in_hom by simp
show "\<guillemotleft>chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using Chn_in_hom by (metis assoc_in_homs(1) chine_composites(1))
show "\<guillemotleft>chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>H\<nu>\<pi>\<rho>.chine\<guillemotright>"
using Chn_in_hom by (metis assoc_in_homs(3) chine_composites(3))
qed
lemma commutative_squares [intro, simp]:
shows "C.commutative_square \<nu>\<pi>.leg0 \<rho>.leg1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
and "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
and "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
(chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
and "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
(chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
and "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
(assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
(\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
and "C.commutative_square \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1
\<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
and "C.commutative_square \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
proof -
show 1: "C.commutative_square \<nu>\<pi>.leg0 \<rho>.leg1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
proof -
have 1: "C.arr \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 \<and> C.dom \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = HH\<mu>H\<nu>\<pi>\<rho>.chine \<and>
C.cod \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = \<rho>.apex"
by (meson C.in_homE \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(3))
hence "(\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0) \<cdot> \<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] = \<rho>.leg1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
by (meson C.prj0_simps_arr C.pullback_commutes')
thus ?thesis
using 1 C.comp_assoc \<nu>\<pi>_\<rho>.legs_form_cospan(1) by simp
qed
show 2: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
proof -
have "\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>\<rho>.leg1] =
\<pi>\<rho>.leg1 \<cdot> \<p>\<^sub>0[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>\<rho>.leg1]"
by (metis (no_types) C.category_axioms C.prj0_simps_arr C.pullback_commutes'
category.comp_reduce \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(3))
thus ?thesis
using C.commutative_square_def \<mu>_\<nu>_\<pi>\<rho>.cospan_\<nu>\<pi>
\<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(3) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(5) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(6)
\<mu>_\<nu>_\<pi>\<rho>.prj_simps(8) \<nu>.dom.apex_def
by presburger
qed
show "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
(chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
using assoc_in_homs(1) chine_hcomp_props(4) [of "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>" \<mu>] hseq_char by blast
show "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
(chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
using chine_hcomp_props(3) [of "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>" \<mu>] hseq_char
\<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
by auto
show "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
(assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
(\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
using assoc_in_homs(3) hseq_char chine_hcomp_props(2) by blast
show "C.commutative_square \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1
\<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
proof
show "C.cospan \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1)"
using HH\<nu>\<pi>\<rho>.dom.leg_simps(1) \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu> C.arrI by fastforce
show "C.span \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
using 1 \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(1) by auto
show "C.dom \<mu>.leg0 = C.cod \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
by simp
show "\<mu>.leg0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 =
(\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
proof -
have "(\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> =
\<nu>\<pi>.leg1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
using 1 C.comp_assoc by auto
also have "... = \<mu>.leg0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
using hcomp_def [of \<nu> \<pi>]
by (metis (no_types, lifting) C.comp_assoc C.prj1_simps_arr C.pullback_commutes'
\<open>C.span \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>\<close> C.seqE)
finally show ?thesis by auto
qed
qed
show "C.commutative_square \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
proof
show "C.cospan \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1)"
using C.arrI \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(4) by auto
show "C.span \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
using 2 by fastforce
thus "C.dom \<mu>.leg0 = C.cod \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1"
using \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> by simp
show "\<mu>.leg0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 =
(\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
proof -
have "(\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
using C.comp_assoc by auto
also have "... = \<nu>.leg1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1"
using 2 by simp
also have "... = \<mu>.leg0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1"
using C.pullback_commutes [of \<mu>.leg0 \<nu>.leg1]
by (metis C.comp_assoc C.pullback_commutes' \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu>)
finally show ?thesis by simp
qed
qed
qed
lemma chine_pentagon:
shows "Chn ((\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> \<bullet> (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>)) =
Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>)"
proof -
let ?LHS = "(\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> \<bullet> (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>)"
let ?RHS = "assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>"
have LHS_in_hom: "\<guillemotleft>?LHS : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
- using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable hseqI' by auto
+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
have RHS_in_hom: "\<guillemotleft>?RHS : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
have "arrow_of_spans (\<cdot>) ?LHS"
- using arr_char assoc_in_homs(1) assoc_in_homs(2) assoc_in_homs(3) by blast
+ using arr_char assoc_in_homs(1-3) by blast
have L: "Chn ?LHS = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "seq (\<mu> \<star> \<lparr>Chn = \<nu>\<pi>\<rho>.chine_assoc, Dom = Dom ((\<nu> \<star> \<pi>) \<star> \<rho>),
Cod = Cod (\<nu> \<star> \<pi> \<star> \<rho>)\<rparr>)
(\<lparr>Chn = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc,
Dom = Dom ((\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>), Cod = Cod (\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>)\<rparr> \<bullet>
(\<lparr>Chn = \<mu>\<nu>\<pi>.chine_assoc,
Dom = Dom ((\<mu> \<star> \<nu>) \<star> \<pi>), Cod = Cod (\<mu> \<star> \<nu> \<star> \<pi>)\<rparr> \<star> \<rho>))"
by (meson LHS_in_hom arrI)
moreover have "seq \<lparr>Chn = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc,
Dom = Dom ((\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>), Cod = Cod (\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>)\<rparr>
(\<lparr>Chn = \<mu>\<nu>\<pi>.chine_assoc,
Dom = Dom ((\<mu> \<star> \<nu>) \<star> \<pi>), Cod = Cod (\<mu> \<star> \<nu> \<star> \<pi>)\<rparr> \<star> \<rho>)"
using assoc_in_homs(2) assoc_in_homs(3) by blast
ultimately show ?thesis
using Chn_vcomp chine_composites(1) chine_composites(2) chine_composites(3)
by presburger
qed
have R: "Chn ?RHS = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using Chn_vcomp assoc_in_homs(4) assoc_in_homs(5) seqI' by auto
text \<open>
The outline of the proof is to show that the compositions of \<open>?LHS\<close>
and \<open>?RHS\<close> with the two projections \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> and
\<open>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> are equal, and then apply \<open>\<nu>\<pi>\<rho>.prj'_joint_monic\<close>.
\<close>
text \<open>
The case for projection \<open>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> does not have subcases,
so we'll dispatch that one first.
\<close>
have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS = \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
proof -
have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
proof -
have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using L by simp
also have "... = \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) =
\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
proof -
have "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
(chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
by blast
thus ?thesis by auto
qed
thus ?thesis
using C.comp_permute [of "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" "chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
\<mu>.chine "\<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
"\<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
by blast
qed
also have "... = \<mu>.chine \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using C.comp_reduce [of "\<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
\<nu>\<pi>_\<rho>.leg1_composite
by fastforce
also have "... = \<mu>.chine \<cdot> \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
proof -
have "\<mu>.chine \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<mu>.chine \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using C.comp_assoc by simp
also have "... = \<mu>.chine \<cdot> (\<mu>_\<nu>\<pi>.prj\<^sub>1 \<cdot> assoc\<mu>\<nu>\<pi>.chine) \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
proof -
have "\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
using chine_hcomp_props(6) [of \<rho> "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>"] hcomp_def [of \<mu> "hcomp \<nu> \<pi>"]
\<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
hseq_char assoc_in_homs(3)
by auto
thus ?thesis
using C.comp_assoc by auto
qed
also have "... = \<mu>.chine \<cdot> \<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
using \<mu>\<nu>\<pi>.prj_chine_assoc(1) hcomp_def \<nu>\<pi>.composable by auto
also have "... = \<mu>.chine \<cdot> \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
proof -
have "\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
proof -
have "\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] =
(\<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<mu>\<nu>.leg0, \<pi>.leg1]) \<cdot> \<p>\<^sub>1[\<pi>.leg0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>0, \<rho>.leg1]"
proof -
have "\<mu>\<nu>.leg0 = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0"
using hcomp_def \<mu>\<nu>.composable by simp
moreover have "assoc\<mu>\<nu>\<pi>.dom.leg0 = \<pi>.leg0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>0"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable by auto
ultimately show ?thesis by simp
qed
also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
using \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(1) C.comp_assoc by simp
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
finally show ?thesis by blast
qed
also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
using \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(1) hcomp_def [of \<mu> \<nu>] chine_hcomp_ide_ide \<mu>\<nu>.cod.apex_def
\<mu>\<nu>.composable \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> C.comp_ide_arr
by auto
finally show ?thesis by blast
qed
also have "... = \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
proof -
have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS =
\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using R by simp
also have "... = \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using C.comp_reduce [of "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" \<mu>_\<nu>_\<pi>\<rho>.chine_assoc]
hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<mu>_\<nu>_\<pi>\<rho>.chine_assoc_def \<nu>\<pi>.composable
by fastforce
also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
proof -
have "\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc = (\<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1) \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using hcomp_def [of \<mu> \<nu>] hcomp_def [of \<pi> \<rho>] \<mu>\<nu>.composable \<pi>\<rho>.composable
by simp
also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using \<mu>\<nu>.dom.apex_def \<mu>\<nu>.dom.leg_simps(1) hcomp_def \<mu>\<nu>.composable
\<mu>\<nu>.prj_in_hom(1) \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(4) C.comp_assoc
by auto
also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
by simp
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
text \<open>
Now for the case of \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close>.
We have to consider three sub-cases, involving the compositions with the projections
\<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<close>, \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0\<close>, and \<open>\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0\<close>.
\<close>
moreover have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
proof -
(* Facts common to the three sub-cases. *)
have A: "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc =
\<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
using \<mu>_\<nu>\<pi>_\<rho>.chine_assoc_def \<nu>\<pi>_\<rho>.leg1_composite by auto
have B: "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
proof -
have "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
(\<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1]) \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow hcomp_def by auto
also have "... = \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using C.comp_assoc by simp
also have "... = \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
proof -
have "HH\<mu>\<nu>\<pi>.leg0 = assoc\<mu>\<nu>\<pi>.dom.leg0"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] by simp
moreover have "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
(assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
(\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
by blast
ultimately show ?thesis
using chine_hcomp_def [of "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>" \<rho>] by simp
qed
finally show ?thesis by blast
qed
have *: "assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<close>:\<close>
have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using \<nu>\<pi>\<rho>.chine_assoc_props(1) C.prj0_in_hom [of \<mu>.leg0 HH\<nu>\<pi>\<rho>.leg1] cospan_\<mu>0_H\<nu>H\<pi>\<rho>1
C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1 assoc\<nu>\<pi>\<rho>.chine \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1
"\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
by auto
also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
by fastforce
also have "... = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
proof -
have "\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> \<nu>\<pi>.prj\<^sub>0"
using hcomp_def \<nu>\<pi>.composable by simp
thus ?thesis
using commutative_squares(1) C.arrI \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(2) \<nu>\<pi>\<rho>.prj_in_hom(1)
by (simp add: C.comp_assoc)
qed
moreover have "C.seq \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
\<pi>\<rho>.composable \<nu>\<pi>\<rho>.prj_in_hom(1)
by auto
moreover have "C.seq \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>
(chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
by fastforce
ultimately show ?thesis
using C.comp_permute by blast
qed
also have "... = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using B by simp
also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable C.comp_assoc
C.comp_reduce [of \<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>0 \<mu>\<nu>\<pi>.chine_assoc \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 "\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
\<mu>\<nu>\<pi>.prj_in_hom(5) \<mu>\<nu>\<pi>.prj_chine_assoc(2)
by auto
also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot>
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
by blast
hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using 1 2 \<pi>\<rho>.composable hcomp_def [of \<pi> \<rho>]
C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1 "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
by fastforce
also have "... = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
proof -
have "\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1"
using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable by simp
thus ?thesis
using C.comp_reduce C.comp_assoc by auto
qed
also have "... = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable by simp
also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
proof -
have 1: "\<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>1 = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1"
using hcomp_def \<mu>\<nu>.composable by simp
moreover have 2: "C.seq \<mu>\<nu>.prj\<^sub>0 \<mu>\<nu>_\<pi>.prj\<^sub>1"
using 1 by fastforce
moreover have "C.seq \<mu>\<nu>_\<pi>.prj\<^sub>1 \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
by (metis 1 2 C.match_1 C.seqI' \<mu>\<nu>\<pi>.prj_in_hom(2) prj_in_homs(5))
ultimately show ?thesis
using C.comp_reduce by simp
qed
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
moreover
text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0\<close>:\<close>
have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 "assoc\<nu>\<pi>\<rho>.chine" \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1
"\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
by auto
also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
by fastforce
also have "... = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> =
\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
using commutative_squares(1) C.arrI \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(2) \<nu>\<pi>\<rho>.prj_in_hom(2)
C.comp_assoc \<nu>\<pi>.leg0_composite
by auto
moreover have "C.seq \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
\<pi>\<rho>.composable \<nu>\<pi>\<rho>.prj_in_hom(2)
by auto
moreover have "C.seq \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>
(chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
by fastforce
ultimately show ?thesis
using C.comp_permute by blast
qed
also have "... = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using B by simp
also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable \<mu>\<nu>\<pi>.prj_in_hom(6)
C.comp_reduce [of \<nu>\<pi>.prj\<^sub>0 \<mu>_\<nu>\<pi>.prj\<^sub>0 \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0
"\<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
C.comp_reduce [of \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0 \<mu>\<nu>\<pi>.chine_assoc \<mu>\<nu>\<pi>.Prj\<^sub>0
"\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
by fastforce
also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot>
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
by blast
hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> = \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
\<pi>\<rho>.prj\<^sub>1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
proof -
have "\<pi>\<rho>.prj\<^sub>1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0"
using hcomp_def [of \<pi> \<rho>] \<pi>\<rho>.composable by simp
moreover have "C.seq \<pi>\<rho>.prj\<^sub>1
(\<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>)"
using 2 hcomp_def [of \<pi> \<rho>] \<nu>\<pi>\<rho>.chine_composite(2) \<nu>\<pi>\<rho>.prj_in_hom(5)
\<pi>\<rho>.composable
by auto
ultimately show ?thesis
using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>1 \<nu>_\<pi>\<rho>.prj\<^sub>0 \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0
"\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"]
by auto
qed
also have "... = \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
using 1 by simp
finally show ?thesis by blast
qed
hence "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot>
\<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
\<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using 2 C.comp_permute by blast
also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have "\<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0"
using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable by simp
thus ?thesis
using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
by auto
qed
also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
by simp
also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] hcomp_def [of \<mu> \<nu>] \<mu>\<nu>.composite_is_arrow
\<mu>\<nu>_\<pi>.composable
by auto
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
moreover
text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0\<close>:\<close>
have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
\<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 assoc\<nu>\<pi>\<rho>.chine \<nu>\<pi>\<rho>.Prj\<^sub>0
"\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
by fastforce
also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
by fastforce
also have "... = \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> = \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>0 = \<nu>\<pi>_\<rho>.prj\<^sub>0"
using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable by simp
thus ?thesis by simp
qed
thus ?thesis
using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
\<pi>\<rho>.composable \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(3) calculation
C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>0 "\<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 "chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
by fastforce
qed
also have "... = \<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
proof -
have "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1]"
using \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow hcomp_def by auto
thus ?thesis
using chine_hcomp_props(5) [of \<rho> "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>"]
\<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
by simp
qed
also have "... = \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
proof -
have "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable prj_in_homs(5) by blast
hence "\<rho>.chine = C.cod \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using C.prj0_simps [of HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1] by simp
thus ?thesis
using C.comp_cod_arr hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable
HH\<mu>\<nu>\<pi>.dom.leg_simps(1) \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
by simp
qed
also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot>
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
by blast
hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
have
"\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
\<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
\<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
proof -
have
"\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
\<pi>\<rho>.prj\<^sub>0 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
proof -
have 3: "\<pi>\<rho>.prj\<^sub>0 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0"
using hcomp_def [of \<pi> \<rho>] \<pi>\<rho>.composable by simp
moreover have "C.seq \<pi>\<rho>.prj\<^sub>0
(\<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>)"
using 1 2 3 hcomp_def [of \<pi> \<rho>] \<nu>\<pi>\<rho>.chine_composite(2)
\<pi>\<rho>.composable
by (metis C.arrI C.match_4 C.prj_tuple(1) \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(3)
\<nu>\<pi>\<rho>.prj_in_hom(6))
ultimately show ?thesis
using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>0 \<nu>_\<pi>\<rho>.prj\<^sub>0 \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0
"\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"]
by auto
qed
also have "... = \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
using 1 by simp
finally show ?thesis by blast
qed
thus ?thesis
using 2 C.comp_permute [of \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
\<pi>\<rho>.prj\<^sub>0 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
by blast
qed
also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable C.comp_assoc \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
C.comp_reduce [of \<pi>\<rho>.prj\<^sub>0 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
by auto
also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0"
by simp
also have "... = \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] hcomp_def [of \<mu> \<nu>]
\<mu>\<nu>.composite_is_arrow \<mu>\<nu>_\<pi>.composable
by auto
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
moreover have "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using \<nu>\<pi>\<rho>.chine_assoc_props(1) by fast
moreover have "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc :
HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
proof -
have "\<guillemotleft>\<mu>\<nu>_\<pi>_\<rho>.chine_assoc : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using \<mu>\<nu>_\<pi>_\<rho>.chine_assoc_props(1) by blast
moreover have "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
using chine_hcomp_ide_ide hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable by auto
ultimately show ?thesis by blast
qed
ultimately show ?thesis
using \<nu>\<pi>\<rho>.prj'_joint_monic
[of "assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
HHH\<mu>\<nu>\<pi>\<rho>.chine
"\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"]
by simp
qed
text \<open>
Now use fact \<open>*\<close> to finish off the \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> case.
\<close>
have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
using L by simp
also have "... = assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
proof -
have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) =
assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
proof -
have "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
(chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
by blast
thus ?thesis
using \<nu>\<pi>\<rho>.chine_assoc_props(1) by auto
qed
moreover have "C.seq \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>))"
using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 prj_in_homs(2) by fastforce
moreover have "C.seq (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>))
(\<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
by blast
ultimately show ?thesis
using chine_hcomp_props(4) C.comp_permute by auto
qed
finally show ?thesis by blast
qed
also have "... = \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using * by simp
also have "... = \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
proof -
have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS =
\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
using R by simp
also have "... = \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
proof -
have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc =
\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable \<mu>_\<nu>_\<pi>\<rho>.chine_assoc_def by auto
thus ?thesis
using C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" \<mu>_\<nu>_\<pi>\<rho>.chine_assoc
"\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
\<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
by fastforce
qed
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
moreover have "C.seq \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (Chn ?LHS)"
using LHS_in_hom Chn_in_hom by blast
moreover have "C.seq \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (Chn ?RHS)"
using RHS_in_hom Chn_in_hom by blast
ultimately show "Chn ?LHS = Chn ?RHS"
using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 C.prj_joint_monic by blast
qed
end
context span_bicategory
begin
interpretation VxV: product_category vcomp vcomp ..
interpretation VV: subcategory VxV.comp \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and>
src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
by (unfold_locales, simp_all)
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 H: horizontal_composition vcomp hcomp src trg
using has_horizontal_composition by auto
interpretation HoHV: "functor" VVV.comp vcomp HoHV
using functor_HoHV by blast
interpretation HoVH: "functor" VVV.comp vcomp HoVH
using functor_HoVH by blast
interpretation L: equivalence_functor vcomp vcomp L
using equivalence_functor_L by auto
interpretation R: equivalence_functor vcomp vcomp R
using equivalence_functor_R by auto
interpretation \<alpha>: natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
using natural_isomorphism_\<alpha> by blast
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 "(f \<star> \<alpha>\<^sub>S\<^sub>B (g, h, k)) \<bullet> \<alpha>\<^sub>S\<^sub>B (f, g \<star> h, k) \<bullet> (\<alpha>\<^sub>S\<^sub>B (f, g, h) \<star> k) =
\<alpha>\<^sub>S\<^sub>B (f, g, h \<star> k) \<bullet> \<alpha>\<^sub>S\<^sub>B (f \<star> g, h, k)"
proof -
interpret f: identity_arrow_of_spans C f
using assms ide_char' by auto
interpret g: identity_arrow_of_spans C g
using assms ide_char' by auto
interpret h: identity_arrow_of_spans C h
using assms ide_char' by auto
interpret k: identity_arrow_of_spans C k
using assms ide_char' by auto
interpret fghk: four_composable_identity_arrows_of_spans C prj0 prj1 f g h k
using assms by (unfold_locales, auto)
let ?LHS = "(f \<star> assoc\<^sub>S\<^sub>B g h k) \<bullet> (assoc\<^sub>S\<^sub>B f (g \<star> h) k) \<bullet> (assoc\<^sub>S\<^sub>B f g h \<star> k)"
let ?RHS = "assoc\<^sub>S\<^sub>B f g (h \<star> k) \<bullet> assoc\<^sub>S\<^sub>B (f \<star> g) h k"
have "(f \<star> \<alpha>\<^sub>S\<^sub>B (g, h, k)) \<bullet> \<alpha>\<^sub>S\<^sub>B (f, g \<star> h, k) \<bullet> (\<alpha>\<^sub>S\<^sub>B (f, g, h) \<star> k) = ?LHS"
using assms \<alpha>_ide ide_hcomp src_hcomp trg_hcomp by simp
also have "... = ?RHS"
using fghk.\<mu>\<nu>.composable fghk.\<nu>\<pi>.composable fghk.\<pi>\<rho>.composable fghk.chine_pentagon
- hseqI'
by (intro arr_eqI, auto)
also have "... = \<alpha>\<^sub>S\<^sub>B (f, g, h \<star> k) \<bullet> \<alpha>\<^sub>S\<^sub>B (f \<star> g, h, k)"
using assms \<alpha>_ide ide_hcomp src_hcomp trg_hcomp by simp
finally show ?thesis by blast
qed
lemma extends_to_bicategory:
shows "bicategory vcomp hcomp assoc unit src trg"
using unit_in_hom obj_char iso_unit assoc_def pentagon
- by (unfold_locales, auto)
+ apply unfold_locales by auto
sublocale bicategory vcomp hcomp assoc unit src trg
using extends_to_bicategory by auto
end
subsection "Miscellaneous Formulas"
context span_bicategory
begin
no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
notation lunit ("\<l>[_]")
notation runit ("\<r>[_]")
notation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
notation runit' ("\<r>\<^sup>-\<^sup>1[_]")
notation assoc ("\<a>[_, _, _]")
notation \<a>' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
lemma \<alpha>'_ide:
assumes "ide f" and "ide g" and "ide h"
and "src f = trg g" and "src g = trg h"
shows "\<alpha>' (f, g, h) = assoc'\<^sub>S\<^sub>B f g h"
proof -
have fgh: "VVV.ide (f, g, h)"
using assms VVV.ide_char VVV.arr_char VV.arr_char by simp
interpret f: arrow_of_spans C f
using assms arr_char [of f] by auto
interpret g: arrow_of_spans C g
using assms arr_char [of g] by auto
interpret h: arrow_of_spans C h
using assms arr_char [of h] by auto
interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
using assms by (unfold_locales, auto)
interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
using assms ide_char by (unfold_locales, auto)
have "\<alpha>' (f, g, h) = inv (\<alpha> (f, g, h))"
using fgh \<alpha>'.inverts_components
by (simp add: \<alpha>_def)
moreover have "inv (\<alpha> (f, g, h)) = \<lparr>Chn = C.inv (Chn (\<alpha> (f, g, h))),
Dom = Cod (\<alpha> (f, g, h)),
Cod = Dom (\<alpha> (f, g, h))\<rparr>"
using fgh \<alpha>.components_are_iso inv_eq
by (simp add: \<alpha>_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable)
moreover have "... = assoc'\<^sub>S\<^sub>B f g h"
using assms fgh \<alpha>_ide [of f g h] fgh.chine_assoc_inverse C.inverse_unique
by (simp add: \<alpha>_def)
ultimately show ?thesis by simp
qed
text \<open>
The following give explicit expressions for the unitors,
derived from their characterizing properties and the definition of the associators.
\<close>
lemma runit_ide_eq:
assumes "ide f"
shows "\<r>[f] = \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
Dom = \<lparr>Leg0 = \<p>\<^sub>0[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
Leg1 = Leg1 (Dom f) \<cdot> \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))]\<rparr>,
Cod = Cod f\<rparr>"
proof -
interpret f: identity_arrow_of_spans C f
using assms ide_char' by auto
interpret src: identity_arrow_of_spans C \<open>src f\<close>
using assms ide_char' ide_src by auto
interpret f_src: two_composable_identity_arrows_of_spans C prj0 prj1 f \<open>src f\<close>
using assms by (unfold_locales, simp)
interpret src_src: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>src f\<close> \<open>src f\<close>
by (unfold_locales, simp)
interpret f_src_src: three_composable_identity_arrows_of_spans C prj0 prj1 f \<open>src f\<close> \<open>src f\<close>
..
let ?rf = "\<lparr>Chn = \<p>\<^sub>1[f.leg0, f.dsrc],
Dom = \<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>,
Cod = Cod f\<rparr>"
have "?rf = \<r>[f]"
proof (intro runit_eqI)
show "ide f" by fact
interpret rf: arrow_of_spans C ?rf
proof -
interpret dom_rf: span_in_category C
\<open>\<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>\<close>
by (unfold_locales, simp_all)
show "arrow_of_spans C ?rf"
using dom_rf.apex_def C.comp_cod_arr C.pullback_commutes [of f.leg0 f.dsrc]
apply unfold_locales by auto
qed
show rf_in_hom: "\<guillemotleft>?rf : f \<star> src f \<Rightarrow> f\<guillemotright>"
proof
show "arr ?rf"
using rf.arrow_of_spans_axioms arr_char by simp
show "cod ?rf = f"
using cod_char rf.arrow_of_spans_axioms arr_char by simp
show "dom ?rf = f \<star> src f"
using dom_char rf.arrow_of_spans_axioms src.arrow_of_spans_axioms arr_char hcomp_def
f.arrow_of_spans_axioms f_src.composable chine_hcomp_ide_ide src_def ide_char
C.comp_cod_arr rf.dom.apex_def
by simp
qed
show "?rf \<star> src f = (f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]"
proof (intro arr_eqI)
show par: "par (?rf \<star> src f) ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
proof -
have "\<guillemotleft>?rf \<star> src f : (f \<star> src f) \<star> src f \<Rightarrow> f \<star> src f\<guillemotright>"
proof -
have "?rf \<star> src f = R ?rf"
using assms rf_in_hom src_def trg_def arr_char rf.arrow_of_spans_axioms
f.arrow_of_spans_axioms
by simp
moreover have "\<guillemotleft>R ?rf : (f \<star> src f) \<star> src f \<Rightarrow> f \<star> src f\<guillemotright>"
using rf_in_hom R.preserves_hom [of ?rf "f \<star> src f" f] by simp
ultimately show ?thesis by auto
qed
- thus ?thesis
- using hseqI' by auto
+ thus ?thesis by auto
qed
show "Chn (?rf \<star> src f) = Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
proof -
have "Chn (?rf \<star> src f) = \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>0\<^sub>1\<rangle>"
proof -
have "Chn (?rf \<star> src f) =
\<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> \<p>\<^sub>0[f_src.prj\<^sub>0, src.leg1]\<rangle>"
using assms src_def trg_def hcomp_def arr_char ide_char
rf.arrow_of_spans_axioms src.identity_arrow_of_spans_axioms
chine_hcomp_arr_ide C.comp_cod_arr
by (simp add: f.arrow_of_spans_axioms identity_arrow_of_spans_def)
moreover have "\<p>\<^sub>0[f_src.prj\<^sub>0, src.leg1] = f_src_src.Prj\<^sub>0\<^sub>1"
proof -
have "src f = \<lparr>Chn = f.dsrc,
Dom = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>,
Cod = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<rparr>"
using assms src_def by simp
thus ?thesis
by (simp add: C.comp_cod_arr C.pullback_commutes')
qed
ultimately show ?thesis by auto
qed
also have "... = Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
proof -
have "Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]) =
\<langle>f_src_src.Prj\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>1\<^sub>0\<rangle> \<cdot> f_src_src.chine_assoc"
proof -
have "Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]) =
Chn (f \<star> \<i>[src f]) \<cdot> Chn \<a>[f, src f, src f]"
using par vcomp_eq [of "f \<star> \<i>[src f]" "\<a>[f, src f, src f]"]
by simp
moreover have "Chn (f \<star> \<i>[src f]) =
\<langle>f_src_src.Prj\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>1\<^sub>0\<rangle>"
proof -
have "\<i>[src f] = \<lparr>Chn = \<p>\<^sub>1[f.dsrc, f.dsrc],
Dom = \<lparr>Leg0 = \<p>\<^sub>1[f.dsrc, f.dsrc], Leg1 = \<p>\<^sub>1[f.dsrc, f.dsrc]\<rparr>,
Cod = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<rparr>"
using unit_def src_def trg_def hcomp_def src.arrow_of_spans_axioms arr_char
f.arrow_of_spans_axioms C.comp_cod_arr
by simp
moreover have "arrow_of_spans C \<i>[src f]"
using assms arr_char [of "\<i>[src f]"] by simp
ultimately show ?thesis
using assms unit_def hcomp_def chine_hcomp_ide_arr
rf.arrow_of_spans_axioms src.arrow_of_spans_axioms
f.arrow_of_spans_axioms arr_char C.comp_cod_arr
src_def trg_def
by simp
qed
ultimately show ?thesis
using \<alpha>_ide by simp
qed
also have "... = \<langle>f_src_src.Prj\<^sub>1 \<cdot> f_src_src.chine_assoc
\<lbrakk>f.leg0, src.leg1\<rbrakk>
f_src_src.Prj\<^sub>1\<^sub>0 \<cdot> f_src_src.chine_assoc\<rangle>"
proof -
have "C.commutative_square f.leg0 src.leg1 f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0"
proof
show "C.cospan f.leg0 src.leg1"
using f_src.legs_form_cospan(1) by auto
show "C.span f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0"
using f_src_src.prj_in_hom(5) by auto
show "C.dom f.leg0 = C.cod f_src_src.Prj\<^sub>1"
by simp
show "f.leg0 \<cdot> f_src_src.Prj\<^sub>1 = src.leg1 \<cdot> f_src_src.Prj\<^sub>1\<^sub>0"
using C.pullback_commutes' \<open>C.span f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0\<close>
C.comp_assoc
by auto
qed
moreover have "C.seq f_src_src.Prj\<^sub>1 f_src_src.chine_assoc"
by blast
ultimately show ?thesis
using C.comp_tuple_arr by auto
qed
also have "... = \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>0\<^sub>1\<rangle>"
by simp
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
qed
qed
thus ?thesis by simp
qed
lemma lunit_ide_eq:
assumes "ide f"
shows "\<l>[f] = \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
Dom = \<lparr>Leg0 = Leg0 (Dom f) \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
Leg1 = \<p>\<^sub>1[C.cod (Leg1 (Dom f)), Leg1 (Dom f)]\<rparr>,
Cod = Cod f\<rparr>"
proof -
interpret f: identity_arrow_of_spans C f
using assms ide_char' by auto
interpret trg: identity_arrow_of_spans C \<open>trg f\<close>
using assms ide_char' ide_trg by auto
interpret trg_f: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> f
using assms by (unfold_locales, simp)
interpret trg_trg: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> \<open>trg f\<close>
by (unfold_locales, simp)
interpret trg_trg_f: three_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> \<open>trg f\<close> f
..
let ?lf = "\<lparr>Chn = \<p>\<^sub>0[f.dtrg, f.leg1],
Dom = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>,
Cod = Cod f\<rparr>"
have "?lf = \<l>[f]"
proof (intro lunit_eqI)
show "ide f" by fact
interpret lf: arrow_of_spans C ?lf
proof -
interpret dom_lf: span_in_category C
\<open>\<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>\<close>
by (unfold_locales, simp_all)
show "arrow_of_spans C ?lf"
using dom_lf.apex_def C.comp_cod_arr C.pullback_commutes [of f.dtrg f.leg1]
apply unfold_locales by auto
qed
show lf_in_hom: "\<guillemotleft>?lf : trg f \<star> f \<Rightarrow> f\<guillemotright>"
proof
show "arr ?lf"
using lf.arrow_of_spans_axioms arr_char by simp
show "cod ?lf = f"
using cod_char lf.arrow_of_spans_axioms arr_char by simp
show "dom ?lf = trg f \<star> f"
using dom_char lf.arrow_of_spans_axioms trg.arrow_of_spans_axioms arr_char hcomp_def
f.arrow_of_spans_axioms trg_f.composable chine_hcomp_ide_ide trg_def ide_char
C.comp_cod_arr lf.dom.apex_def
by simp
qed
show "trg f \<star> ?lf = (\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
proof (intro arr_eqI)
show par: "par (trg f \<star> ?lf) ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
proof -
have "\<guillemotleft>trg f \<star> ?lf : trg f \<star> (trg f \<star> f) \<Rightarrow> trg f \<star> f\<guillemotright>"
proof -
have "trg f \<star> ?lf = L ?lf"
using assms lf_in_hom src_def trg_def arr_char lf.arrow_of_spans_axioms
f.arrow_of_spans_axioms
by simp
moreover have "\<guillemotleft>L ?lf : trg f \<star> (trg f \<star> f) \<Rightarrow> trg f \<star> f\<guillemotright>"
using lf_in_hom L.preserves_hom [of ?lf "trg f \<star> f" f] by simp
ultimately show ?thesis by auto
qed
- thus ?thesis
- using hseqI' by auto
+ thus ?thesis by auto
qed
show "Chn (trg f \<star> ?lf) = Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
proof -
have "Chn (trg f \<star> ?lf) = \<langle>trg_trg_f.Prj\<^sub>1\<^sub>0 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
proof -
have "Chn (trg f \<star> ?lf) =
\<langle>\<p>\<^sub>1[trg.leg0, trg_f.prj\<^sub>1] \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
using assms src_def trg_def hcomp_def arr_char ide_char
lf.arrow_of_spans_axioms trg.identity_arrow_of_spans_axioms
chine_hcomp_ide_arr C.comp_cod_arr
by (simp add: f.arrow_of_spans_axioms identity_arrow_of_spans_def)
moreover have "\<p>\<^sub>1[trg.leg0, trg_f.prj\<^sub>1] = trg_trg_f.Prj\<^sub>1\<^sub>0"
proof -
have "trg f = \<lparr>Chn = f.dtrg,
Dom = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>,
Cod = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<rparr>"
using assms trg_def by simp
thus ?thesis
apply (simp add: C.comp_cod_arr C.pullback_commutes')
by (metis C.comp_cod_arr C.pullback_commutes' select_convs(1) select_convs(2)
select_convs(3) f.cod_simps(3) lf.cod_trg_eq_dom_trg lf.dom.leg_simps(3)
span_data.select_convs(1) span_data.select_convs(2) trg.chine_eq_apex
trg_trg_f.cospan_\<nu>\<pi> trg_trg_f.prj_simps(10) trg_trg_f.prj_simps(16))
qed
ultimately show ?thesis by auto
qed
also have "... = Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
proof -
have "Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]) =
\<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<rangle> \<cdot> trg_trg_f.chine_assoc'"
proof -
have "Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]) =
Chn (\<i>[trg f] \<star> f) \<cdot> Chn \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
using par vcomp_eq [of "\<i>[trg f] \<star> f" "\<a>\<^sup>-\<^sup>1[trg f, trg f, f]"]
by simp
moreover have "Chn (\<i>[trg f] \<star> f) =
\<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<rangle>"
proof -
have "\<i>[trg f] = \<lparr>Chn = \<p>\<^sub>1[f.dtrg, f.dtrg],
Dom = \<lparr>Leg0 = \<p>\<^sub>1[f.dtrg, f.dtrg], Leg1 = \<p>\<^sub>1[f.dtrg, f.dtrg]\<rparr>,
Cod = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<rparr>"
using unit_def src_def trg_def hcomp_def trg.arrow_of_spans_axioms arr_char
f.arrow_of_spans_axioms C.comp_cod_arr
by simp
moreover have "arrow_of_spans C \<i>[trg f]"
using assms arr_char [of "\<i>[trg f]"] by simp
ultimately show ?thesis
using assms unit_def hcomp_def chine_hcomp_arr_ide
lf.arrow_of_spans_axioms trg.arrow_of_spans_axioms
f.arrow_of_spans_axioms arr_char C.comp_cod_arr
src_def trg_def
by simp
qed
moreover have "Chn \<a>\<^sup>-\<^sup>1[trg f, trg f, f] = trg_trg_f.chine_assoc'"
proof -
have "iso (\<alpha> (trg f, trg f, f))"
proof -
have "VVV.ide (trg f, trg f, f)"
using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
by auto
thus ?thesis
using \<alpha>_def \<alpha>.components_are_iso [of "(trg f, trg f, f)"] by simp
qed
moreover have "C.inv trg_trg_f.chine_assoc = trg_trg_f.chine_assoc'"
using trg_trg_f.chine_assoc_inverse C.inv_is_inverse C.inverse_arrow_unique
by auto
ultimately show ?thesis
using assms by (simp add: \<a>'_def \<alpha>'_ide)
qed
ultimately show ?thesis
by simp
qed
also have "... = \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<cdot> trg_trg_f.chine_assoc'
\<lbrakk>trg.leg0, f.leg1\<rbrakk>
trg_trg_f.Prj\<^sub>0 \<cdot> trg_trg_f.chine_assoc'\<rangle>"
proof -
have "C.commutative_square trg.leg0 f.leg1 trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0"
proof
show "C.cospan trg.leg0 f.leg1"
using trg_f.legs_form_cospan(1) by auto
show "C.span trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0"
using trg_trg_f.prj_in_hom by auto
show "C.dom trg.leg0 = C.cod trg_trg_f.Prj\<^sub>0\<^sub>1"
by simp
show "trg.leg0 \<cdot> trg_trg_f.Prj\<^sub>0\<^sub>1 = f.leg1 \<cdot> trg_trg_f.Prj\<^sub>0"
by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
\<open>C.span trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0\<close>)
qed
moreover have "C.seq trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.chine_assoc'"
by blast
ultimately show ?thesis
using C.comp_tuple_arr [of trg.leg0 f.leg1 trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0
trg_trg_f.chine_assoc']
by auto
qed
also have "... = \<langle>trg_trg_f.Prj\<^sub>1\<^sub>0 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
by simp
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
qed
qed
thus ?thesis by simp
qed
lemma runit'_ide_eq:
assumes "ide f"
shows "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>Chn f \<lbrakk>Leg0 (Dom f), C.cod (Leg0 (Dom f))\<rbrakk> Leg0 (Dom f)\<rangle>,
Dom = Cod f,
Cod = \<lparr>Leg0 = \<p>\<^sub>0[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
Leg1 = Leg1 (Dom f) \<cdot> \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))]\<rparr>\<rparr>"
proof -
interpret f: identity_arrow_of_spans C f
using assms ide_char' by auto
show "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>, Dom = Cod f,
Cod = \<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>\<rparr>"
proof -
have "C.inverse_arrows \<p>\<^sub>1[f.leg0, f.dsrc] \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
proof
show "C.ide (\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc])"
proof -
have "\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] =
\<langle>f.chine \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rangle>"
using assms C.comp_tuple_arr [of f.leg0 f.dsrc f.chine f.leg0 "\<p>\<^sub>1[f.leg0, f.dsrc]"]
C.comp_arr_dom C.comp_cod_arr
by simp
also have "... = \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, f.dsrc\<rbrakk> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
using C.pullback_commutes [of f.leg0 f.dsrc] C.comp_cod_arr by auto
also have "... = f.leg0 \<down>\<down> f.dsrc"
by simp
finally have "\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = f.leg0 \<down>\<down> f.dsrc"
by blast
thus ?thesis by simp
qed
show "C.ide (\<p>\<^sub>1[f.leg0, f.dsrc] \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
using assms C.comp_arr_dom C.comp_cod_arr by auto
qed
hence "C.inv \<p>\<^sub>1[f.leg0, f.dsrc] = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
using C.inv_is_inverse C.inverse_arrow_unique by auto
hence "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>,
Dom = Cod \<r>[f], Cod = Dom \<r>[f]\<rparr>"
using assms runit_ide_eq inv_eq [of "\<r>[f]"] iso_runit by simp
thus ?thesis
using assms runit_ide_eq by simp
qed
qed
lemma lunit'_ide_eq:
assumes "ide f"
shows "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>Leg1 (Dom f) \<lbrakk>C.cod (Leg1 (Dom f)), Leg1 (Dom f)\<rbrakk> Chn f\<rangle>,
Dom = Cod f,
Cod = \<lparr>Leg0 = Leg0 (Dom f) \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
Leg1 = \<p>\<^sub>1[C.cod (Leg1 (Dom f)), Leg1 (Dom f)]\<rparr>\<rparr>"
proof -
interpret f: identity_arrow_of_spans C f
using assms ide_char' by auto
show "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>, Dom = Cod f,
Cod = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>\<rparr>"
proof -
have "C.inverse_arrows \<p>\<^sub>0[f.dtrg, f.leg1] \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>"
proof
show "C.ide (\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1])"
proof -
have "\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] =
\<langle>f.leg1 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1]\<rangle>"
using assms C.comp_tuple_arr C.comp_arr_dom C.comp_cod_arr
by simp
also have "... = \<langle>\<p>\<^sub>1[f.dtrg, f.leg1] \<lbrakk>f.dtrg, f.leg1\<rbrakk> \<p>\<^sub>0[f.dtrg, f.leg1]\<rangle>"
proof -
have "f.leg1 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] = \<p>\<^sub>1[f.dtrg, f.leg1]"
using C.pullback_commutes [of f.dtrg f.leg1] C.comp_cod_arr by auto
thus ?thesis
using C.comp_cod_arr by simp
qed
also have "... = f.dtrg \<down>\<down> f.leg1"
by simp
finally have "\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] = f.dtrg \<down>\<down> f.leg1"
by blast
thus ?thesis by simp
qed
show "C.ide (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>)"
using assms C.comp_arr_dom C.comp_cod_arr by auto
qed
hence "C.inv \<p>\<^sub>0[f.dtrg, f.leg1] = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>"
using C.inv_is_inverse C.inverse_arrow_unique by auto
hence "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>,
Dom = Cod \<l>[f], Cod = Dom \<l>[f]\<rparr>"
using assms lunit_ide_eq inv_eq [of "\<l>[f]"] iso_lunit by simp
thus ?thesis
using assms lunit_ide_eq by simp
qed
qed
end
locale adjunction_data_in_span_bicategory =
span_bicategory C prj0 prj1 +
adjunction_data_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
for C :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<cdot>" 55)
and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>0[_, _]")
and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>1[_, _]")
and f :: "'a arrow_of_spans_data"
and g :: "'a arrow_of_spans_data"
and \<eta> :: "'a arrow_of_spans_data"
and \<epsilon> :: "'a arrow_of_spans_data"
begin
interpretation f: identity_arrow_of_spans C f
using ide_char' [of f] by auto
interpretation g: identity_arrow_of_spans C g
using ide_char' [of g] by auto
interpretation gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
using antipar by (unfold_locales, auto)
interpretation fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
using antipar by (unfold_locales, auto)
interpretation fgf: three_composable_identity_arrows_of_spans C prj0 prj1 f g f ..
interpretation gfg: three_composable_identity_arrows_of_spans C prj0 prj1 g f g ..
interpretation \<eta>: arrow_of_spans C \<eta>
using arr_char unit_in_hom by auto
interpretation \<epsilon>: arrow_of_spans C \<epsilon>
using arr_char counit_in_hom by auto
lemma chine_unit_in_hom:
shows "\<guillemotleft>\<eta>.chine : f.dsrc \<rightarrow>\<^sub>C g.leg0 \<down>\<down> f.leg1\<guillemotright>"
proof -
have "\<guillemotleft>\<eta>.chine : \<eta>.dom.apex \<rightarrow>\<^sub>C \<eta>.cod.apex\<guillemotright>"
using \<eta>.chine_in_hom by simp
moreover have "\<eta>.dom.apex = f.dsrc"
using \<eta>.dom.apex_def dom_char unit_simps src_def by auto
moreover have "\<eta>.cod.apex = g.leg0 \<down>\<down> f.leg1"
proof -
have "\<eta>.cod.apex = C.dom \<eta>.cod.leg0" by simp
also have "... = C.dom (f.leg0 \<cdot> \<p>\<^sub>0[g.leg0, f.leg1])"
using cod_char unit_simps hcomp_def gf.composable by simp
also have "... = g.leg0 \<down>\<down> f.leg1"
using fgf.cospan_\<nu>\<pi> by simp
finally show ?thesis by blast
qed
ultimately show ?thesis by simp
qed
lemma chine_counit_in_hom:
shows "\<guillemotleft>\<epsilon>.chine : f.leg0 \<down>\<down> g.leg1 \<rightarrow>\<^sub>C f.dtrg\<guillemotright>"
proof -
have "\<guillemotleft>\<epsilon>.chine : \<epsilon>.dom.apex \<rightarrow>\<^sub>C \<epsilon>.cod.apex\<guillemotright>"
using \<epsilon>.chine_in_hom by simp
moreover have "\<epsilon>.cod.apex = f.dtrg"
using \<epsilon>.cod.apex_def cod_char counit_simps trg_def gf.composable by auto
moreover have "\<epsilon>.dom.apex = f.leg0 \<down>\<down> g.leg1"
proof -
have "\<epsilon>.dom.apex = C.dom \<epsilon>.dom.leg0" by simp
also have "... = C.dom (g.leg0 \<cdot> fg.prj\<^sub>0)"
using dom_char counit_simps hcomp_def fg.composable by simp
also have "... = f.leg0 \<down>\<down> g.leg1"
using fg.prj_in_hom(2) by auto
finally show ?thesis by blast
qed
ultimately show ?thesis by simp
qed
lemma \<eta>_leg_simps:
shows "\<eta>.dom.leg0 = f.dsrc" and "\<eta>.dom.leg1 = f.dsrc"
and "\<eta>.cod.leg0 = gf.leg0" and "\<eta>.cod.leg1 = gf.leg1"
proof -
show "\<eta>.dom.leg0 = f.dsrc"
using dom_char unit_simps(2) src_def by auto
show "\<eta>.dom.leg1 = f.dsrc"
using dom_char unit_simps(2) src_def by auto
show "\<eta>.cod.leg0 = gf.leg0"
using cod_char unit_simps(1,3)
by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
show "\<eta>.cod.leg1 = gf.leg1"
using cod_char unit_simps(1,3)
by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
qed
lemma \<epsilon>_leg_simps:
shows "\<epsilon>.cod.leg0 = f.dtrg" and "\<epsilon>.cod.leg1 = f.dtrg"
and "\<epsilon>.dom.leg0 = fg.leg0" and "\<epsilon>.dom.leg1 = fg.leg1"
proof -
show "\<epsilon>.cod.leg0 = f.dtrg"
using cod_char counit_simps(3) trg_def gf.composable by auto
show "\<epsilon>.cod.leg1 = f.dtrg"
using cod_char counit_simps(3) trg_def gf.composable by auto
show "\<epsilon>.dom.leg0 = fg.leg0"
using dom_char counit_simps hcomp_def fg.composable by simp
show "\<epsilon>.dom.leg1 = fg.leg1"
using dom_char counit_simps hcomp_def fg.composable by simp
qed
lemma Chn_triangle_eq:
shows "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
and "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
proof -
have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
proof -
have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
Chn \<l>[f] \<cdot> Chn (\<epsilon> \<star> f) \<cdot> Chn \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> Chn (f \<star> \<eta>) \<cdot> Chn \<r>\<^sup>-\<^sup>1[f]"
- using antipar Chn_vcomp hseqI' by auto
+ using antipar Chn_vcomp by auto
also have "... = \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
using \<alpha>_ide fg.composable gf.composable fgf.chine_assoc_inverse
C.inverse_unique inv_eq iso_assoc lunit_ide_eq hcomp_def [of \<epsilon> f]
gf.composable hcomp_def [of f \<eta>] fg.composable runit'_ide_eq
by simp
finally show ?thesis by blast
qed
moreover have "C.arr (Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]))"
proof -
have "\<guillemotleft>\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f\<guillemotright>"
using ide_left ide_right antipar triangle_in_hom(1) by blast
thus ?thesis
using Chn_in_hom by blast
qed
ultimately have *: "C.arr (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
by simp
have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
by fact
also have
1: "... = fgf.Prj\<^sub>0 \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
proof -
have "\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f = \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
proof -
have "chine_hcomp \<epsilon> f = \<langle>\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]
\<lbrakk>\<epsilon>.cod.leg0, f.leg1\<rbrakk>
\<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]\<rangle>"
using chine_hcomp_arr_ide gf.composable by simp
moreover have 1: "f.dtrg = \<epsilon>.cod.leg0"
using cod_char trg_def counit_simps gf.composable by simp
moreover have "C.commutative_square f.dtrg f.leg1
(\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]) \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
proof
show "C.cospan f.dtrg f.leg1" by simp
show 2: "C.span (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]) \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
using 1 \<open>C.cospan f.dtrg f.leg1\<close> chine_counit_in_hom by simp
show 3: "C.dom f.dtrg = C.cod (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1])"
using 1 2 dom_char counit_simps by simp
show "f.dtrg \<cdot> \<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1] = f.leg1 \<cdot> \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
using 1 2 3 C.comp_cod_arr dom_char counit_simps C.pullback_commutes'
by (metis (no_types, lifting) C.prj1_simps_arr C.seqE \<epsilon>.leg0_commutes)
qed
ultimately show ?thesis by simp
qed
also have "... = fgf.Prj\<^sub>0"
using dom_char counit_simps hcomp_def fg.composable by simp
finally have "\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f = fgf.Prj\<^sub>0"
by simp
moreover have "C.seq \<p>\<^sub>0[f.dtrg, f.leg1] (chine_hcomp \<epsilon> f)"
using chine_hcomp_props(1) fg.composable calculation(1) fgf.prj_in_hom(3)
by auto
moreover have "C.seq (chine_hcomp \<epsilon> f)
(fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
using chine_hcomp_props(1) fg.composable by (metis "*" C.seqE)
ultimately show ?thesis
using C.comp_reduce by simp
qed
also have 3: "... = fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
using C.comp_reduce [of fgf.Prj\<^sub>0 fgf.chine_assoc' fgf.Prj\<^sub>0\<^sub>0
"chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"]
* fgf.prj_chine_assoc'(3)
by blast
also have 4: "... = (gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]) \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
proof -
have "fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
proof -
have "fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> =
(gf.prj\<^sub>0 \<cdot> \<p>\<^sub>0[f.leg0, gf.leg1]) \<cdot>
\<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, gf.leg1\<rbrakk> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
using hcomp_def fg.composable gf.composable chine_hcomp_ide_arr \<eta>_leg_simps by auto
also have "... = gf.prj\<^sub>0 \<cdot> \<p>\<^sub>0[f.leg0, gf.leg1] \<cdot>
\<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, gf.leg1\<rbrakk> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
using C.comp_assoc by simp
also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
proof -
have "C.commutative_square f.leg0 gf.leg1 \<p>\<^sub>1[f.leg0, f.dsrc] (\<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc])"
proof
show "C.cospan f.leg0 gf.leg1"
using hcomp_def gf.composable fgf.prj_in_hom(5) by auto
show "C.span \<p>\<^sub>1[f.leg0, f.dsrc] (\<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc])"
using chine_unit_in_hom by auto
show "C.dom f.leg0 = C.cod \<p>\<^sub>1[f.leg0, f.dsrc]" by simp
show "f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = gf.leg1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
proof -
have "f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = \<p>\<^sub>0[f.leg0, f.dsrc]"
using C.comp_cod_arr C.pullback_commutes [of f.leg0 f.dsrc] by auto
also have "... = gf.leg1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
using unit_simps cod_char hcomp_def gf.composable \<eta>.leg1_commutes \<eta>_leg_simps
C.comp_cod_arr chine_unit_in_hom C.comp_reduce
by auto
finally show ?thesis by blast
qed
qed
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
moreover have "C.seq fgf.Prj\<^sub>0\<^sub>0 (chine_hcomp f \<eta>)"
using chine_hcomp_props(1) by (metis "*" 1 3 C.match_2 C.seqE)
moreover have "C.seq (chine_hcomp f \<eta>) \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
using chine_hcomp_props(1) by (metis "*" C.seqE)
ultimately show ?thesis
using C.comp_reduce by simp
qed
also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc] \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
using C.comp_assoc by simp
also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
using C.comp_cod_arr f.leg0_commutes by simp
finally show "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
by simp
have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
\<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
proof -
have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
Chn \<r>[g] \<cdot> Chn (g \<star> \<epsilon>) \<cdot> Chn \<a>[g, f, g] \<cdot> Chn (\<eta> \<star> g) \<cdot> Chn \<l>\<^sup>-\<^sup>1[g]"
- using antipar Chn_vcomp hseqI' by auto
+ using antipar Chn_vcomp by auto
also have "... = \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
\<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
using \<alpha>_ide gf.composable fg.composable runit_ide_eq hcomp_def [of g \<epsilon>]
fg.composable hcomp_def [of \<eta> g] gf.composable lunit'_ide_eq
by simp
finally show ?thesis by blast
qed
moreover have "C.arr (Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]))"
proof -
have "\<guillemotleft>\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g\<guillemotright>"
using ide_left ide_right antipar triangle_in_hom(2) by blast
thus ?thesis
using Chn_in_hom by blast
qed
ultimately have *: "C.arr (\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
\<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
by simp
have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
\<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
by fact
also have
1: "... = gfg.Prj\<^sub>1 \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
proof -
have "\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> = \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]"
proof -
have "chine_hcomp g \<epsilon> = \<langle>\<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]
\<lbrakk>g.leg0, \<epsilon>.cod.leg1\<rbrakk>
\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1]\<rangle>"
using chine_hcomp_ide_arr gf.composable by simp
moreover have 1: "g.dsrc = \<epsilon>.cod.leg1"
using gfg.cospan_\<mu>\<nu> by (simp add: \<epsilon>_leg_simps(2))
moreover have "C.commutative_square g.leg0 g.dsrc \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]
(\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1])"
proof
show "C.cospan g.leg0 g.dsrc" by simp
show 2: "C.span \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1] (\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1])"
using 1 \<open>C.cospan g.leg0 g.dsrc\<close> chine_counit_in_hom by simp
show 3: "C.dom g.leg0 = C.cod \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]"
using 1 2 dom_char counit_simps by simp
show "g.leg0 \<cdot> \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1] = g.dsrc \<cdot> \<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1]"
using 1 2 3 C.comp_cod_arr dom_char counit_simps C.pullback_commutes'
by (metis (no_types, lifting) C.cod_comp C.prj0_simps_arr C.seqE \<epsilon>.leg1_commutes)
qed
ultimately show ?thesis by simp
qed
also have "... = gfg.Prj\<^sub>1"
using dom_char counit_simps hcomp_def fg.composable by simp
finally have "\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> = gfg.Prj\<^sub>1"
by simp
moreover have "C.seq \<p>\<^sub>1[g.leg0, g.dsrc] (chine_hcomp g \<epsilon>)"
using chine_hcomp_props(1) [of g \<epsilon>] gf.composable calculation gfg.prj_in_hom(4)
by auto
moreover have "C.seq (chine_hcomp g \<epsilon>)
(gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
using chine_hcomp_props(1) gf.composable * by (metis C.seqE)
ultimately show ?thesis
using C.comp_reduce by simp
qed
also have 3: "... = gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
using C.comp_reduce [of gfg.Prj\<^sub>1 gfg.chine_assoc gfg.Prj\<^sub>1\<^sub>1
"chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"]
* gfg.prj_chine_assoc(1)
by blast
also have 4: "... = (gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
proof -
have "gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
proof -
have "gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g =
(gf.prj\<^sub>1 \<cdot> \<p>\<^sub>1[gf.leg0, g.leg1]) \<cdot>
\<langle>\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<lbrakk>gf.leg0, g.leg1\<rbrakk> \<p>\<^sub>0[g.dtrg, g.leg1]\<rangle>"
using hcomp_def fg.composable gf.composable chine_hcomp_arr_ide trg_def unit_simps(5)
\<eta>_leg_simps
by auto
also have "... = gf.prj\<^sub>1 \<cdot> \<p>\<^sub>1[gf.leg0, g.leg1] \<cdot>
\<langle>\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<lbrakk>gf.leg0, g.leg1\<rbrakk> \<p>\<^sub>0[g.dtrg, g.leg1]\<rangle>"
using C.comp_assoc by simp
also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
proof -
have "C.commutative_square gf.leg0 g.leg1 (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]"
proof
show "C.cospan gf.leg0 g.leg1"
using hcomp_def [of g f] gf.composable gfg.prj_in_hom(3) by auto
show "C.span (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]"
using chine_unit_in_hom fg.composable src_def trg_def by auto
show "C.dom gf.leg0 = C.cod (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1])"
using chine_unit_in_hom \<eta>_leg_simps
by (simp add: \<eta>.cod.apex_def
\<open>C.span (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]\<close>)
show "gf.leg0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] = g.leg1 \<cdot> \<p>\<^sub>0[g.dtrg, g.leg1]"
proof -
have "g.leg1 \<cdot> \<p>\<^sub>0[g.dtrg, g.leg1] = \<p>\<^sub>1[g.dtrg, g.leg1]"
using C.comp_cod_arr C.pullback_commutes [of g.dtrg g.leg1] by auto
also have "... = gf.leg0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
proof -
have "gf.leg0 \<cdot> \<eta>.chine = g.dtrg"
using unit_simps cod_char hcomp_def gf.composable \<eta>.leg0_commutes
dom_char trg_def fg.composable
by simp
moreover have "C.seq \<eta>.chine \<p>\<^sub>1[g.dtrg, g.leg1]"
using chine_unit_in_hom fg.composable src_def trg_def by auto
ultimately show ?thesis
using C.comp_cod_arr C.comp_reduce by auto
qed
finally show ?thesis by simp
qed
qed
thus ?thesis by simp
qed
finally show ?thesis by simp
qed
moreover have "C.seq gfg.Prj\<^sub>1\<^sub>1 (chine_hcomp \<eta> g)"
using chine_hcomp_props(1) [of \<eta> g] by (metis "*" 1 "3" C.match_2 C.seqE)
moreover have "C.seq (chine_hcomp \<eta> g) \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
using chine_hcomp_props(1) by (metis "*" C.seqE)
ultimately show ?thesis
using C.comp_reduce by simp
qed
also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
using C.comp_assoc by simp
also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
using C.comp_cod_arr g.leg1_commutes by simp
finally show "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
by simp
qed
end
subsection "Maps in Span(C)"
text \<open>
In this section, we chararacterize the maps (\emph{i.e}~the left adjoints)
in a span bicategory. This is Proposition 2 of \cite{carboni-et-al}.
\<close>
context span_bicategory
begin
abbreviation adjoint_of_map
where "adjoint_of_map f \<equiv> \<lparr>Chn = Chn f,
Dom = \<lparr>Leg0 = Leg1 (Dom f), Leg1 = Leg0 (Dom f)\<rparr>,
Cod = \<lparr>Leg0 = Leg1 (Dom f), Leg1 = Leg0 (Dom f)\<rparr>\<rparr>"
abbreviation unit_for_map
where "unit_for_map f \<equiv> \<lparr>Chn = \<langle>C.inv (Leg0 (Dom f))
\<lbrakk>Leg1 (Dom f), Leg1 (Dom f)\<rbrakk>
C.inv (Leg0 (Dom f))\<rangle>,
Dom = Dom (src f),
Cod = Dom (hcomp (adjoint_of_map f) f)\<rparr>"
abbreviation counit_for_map
where "counit_for_map f \<equiv> \<lparr>Chn = Leg1 (Dom f) \<cdot> \<p>\<^sub>0[Leg0 (Dom f), Leg0 (Dom f)],
Dom = Dom (hcomp f (adjoint_of_map f)),
Cod = Dom (trg f)\<rparr>"
lemma is_left_adjoint_char:
shows "is_left_adjoint f \<longleftrightarrow> ide f \<and> C.iso (Leg0 (Dom f))"
and "is_left_adjoint f \<Longrightarrow>
adjunction_in_bicategory vcomp hcomp assoc unit src trg f
(adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
proof
show 1: "is_left_adjoint f \<Longrightarrow> ide f \<and> C.iso (Leg0 (Dom f))"
proof
assume f: "is_left_adjoint f"
obtain g \<eta> \<epsilon> where adj: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>"
using f adjoint_pair_def by blast
interpret adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
using adj by auto
show "ide f" by simp
interpret f: identity_arrow_of_spans C f
using ide_char' [of f] by auto
interpret g: identity_arrow_of_spans C g
using ide_char' [of g] by auto
interpret gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
using antipar by (unfold_locales, auto)
interpret fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
using antipar by (unfold_locales, auto)
interpret fgf: three_composable_identity_arrows_of_spans C prj0 prj1 f g f ..
interpret src_f: arrow_of_spans C \<open>src f\<close>
using arr_char gf.are_arrows(2) by blast
interpret src_f: identity_arrow_of_spans C \<open>src f\<close>
using ide_char ide_src src_def by (unfold_locales, simp)
interpret \<eta>: arrow_of_spans C \<eta>
using arr_char unit_in_hom by auto
interpret \<epsilon>: arrow_of_spans C \<epsilon>
using arr_char counit_in_hom by auto
interpret adjunction_data_in_span_bicategory C prj0 prj1 f g \<eta> \<epsilon>
..
show "C.iso f.leg0"
proof -
have "C.section f.leg0"
proof -
have "f.chine = (gf.prj\<^sub>0 \<cdot> \<eta>.chine) \<cdot> f.leg0"
using triangle_left' Chn_triangle_eq(1) C.comp_assoc by simp
thus ?thesis
using f.chine_is_identity by auto
qed
moreover have "C.retraction f.leg0"
using C.retractionI [of f.leg0 "gf.prj\<^sub>0 \<cdot> \<eta>.chine"] hcomp_def C.comp_assoc
\<eta>.leg0_commutes gf.leg0_composite \<eta>_leg_simps
by auto
ultimately show ?thesis
by (simp add: C.iso_iff_section_and_retraction)
qed
qed
have 2: "ide f \<and> C.iso (Leg0 (Dom f)) \<Longrightarrow>
adjunction_in_bicategory vcomp hcomp assoc unit src trg f
(adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
text \<open>
The right adjoint \<open>g\<close> is obtained by exchanging the legs of \<open>f\<close>.
The unit is obtained by tupling \<open>C.inv f.leg0\<close> with itself,
via the pullback of \<open>f.leg1\<close> with itself.
The counit is given by the legs of \<open>f \<star> g\<close>, which are equal,
because the two legs of a pullback of the isomorphism \<open>f.leg0\<close>
with itself must be equal.
It then remains to verify the triangle identities.
\<close>
proof -
assume f: "ide f \<and> C.iso (Leg0 (Dom f))"
interpret f: identity_arrow_of_spans C f
using f ide_char' by auto
interpret Dom_src: span_in_category C \<open>\<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<close>
using f by (unfold_locales, auto)
interpret Dom_trg: span_in_category C \<open>\<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<close>
using f by (unfold_locales, auto)
define g where "g = adjoint_of_map f"
interpret Dom_g: span_in_category C \<open>\<lparr>Leg0 = f.leg1, Leg1 = f.leg0\<rparr>\<close>
by (unfold_locales, simp)
interpret g: arrow_of_spans C g
unfolding g_def
using Dom_g.apex_def f.leg0_commutes f.leg1_commutes
by (unfold_locales, auto)
interpret g: identity_arrow_of_spans C g
using g_def
by (unfold_locales, auto)
have ide_g: "ide g"
using f ide_char g.arrow_of_spans_axioms by simp
interpret fg: two_composable_arrows_of_spans C prj0 prj1 f g
apply unfold_locales
using g_def src_def trg_def arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms
by auto
interpret fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
..
interpret gf: two_composable_arrows_of_spans C prj0 prj1 g f
apply unfold_locales
using g_def src_def trg_def arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms
by auto
interpret gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
..
have hcomp_fg_eq: "hcomp f g = \<lparr>Chn = f.leg0 \<down>\<down> f.leg0,
Dom = \<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>,
Cod = \<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>\<rparr>"
using f g_def hcomp_def fg.composable src_def trg_def arr_char f.arrow_of_spans_axioms
g.arrow_of_spans_axioms chine_hcomp_def gf.are_identities(1) chine_hcomp_ide_ide
C.pullback_iso_self
by auto
have hcomp_gf_eq: "hcomp g f = \<lparr>Chn = f.leg1 \<down>\<down> f.leg1,
Dom = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>,
Cod = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>\<rparr>"
using g_def hcomp_def gf.composable src_def trg_def chine_hcomp_ide_ide
arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms ide_char
by simp
define \<eta> where "\<eta> = unit_for_map f"
interpret Dom_gf: span_in_category C \<open>\<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>\<close>
by (unfold_locales, simp_all)
interpret \<eta>: arrow_of_spans C \<eta>
using f g_def \<eta>_def hcomp_def src_def trg_def f.arrow_of_spans_axioms
g.arrow_of_spans_axioms arr_char C.comp_arr_inv'
C.tuple_in_hom [of f.leg1 f.leg1 "C.inv f.leg0" "C.inv f.leg0"]
Dom_src.apex_def Dom_gf.apex_def
apply unfold_locales by (simp_all add: C.comp_assoc)
have unit_in_hom: "\<guillemotleft>\<eta> : src f \<Rightarrow> hcomp g f\<guillemotright>"
proof
show 1: "arr \<eta>"
using arr_char \<eta>.arrow_of_spans_axioms by simp
show "dom \<eta> = src f"
using 1 \<eta>_def dom_char src_def Dom_src.apex_def by simp
show "cod \<eta> = hcomp g f"
using 1 \<eta>_def g_def cod_char hcomp_gf_eq Dom_gf.apex_def by simp
qed
define \<epsilon> where "\<epsilon> = counit_for_map f"
interpret Dom_fg: span_in_category C \<open>\<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>\<close>
by (unfold_locales, simp_all)
interpret \<epsilon>: arrow_of_spans C \<epsilon>
using f g_def \<epsilon>_def hcomp_def src_def trg_def f.arrow_of_spans_axioms
g.arrow_of_spans_axioms arr_char C.comp_cod_arr C.pullback_iso_self
Dom_trg.apex_def Dom_fg.apex_def
apply unfold_locales by auto
have counit_in_hom: "\<guillemotleft>\<epsilon> : hcomp f g \<Rightarrow> trg f\<guillemotright>"
proof
show 1: "arr \<epsilon>"
using arr_char \<epsilon>.arrow_of_spans_axioms by simp
show "cod \<epsilon> = trg f"
using 1 \<epsilon>_def cod_char trg_def Dom_trg.apex_def by simp
show "dom \<epsilon> = hcomp f g"
using 1 g_def \<epsilon>_def dom_char hcomp_fg_eq Dom_fg.apex_def by simp
qed
interpret adj: adjunction_data_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
using f ide_g unit_in_hom counit_in_hom gf.composable
by (unfold_locales, simp_all)
interpret adjunction_data_in_span_bicategory C prj0 prj1 f g \<eta> \<epsilon>
..
have triangle_left: "(\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<bullet> \<r>[f]"
proof -
have "\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f] = f"
proof (intro arr_eqI)
show "par (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) f"
using f ide_in_hom [of f] adj.triangle_in_hom(3)
by (metis (no_types, lifting) in_homE)
show "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = f.chine"
using f g_def \<eta>_def Chn_triangle_eq(1) C.comp_tuple_arr C.comp_inv_arr' by simp
qed
thus ?thesis
using adj.triangle_equiv_form by simp
qed
have triangle_right: "(g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<bullet> \<l>[g]"
proof -
have "\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g] = g"
proof (intro arr_eqI)
show "par (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) g"
using adj.ide_right ide_in_hom [of g] adj.triangle_in_hom(4)
by (metis (no_types, lifting) in_homE)
show "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = g.chine"
using f g_def \<eta>_def Chn_triangle_eq(2) C.comp_tuple_arr C.comp_inv_arr' by simp
qed
thus ?thesis
using adj.triangle_equiv_form by simp
qed
interpret adj: adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
using triangle_left triangle_right by (unfold_locales, simp_all)
show "adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>" ..
qed
show "ide f \<and> C.iso (Leg0 (Dom f)) \<Longrightarrow> is_left_adjoint f"
using 2 adjoint_pair_def by blast
show "is_left_adjoint f \<Longrightarrow> adjunction_in_bicategory vcomp hcomp assoc unit src trg f
(adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
using 1 2 by blast
qed
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,4501 +1,4491 @@
(* Title: Strictness
Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
*)
section "Strictness"
theory Strictness
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'
+ using 2 assoc_in_hom [of "dom \<mu>" "dom \<nu>" "dom \<tau>"] strict_assoc comp_arr_dom
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>)"
..
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 (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
+ by auto
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
+ using assms 1 arr_char src_def trg_def
+ apply (intro conjI B.in_homI) 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
+ proof -
+ have "E.Nml (Dom \<mu>) \<and> E.Nml (Dom \<nu>) \<and> E.Nml (Dom \<tau>)"
+ using assms by blast
+ moreover have "E.Src (Dom \<mu>) = E.Trg (Dom \<nu>) \<and> E.Src (Dom \<nu>) = E.Trg (Dom \<tau>)"
+ using assms \<mu>\<nu> \<nu>\<tau>
+ by (metis (no_types, lifting) src_simps(2) trg_simps(2))
+ ultimately show ?thesis
+ using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc by simp
+ qed
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
+ proof -
+ have "E.Nml (Cod \<mu>) \<and> E.Nml (Cod \<nu>) \<and> E.Nml (Cod \<tau>)"
+ using assms by blast
+ moreover have "E.Src (Cod \<mu>) = E.Trg (Cod \<nu>) \<and> E.Src (Cod \<nu>) = E.Trg (Cod \<tau>)"
+ using assms \<mu>\<nu> \<nu>\<tau>
+ by (metis (no_types, lifting) arrE src_simps(2) trg_simps(2))
+ ultimately show ?thesis
+ using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc by simp
+ qed
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
+ using assms \<mu>\<nu> \<nu>\<tau> hcomp_def E.HcompNml_assoc src_def trg_def arr_char
+ E.Nml_HcompNml E.Ide_HcompNml
+ by auto (* 5 sec *)
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
+ using assms 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
+ using VVV.arr_char VV.arr_char \<a>_def 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
+ using VVV.arr_char VV.arr_char \<a>_def 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 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 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
+ using \<mu>\<nu> B.VV.arr_char
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 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)
+ apply (intro comp_MkArr arr_MkArr) 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>)"
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
+ using assms UP.FF_def by fastforce
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)"
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)"
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)
+ 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)
+ by simp
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 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
+ using \<mu>\<nu> DN_def VV.arr_char B.comp_assoc by simp
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"
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] \<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 \<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)
+ using assms
+ apply (intro comp_MkArr arr_MkArr)
+ apply auto
+ by fastforce
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)
+ using assms 0 B.comp_arr_dom
+ by (intro comp_MkArr arr_MkArr, auto)
ultimately show ?thesis by argo
qed
also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
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')
+ using assms \<Psi>_char by (auto simp add: D.hcomp_obj_arr)
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
+ using assms \<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
+ using assms 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
+ using assms D.comp_arr_dom D.comp_cod_arr \<Psi>_char 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')
+ using assms \<Psi>_char by (auto simp add: D.hcomp_arr_obj)
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
+ using assms \<Phi>_in_hom(2) 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
+ using assms 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
+ using assms 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
+ using assms 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
+ using assms \<open>D.hseq (F f) (\<Phi> (g, h))\<close> \<Phi>_simps(1) \<Phi>_simps(4) by auto
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
+ using assms \<open>D.hseq (F f) (\<Phi> (g, h))\<close> \<Phi>_simps(1) \<Phi>_simps(4) by auto
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
+ using assms 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
+ using assms C.VV.arr_char 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
+ using assms 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
+ using assms 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
+ using assms 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')
+ by (simp add: D.inv_comp D.isos_compose)
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
+ using antipar inv_comp hcomp_assoc 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))
+ using ide_left ide_right antipar comp_assoc whisker_right comp_cod_arr
+ by (metis "2" comp_arr_dom counit_simps(1-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
+ using 2 antipar 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
+ using antipar 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 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")
+ using 2 antipar by simp
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
+ using antipar hcomp_assoc hcomp_obj_arr by auto
ultimately show ?thesis
- using antipar counit_is_iso comp_assoc comp_arr_dom hcomp_obj_arr hseqI'
+ using comp_assoc comp_arr_dom hcomp_obj_arr
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
+ using antipar comp_assoc hcomp_assoc whisker_left hcomp_arr_obj 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
+ using antipar comp_arr_dom whisker_left hcomp_arr_obj 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'
+ using antipar comp_arr_dom comp_cod_arr whisker_left
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
+ using antipar comp_assoc whisker_left whisker_right hcomp_assoc 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
+ using antipar comp_cod_arr 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
+ using antipar hcomp_arr_obj hcomp_assoc interchange by auto
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)
+ using 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
+ using antipar 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')
+ using hcomp_obj_arr [of "trg f" "f \<star> inv \<eta>"] by fastforce
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')
+ using antipar 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
+ using antipar 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"]
+ using antipar UP.FF_def 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
+ using antipar 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)
+ using antipar UP.\<Phi>_in_hom(2) 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
+ using antipar S.comp_inv_arr' S.comp_cod_arr 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
+ using antipar VV.arr_char S.comp_cod_arr 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
+ using antipar 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'
+ using antipar UP.FF_def VV.ide_char VV.arr_char UP.\<Phi>_in_hom [of "trg f" f]
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
+ using antipar 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)
+ using antipar 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
+ using antipar S.comp_cod_arr VV.arr_char 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
+ using antipar S.comp_inv_arr' S.comp_cod_arr 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
+ using antipar VV.arr_char 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
+ using antipar S.iso_is_retraction S.retraction_is_epi 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
+ using antipar VV.arr_char 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
+ using 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
+ using antipar 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')
+ by (simp add: S.hcomp_obj_arr)
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
+ using 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
+ using UP.\<Psi>_char 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
+ using antipar 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
+ using antipar 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'
+ using antipar strict_assoc assoc'_in_hom(2) [of f g f] comp_cod_arr
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'
+ using antipar strict_assoc assoc_in_hom(2) [of g f g] comp_cod_arr
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,1363 +1,1342 @@
(* 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 "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
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)
+ by (metis (no_types, lifting) B.H.preserves_reflects_arr B.trg_hcomp
+ VV.arr_char VVV.arrE arr_char)
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.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 "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
qed
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
+ using f \<mu> \<mu>_eq ide_char arr_char B.trg_dom [of ?\<mu>] by fastforce
ultimately show ?thesis
- using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char B.hseqI' by auto
+ using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char 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
+ using f \<mu> \<mu>_eq ide_char arr_char B.src_dom [of ?\<mu>] by fastforce
ultimately show ?thesis
- using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char B.hseqI' by auto
+ using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char 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 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
+ using f arr_char hcomp_def 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
+ using f arr_char hcomp_def 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 0: "in_hhom (dom \<mu>) a a"
+ using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
+ have 1: "in_hhom \<phi> a a"
+ using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
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
+ using \<mu> 0 1 by auto
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
+ proof (intro seqI')
+ show "\<guillemotleft>\<phi> \<star> dom \<mu> : w \<star> dom \<mu> \<Rightarrow> a \<star> dom \<mu>\<guillemotright>"
+ by (metis (no_types, lifting) 0 \<mu> \<phi> hcomp_in_vhom ide_dom ide_in_hom(2)
+ in_hhom_def w_simps(3))
+ show "\<guillemotleft>\<ll> \<mu> : a \<star> dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
+ using \<mu> 2 \<ll>.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] arr_simps(2) arr_cod by fastforce
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)
+ using \<mu> 3 hcomp_simps(3) dom_comp dom_dom
+ apply (elim seqE) by auto
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))
+ using \<mu> \<phi> 2
+ by (metis (no_types, lifting) arr_simps(2) seqE vconn_implies_hpar(1) w_simps(3))
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
+ using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom 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
+ using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom 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 0: "in_hhom (dom \<mu>) a a"
+ using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
+ have 1: "in_hhom \<phi> a a"
+ using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
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))
+ using \<mu> 0 1 by auto
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
+ proof (intro seqI')
+ show "\<guillemotleft>dom \<mu> \<star> \<phi> : dom \<mu> \<star> w \<Rightarrow> dom \<mu> \<star> a\<guillemotright>"
+ by (metis (no_types, lifting) "0" "1" \<mu> \<phi> hcomp_in_vhom hseqI hseq_char
+ ide_dom ide_in_hom(2) vconn_implies_hpar(2))
+ show "\<guillemotleft>\<rr> \<mu> : dom \<mu> \<star> a \<Rightarrow> cod \<mu>\<guillemotright>"
+ using \<mu> 2 \<rr>.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] arr_simps(2) arr_cod by fastforce
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)
+ using \<mu> 3 hcomp_simps(3) dom_comp dom_dom
+ apply (elim seqE) by auto
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
+ VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp H.preserves_reflects_arr hseqI'
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
+ using f g h k ide_char arr_char 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'
+ using assms iso_unit in_homE isoE isomorphicE VVV.arr_char VV.arr_char
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,6191 @@
(* 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
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))
+ by (metis arrI hcomp_simps(1) hcomp_simps(2) in_hhomI not_arr_null
+ src.is_extensional src.preserves_hom vconn_implies_hpar(1)
+ vconn_implies_hpar(2) vconn_implies_hpar(3) vconn_implies_hpar(4))
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)
+ using assms ide_base ide_leg0 tab_in_hom by fastforce
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
+ using tab_in_hom T0.antipar(1) 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
+ using T0.antipar(1-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)
+ using T0.antipar by 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))
+ by (metis arr_dom in_homE leg0_simps(3) trg_hcomp vconn_implies_hpar(4))
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))
+ by (metis ide_base leg0_simps(3) runit'_simps(1) seqE src_hcomp vconn_implies_hpar(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
+ using f\<^sub>a 1 2 \<epsilon> 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')
+ by (simp add: \<nu> comp_cod_arr)
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'
+ using 1 2 \<open>ide f\<^sub>a\<close> ide_leg0 iso_inv_iso iso_assoc
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
+ using 1 2 \<open>ide f\<^sub>a\<close> \<eta>_in_hom \<epsilon> 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
+ using f\<^sub>a 1 2 \<epsilon> 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'
+ using interchange comp_arr_dom comp_cod_arr 1 2 \<open>ide f\<^sub>a\<close>
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
+ using 1 2 comp_cod_arr \<open>ide f\<^sub>a\<close> comp_assoc_assoc' 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
+ using ide_base T0.antipar hseq_char T0.trnr\<^sub>\<epsilon>_def rep_in_hom w\<theta>'\<nu>
+ apply (intro comp_in_homI') 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
+ using \<gamma> whisker_left trg_\<gamma>_eq 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
+ 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)
+ using \<gamma> T0.antipar hseq_char by force
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
+ using comp_arr_dom comp_cod_arr 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
+ using comp_arr_dom comp_cod_arr 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
+ using assoc_naturality [of r f "f\<^sup>* \<star> \<theta>'"] T0.antipar by fastforce
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
+ using whisker_left 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
+ 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
+ using whisker_left 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
+ using whisker_left 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
+ using whisker_left 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
+ using whisker_left 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
+ using whisker_left 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'
+ comp_arr_dom comp_cod_arr T0.unit_in_hom
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'
+ comp_cod_arr 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
+ whisker_left comp_assoc 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
+ using T0.antipar comp_cod_arr 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
+ using T0.antipar comp_cod_arr 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
+ using assoc_naturality [of r f "\<eta> \<star> w"] 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
+ using assoc'_naturality [of f \<eta> w] 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
+ using whisker_left whisker_right 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
+ using whisker_left 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
+ using comp_cod_arr
+ by (metis assoc_is_natural_1 base_simps(2-3) leg0_simps(2-4)
+ w_simps(2) w_simps(4) w_simps(5))
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'
+ using 1 w\<theta>'\<nu> \<gamma> trg_\<gamma>_eq isos_compose iso_inv_iso
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))
+ using \<omega> 1 u ide_right antipar(1) vconn_implies_hpar(4) by force
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')
+ using comp_arr_dom by (simp add: comp_inv_arr')
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
+ using \<gamma> 3 hcomp_obj_arr by blast
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 (intro seqI)
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
+ using \<theta> ide_base ide_dom [of \<theta>] trg_dom [of \<theta>]
+ using arrI fw vconn_implies_hpar(2) by auto
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')
+ using whisker_left comp_assoc 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 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
+ using \<nu>'\<nu> iso_\<nu>'\<nu>_r by auto
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
+ using inv_\<nu>'\<nu>_r \<theta>\<theta>' eq'
+ T2 [of "w' \<star> w" "src f" "\<theta> \<cdot> (\<theta>' \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[f, w', w]" f] 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)
+ proof -
+ have "(\<rho> \<star> src \<rho>) \<cdot> (dom \<rho> \<star> src (dom \<rho>)) = \<rho> \<star> src \<rho>"
+ using R.is_natural_1 arr_dom tab_simps(1) by presburger
+ thus ?thesis
+ by simp
+ qed
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
+ using T2 by presburger
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)
+ by (metis arr_cod in_homE leg0_simps(2) src_hcomp src_src vconn_implies_hpar(3))
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)
+ by (metis T'.leg0_simps(2) arr_cod in_homE src_hcomp src_src vconn_implies_hpar(3))
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')
+ 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')
+ using v'_def D.vconn_implies_hpar(4) \<omega>' u' by force
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)
+ 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'
+ 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)
+ 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)
+ 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
+ using \<omega> w\<theta>\<nu> \<Phi>_in_hom(2) [of "r \<star>\<^sub>C f" w] C.VV.arr_char FF_def by auto
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>)
+ 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-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
+ by presburger
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'
+ using 1 w\<theta>\<nu> D.assoc_naturality [of "F r" "\<Phi> (f, w)" d']
\<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)
+ using w\<theta>\<nu> C.arrI C.vconn_implies_hpar(1) by auto
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']
+ using F\<omega> F\<omega>_def \<omega>' D.comp_assoc 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')
+ using u' by simp
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'
+ using u' D.comp_assoc
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
+ using u u' \<phi> 1 2 D.src_dom e'.antipar 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')
+ 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))
+ by (metis D.arr_dom D.in_homE D.trg_hcomp D.vconn_implies_hpar(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))
+ by (metis D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) \<open>trg\<^sub>D \<theta> = trg\<^sub>D (F f)\<close> \<theta>)
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)
+ by (metis D.ideD(1) D.in_homE D.src_hcomp D.vconn_implies_hpar(1) \<open>src\<^sub>D \<theta>' = a\<close>
+ \<theta>' category.ide_dom horizontal_homs_def weak_arrow_of_homs_axioms
+ weak_arrow_of_homs_def)
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'
+ D.comp_cod_arr
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
+ using w\<^sub>C D.comp_cod_arr D.comp_inv_arr' \<Phi>_simps(1,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)
+ by (metis D.comp_arr_ide D.comp_cod_arr D.in_homE D.seqI' T'.ide_leg1
+ T'.leg1_in_hom(2) T'.tab_in_vhom')
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)
+ 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 (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'
+ 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
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)
+ 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>')
+ by (metis D.cod_inv D.comp_null(2) D.hseq_char' D.in_homE
+ D.is_weak_composition T'.leg1_simps(6) \<phi>'
+ weak_composition.hcomp_simps\<^sub>W\<^sub>C(3))
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)
+ using w' by simp
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
+ using w' w'e 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 (\<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)
+ by (metis (no_types, lifting) D.comp_assoc_assoc'(2) D.hcomp_simps(1)
+ D.hcomp_simps(4) D.hseqI' D.ide_char D.in_homE D.vconn_implies_hpar(1)
+ D.vconn_implies_hpar(3) T'.ide_leg1 T.leg1_simps(2) T.leg1_simps(3)
+ 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'
+ using 2 \<phi> \<phi>'
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)
+ moreover have "C.par \<beta>\<^sub>C (g \<star>\<^sub>C \<gamma>\<^sub>C')"
+ proof (intro conjI)
+ show "C.arr \<beta>\<^sub>C"
+ using \<beta>\<^sub>C by blast
+ show 2: "C.hseq g \<gamma>\<^sub>C'"
+ using F\<beta>\<^sub>C \<beta>\<^sub>C calculation by fastforce
+ show "C.dom \<beta>\<^sub>C = C.dom (g \<star>\<^sub>C \<gamma>\<^sub>C')"
+ using 2 \<beta>\<^sub>C \<gamma>\<^sub>C' by fastforce
+ show "C.cod \<beta>\<^sub>C = C.cod (g \<star>\<^sub>C \<gamma>\<^sub>C')"
+ using 2 \<beta>\<^sub>C \<gamma>\<^sub>C' by fastforce
+ qed
+ ultimately show ?thesis using is_faithful by blast
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
+ by fastforce
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)
+ moreover have "C.par \<theta>\<^sub>C (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C'))"
+ proof (intro conjI)
+ show "C.arr \<theta>\<^sub>C"
+ using \<theta>\<^sub>C by auto
+ show 1: "C.seq \<theta>\<^sub>C' (f \<star>\<^sub>C \<gamma>\<^sub>C')"
+ using \<theta>\<^sub>C' \<gamma>\<^sub>C'
+ by (metis C.arrI \<theta>\<^sub>C calculation preserves_reflects_arr)
+ show "C.dom \<theta>\<^sub>C = C.dom (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C'))"
+ using 1 \<theta>\<^sub>C \<gamma>\<^sub>C' by fastforce
+ show "C.cod \<theta>\<^sub>C = C.cod (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C'))"
+ using 1 \<theta>\<^sub>C \<gamma>\<^sub>C' \<gamma>\<^sub>C by auto
+ qed
+ ultimately show ?thesis
+ using is_faithful by blast
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)
+ apply (intro D.comp_in_homI)
+ apply auto[2]
+ apply fastforce
+ apply auto[3]
+ apply fastforce
+ by 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"
+ using w'e D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc'(1) 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)
+ using we e.ide_right e.antipar P\<gamma>e by fastforce
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'
+ 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)
+ using w w' e e.antipar by simp
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)
+ using w w' e e.antipar by simp
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
+ 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))
+ by (metis D.cod_cod D.hcomp_simps(1) D.hcomp_simps(4)
+ D.in_homE D.trg.preserves_reflects_arr D.vconn_implies_hpar(1)
+ D.vconn_implies_hpar(2) D.vconn_implies_hpar(3) D.vconn_implies_hpar(4)
+ \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> e.counit_in_hom(2) e.counit_simps(5))
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>)
+ 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
+ using 1 2 e.antipar D.isomorphic_implies_ide(2) w\<^sub>C' w'e D.comp_assoc_assoc'
+ by auto
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)
+ using we 1 2 e.antipar P\<gamma>e by fastforce
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')
+ using w D.comp_cod_arr D.comp_assoc_assoc' 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 \<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
+ using w'e 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'
+ using w D.comp_cod_arr D.assoc'_in_hom(2) [of "F f" w "trg\<^sub>D e"]
\<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'
+ 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)
+ by (metis C.hseqI' C.ideD(1) C.in_hhomE C.src_hcomp C.vconn_implies_hpar(1)
+ C.vconn_implies_hpar(3) \<rho>.base_simps(2) \<rho>.leg0_in_hom(1) 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
+ using \<phi> \<rho>'.leg0_in_hom(2) w' by fastforce
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
+ 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
+ using w' D.comp_inv_arr' 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))
+ by (metis C.in_hhom_def D.arrI D.cod_inv D.seqE)
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)
+ by (metis C.hseq_char' C.in_homE C.trg.is_extensional C.trg.preserves_hom
+ C.trg_hcomp C.vconn_implies_hpar(2) C.vconn_implies_hpar(4) \<rho>.leg0_simps(3))
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
+ by fastforce
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
+ 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
+ using w' D.comp_inv_arr' 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
+ using assms(1) \<theta>' D.comp_cod_arr 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
+ using w' \<theta>' preserves_hcomp 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
+ using w' preserves_hcomp 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
+ using w' \<theta>' C.comp_assoc hseq_ru hseq_fw 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)
+ D.ext D.seqE \<rho>.tab_simps(4) 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
+ using w \<theta> C.comp_assoc hseq_ru hseq_fw 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
+ using w \<theta> preserves_hcomp 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
+ using w preserves_hcomp 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
+ using \<theta> D.comp_cod_arr hseq_ru 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
+ 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
+ using w D.comp_inv_arr' 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
+ using w \<theta> D.comp_arr_dom D.comp_inv_arr' hseq_gw 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)
+ 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)
+ using \<gamma> \<theta> \<theta>' hseq_fw C.hseqI' preserves_comp by force
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)
+ moreover have "C.par \<theta> (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>))"
+ using \<gamma> \<theta> \<theta>' hseq_fw by fastforce
+ ultimately show ?thesis
+ using is_faithful by blast
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)
+ moreover have "C.par \<beta> (g \<star>\<^sub>C \<gamma>)"
+ proof (intro conjI)
+ show "C.arr \<beta>"
+ using \<beta> by blast
+ show 1: "C.hseq g \<gamma>"
+ using \<gamma> hseq_gw by fastforce
+ show "C.dom \<beta> = C.dom (g \<star>\<^sub>C \<gamma>)"
+ using \<gamma> \<beta> 1 by fastforce
+ show "C.cod \<beta> = C.cod (g \<star>\<^sub>C \<gamma>)"
+ using \<gamma> \<beta> 1 by fastforce
+ qed
+ ultimately show ?thesis
+ using is_faithful by blast
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
+ using \<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
+ using \<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/Category3/Category.thy b/thys/Category3/Category.thy
--- a/thys/Category3/Category.thy
+++ b/thys/Category3/Category.thy
@@ -1,626 +1,621 @@
(* 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"
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
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-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_homI' [simp]:
+ assumes "arr f" and "arr g" and "dom f = a" and "cod g = c" and "dom g = cod f"
+ shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
+ using assms by auto
+
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)"
using ide_dom ide_cod ide_char by metis
lemma dom_dom:
assumes "arr f"
shows "dom (dom f) = dom f"
using assms by simp
lemma cod_cod:
assumes "arr f"
shows "cod (cod f) = cod f"
using assms by simp
lemma dom_cod:
assumes "arr f"
shows "dom (cod f) = cod f"
using assms by simp
lemma cod_dom:
assumes "arr f"
shows "cod (dom f) = dom f"
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"
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
end
diff --git a/thys/Category3/Limit.thy b/thys/Category3/Limit.thy
--- a/thys/Category3/Limit.thy
+++ b/thys/Category3/Limit.thy
@@ -1,6171 +1,6170 @@
(* 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 \<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 \<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"
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 \<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 \<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 \<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)"
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_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.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_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"
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"
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>"
proof -
fix \<phi>'
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>': 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 \<open>F a\<close>
apply unfold_locales using \<chi>.ide_apex by auto
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 \<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 \<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 \<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' \<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' \<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>)"
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 \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
using SetCat.is_set_category by auto
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 \<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 \<open>SetCat.comp :: ('c + ('j \<Rightarrow> 'c)) setcat.arr comp\<close>
\<open>\<lambda>_. UP o Inl\<close> ..
interpretation Ya: yoneda_functor_fixed_object
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
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"
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 \<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 \<open>Y a\<close> 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 \<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>"
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"
\<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 \<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 \<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 \<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 \<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 \<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))
(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 \<open>C.dom f\<close>
using f by (unfold_locales, auto)
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_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_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 \<open>C.dom f\<close>
using f by (unfold_locales, auto)
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 \<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))"
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)"
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)"
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
Fun_g.natural_transformation_axioms
by blast
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.Map d)" and "J_C.MkIde (J_C.Map d) = d"
proof -
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.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
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.Map (Collect J_C.ide) (Collect (diagram J C))"
proof (intro bij_betwI)
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"
using diagram_determines_ide by blast
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.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.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 \<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.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.Map d"
using x.arrow by auto
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.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.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.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 \<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.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.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.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"
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>'"
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>"
proof -
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_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_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>"
proof -
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_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_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)"
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.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.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.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.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.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.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.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.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 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.Map (map g)) ?\<chi>)"
using J_C.comp_char [of x "map g"] by simp
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)"
proof -
have f1: "A'.map = J_C.Dom (map g)"
using \<gamma>.natural_transformation_axioms map_def g by auto
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'"
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.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 ?a = "G ?d"
let ?x = "Adj.\<epsilon> ?d"
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.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>'"
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))"
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 \<open>J_C.Map d\<close>
using D \<Delta>.ide_determines_diagram by auto
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 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 -
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.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 "\<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
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
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 \<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 \<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 \<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 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 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 \<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 \<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 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 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 (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"
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
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 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 \<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 \<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 \<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 \<open>Collect J.arr\<close> J.null
using J.not_arr_null by (unfold_locales, blast)
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 \<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 \<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 \<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 \<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 \<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')
+ using 2 e_in_hom h'_in_hom \<pi>o.cone_axioms by auto
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 \<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 \<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 \<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 \<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 \<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 \<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' \<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 \<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 .
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 \<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 \<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 \<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 \<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 \<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 \<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 \<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 \<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 \<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>_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 \<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 \<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 \<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
\<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 \<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.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 \<open>Curry.uncurry F\<close>
using assms(1) Curry.uncurry_preserves_functors by simp
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 \<open>Curry.uncurry F\<close>
using assms(1) Curry.uncurry_preserves_functors by simp
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 \<open>Curry.uncurry F\<close>
using Curry.uncurry_preserves_functors \<tau>.F.functor_axioms by simp
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 \<open>Curry.uncurry G\<close> ..
interpret uncurry_\<tau>: natural_transformation
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
\<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.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 \<open>A_B.Map x\<close>
using x A_B.ide_char by simp
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 \<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.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 \<open>A_B.Map x\<close>
using x A_B.ide_char by simp
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 \<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 \<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 \<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 \<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 \<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 \<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.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' \<open>cones_map f \<chi>\<close>
using x' f assms(1) cones_map_mapsto by blast
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.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.Map f a) (at a \<chi>) = at a \<chi>'"
proof -
fix a
assume a: "A.ide a"
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 \<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.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 (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.Map f a) (at a \<chi>) = at a \<chi>'"
proof
fix 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.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.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.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.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.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.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.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.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 (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.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.Map (cones_map f \<chi> j) = A_B.Map (\<chi>' j)"
proof (intro NaturalTransformation.eqI)
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.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.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 \<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 \<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 \<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.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.Map (cones_map f \<chi> j) a = Da.cones_map (A_B.Map f a) (at a \<chi>) j"
proof -
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.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 (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.Map (\<chi>' j) a"
using j Curry.uncurry_def E.map_simp \<chi>'j.is_extensional by simp
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.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.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.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 \<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 \<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.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.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.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 \<open>\<lambda>a. A_B.Map x a\<close>
using x A_B.ide_char by simp
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
\<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.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.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.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 \<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 \<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 \<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 \<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 \<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 \<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 \<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.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.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.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.Map x a"
using a j at_simp by simp
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.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.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.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.Map x' a"
using a j at_simp by simp
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 \<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.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.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.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.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.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.Map f')"
using f' A_B.MkArr_Map by auto
also have "... = ?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.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.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.Map f' a = \<phi>.map a"
proof -
fix a
assume a: "A.ide a"
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.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.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.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 \<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 \<open>Curry.uncurry D\<close>
using D.functor_axioms Curry.uncurry_preserves_functors by simp
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 \<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' \<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 \<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 \<open>D.at (A.dom ?a) D\<close>
using a D.at_ide_is_diagram by auto
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 \<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 \<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 \<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 =
Map (D (J.cod ?j)) ?a \<cdot>\<^sub>B Map (D ?j) (A.dom ?a)"
using ja D.at_simp by auto
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_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 \<open>MkIde ?L\<close>
proof
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))
(\<lambda>a. ?L' (j, a))"
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
\<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 \<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 \<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)"
proof -
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 \<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 \<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.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 \<open>YoD.at a' (map o D)\<close>
using a' YoD.at_ide_is_diagram by simp
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.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.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.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.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 \<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
\<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' \<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.Map (map a) a'"
using f Fun_map_a_a' by force
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 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
\<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' \<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' \<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.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

File Metadata

Mime Type
application/octet-stream
Expires
Sat, Apr 27, 3:19 AM (1 d, 23 h)
Storage Engine
chunks
Storage Format
Chunks
Storage Handle
i6md5v.Dz3uQ
Default Alt Text
(4 MB)

Event Timeline