Theory Tabulation
section "Tabulations"
theory Tabulation
imports CanonicalIsos InternalAdjunction
begin
text ‹
A ``tabulation'' is a kind of bicategorical limit that associates with a 1-cell ‹r›
a triple ‹(f, ρ, g)›, where ‹f› and ‹g› are 1-cells having a common source,
and ‹ρ› is a $2$-cell from ‹g› to ‹r ⋅ f›, 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 ‹r›, up to isomorphism,
as the composition ‹g ⋅ f⇧*› of a map ‹g› and the right adjoint ‹f⇧*› of a map ‹f›.
In order to be able to express this as a bicategorical limit, CKS consider,
instead of an isomorphism ‹«φ : g ⋆ f⇧* ⇒ r»›, its transpose
‹ρ : g ⇒ r ⋆ f› under the adjunction ‹f ⊣ f⇧*›.
›
subsection "Definition of Tabulation"
text ‹
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}
\\
&
}$$
›
locale tabulation_data =
bicategory +
fixes r :: 'a
and ρ :: 'a
and f :: 'a
and g :: 'a
assumes ide_base: "ide r"
and ide_leg0: "ide f"
and tab_in_vhom': "«ρ : g ⇒ r ⋆ f»"
begin
lemma base_in_hom [intro]:
shows "«r : src r → trg r»" and "«r : r ⇒ r»"
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 "«ρ : src f → trg r»" and "«ρ : g ⇒ r ⋆ f»"
using tab_in_vhom' src_dom [of ρ] trg_dom [of ρ] base_in_hom apply auto
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 "«g : src f → trg r»" and "«g : g ⇒ g»"
using ide_leg1 apply auto
using tab_in_hom ide_dom [of ρ]
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 ρ" and "src ρ = src f" and "trg ρ = trg r"
and "dom ρ = g" and "cod ρ = r ⋆ f"
using tab_in_hom by auto
lemma leg0_in_hom [intro]:
shows "«f : src f → src r»" and "«f : f ⇒ f»"
using ide_leg0 apply auto
using tab_in_hom ide_cod [of ρ] 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 ‹
The following function, which composes ‹ρ› with a 2-cell ‹«θ : f ⋆ w ⇒ u»› to obtain
a 2-cell ‹«(r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) : g ⋆ w ⇒ r ⋆ u»"›,
occurs frequently in the sequel.
›
abbreviation (input) composite_cell
where "composite_cell w θ ≡ (r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w)"
lemma composite_cell_in_hom:
assumes "ide w" and "«w : src u → src f»" and "«θ : f ⋆ w ⇒ u»"
shows "«composite_cell w θ : g ⋆ w ⇒ r ⋆ u»"
proof (intro comp_in_homI)
show "«ρ ⋆ w : g ⋆ w ⇒ (r ⋆ f) ⋆ w»"
using assms tab_in_hom
apply (elim conjE in_hhomE in_homE)
by (intro hcomp_in_vhom, auto)
show "«𝖺[r, f, w] : (r ⋆ f) ⋆ w ⇒ r ⋆ f ⋆ w»"
using assms ide_base ide_leg0 tab_in_hom by fastforce
show "«r ⋆ θ : r ⋆ f ⋆ w ⇒ r ⋆ u»"
using assms ide_base ide_leg0 tab_in_hom by fastforce
qed
text ‹
We define some abbreviations for various combinations of conditions that occur in the
hypotheses and conclusions of the tabulation axioms.
›
abbreviation (input) uwθω
where "uwθω u w θ ω ≡ ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ω : dom ω ⇒ r ⋆ u»"
abbreviation (input) uwθων
where "uwθων u w θ ω ν ≡
ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧ iso ν ∧
(r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν = ω"
abbreviation (input) uwθw'θ'β
where "uwθw'θ'β u w θ w' θ' β ≡
ide u ∧ ide w ∧ ide w' ∧
«θ : f ⋆ w ⇒ u» ∧ «θ' : f ⋆ w' ⇒ u» ∧ «β : g ⋆ w ⇒ g ⋆ w'» ∧
(r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) = (r ⋆ θ') ⋅ 𝖺[r, f, w'] ⋅ (ρ ⋆ w') ⋅ β"
end
text ‹
CKS define two notions of tabulation.
The first, which they call simply ``tabulation'', is restricted to triples ‹(f, ρ, g)›
where the ``input leg'' ‹f› is a map, and assumes only a weak form of the biuniversal
property that only applies to ‹(u, ω, v)› for which u is a map.
The second notion, which they call ``wide tabulation'', concerns arbitrary ‹(f, ρ, g)›,
and assumes a strong form of the biuniversal property that applies to all ‹(u, ω, v)›.
On its face, neither notion implies the other: ``tabulation'' has the stronger assumption
that ‹f› is a map, but requires a weaker biuniversal property, and ``wide tabulation''
omits the assumption on ‹f›, but requires a stronger biuniversal property.
CKS Proposition 1(c) states that if ‹(f, ρ, g)› is a wide tabulation,
then ‹f› 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.
›
locale tabulation =
tabulation_data +
assumes T1: "⋀u ω.
⟦ ide u; «ω : dom ω ⇒ r ⋆ u» ⟧ ⟹
∃w θ ν. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧ iso ν ∧
composite_cell w θ ⋅ ν = ω"
and T2: "⋀u w w' θ θ' β.
⟦ ide w; ide w'; «θ : f ⋆ w ⇒ u»; «θ' : f ⋆ w' ⇒ u»; «β : g ⋆ w ⇒ g ⋆ w'»;
composite_cell w θ = composite_cell w' θ' ⋅ β ⟧ ⟹
∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
text ‹
$$
\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
$$
›
text ‹
The following definition includes the additional axiom ‹T0›, which states that
the ``input leg'' ‹f› is a map.
›
locale tabulation_data_with_T0 =
tabulation_data +
T0: map_in_bicategory V H 𝖺 𝗂 src trg f
begin
abbreviation η where "η ≡ T0.η"
abbreviation ε where "ε ≡ T0.ε"
text ‹
If ‹«ρ : g ⇒ r ⋆ f»› is a 2-cell and ‹f› is a map, then ‹«T0.trnr⇩ε r ρ : g ⋆ f⇧* ⇒ r»›,
where ‹T0.trnr⇩ε r ρ› is the adjoint transpose of ‹ρ›.
We will show (CKS Proposition 1(d)) that if ‹ρ› is a tabulation,
then ‹ψ = T0.trnr⇩ε r ρ› is an isomorphism. However, regardless of whether ‹ρ› is a
tabulation, the mapping ‹ρ ↦ ψ› is injective, and we can recover ‹ρ› by the formula:
‹ρ = (ψ ⋆ f) ⋅ T0.trnr⇩η g (g ⋆ f⇧*)›. The proof requires only ‹T0› and the ``syntactic''
properties of the tabulation data, and in particular does not require the tabulation
conditions ‹T1› and ‹T2›. In case ‹ρ› is in fact a tabulation, then this formula can
be interpreted as expressing that ‹ρ› is obtained by transposing the identity
‹«g ⋆ f⇧* : g ⋆ f⇧* ⇒ g ⋆ f⇧*»› to obtain a 2-cell ‹«T0.trnr⇩η g (g ⋆ f⇧*) : g ⇒ (g ⋆ f⇧*) ⋆ f»›
(which may be regarded as the canonical tabulation of ‹g ⋆ f⇧*›), and then composing
with the isomorphism ‹«ψ ⋆ f : (g ⋆ f⇧*) ⋆ f ⇒ r ⋆ f»› to obtain a tabulation of ‹r›.
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.
›
lemma rep_in_hom [intro]:
shows "«T0.trnr⇩ε r ρ : g ⋆ f⇧* ⇒ r»"
proof (unfold T0.trnr⇩ε_def, intro comp_in_homI)
show "«ρ ⋆ f⇧* : g ⋆ f⇧* ⇒ (r ⋆ f) ⋆ f⇧*»"
using tab_in_hom T0.antipar(1) by auto
show "«𝖺[r, f, f⇧*] : (r ⋆ f) ⋆ f⇧* ⇒ r ⋆ f ⋆ f⇧*»"
using T0.antipar(1-2) by auto
show "«r ⋆ ε : r ⋆ f ⋆ f⇧* ⇒ r ⋆ src r»"
using T0.antipar by auto
show "«𝗋[r] : r ⋆ src r ⇒ r»"
by auto
qed
lemma ρ_in_terms_of_rep:
shows "ρ = (T0.trnr⇩ε r ρ ⋆ f) ⋅ T0.trnr⇩η g (g ⋆ f⇧*)"
proof -
have "(T0.trnr⇩ε r ρ ⋆ f) ⋅ T0.trnr⇩η g (g ⋆ f⇧*) =
(𝗋[r] ⋅ composite_cell f⇧* ε ⋆ f) ⋅ ((g ⋆ f⇧*) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] ⋅ (g ⋆ η) ⋅ 𝗋⇧-⇧1[g]"
unfolding T0.trnr⇩ε_def T0.trnr⇩η_def by simp
text ‹
$$
\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
$$
›
also have "... = (𝗋[r] ⋅ composite_cell f⇧* ε ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] ⋅ (g ⋆ η) ⋅ 𝗋⇧-⇧1[g]"
proof -
have "((g ⋆ f⇧*) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] = 𝖺⇧-⇧1[g, f⇧*, f]"
using comp_cod_arr T0.antipar by simp
thus ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋆ f) ⋅ (composite_cell f⇧* ε ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] ⋅ (g ⋆ η) ⋅ 𝗋⇧-⇧1[g]"
using comp_assoc T0.antipar whisker_right [of "f" "𝗋[r]" "composite_cell f⇧* ε"]
by fastforce
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋆ f) ⋅ ((ρ ⋆ f⇧*) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] ⋅
(g ⋆ η) ⋅ 𝗋⇧-⇧1[g]"
using T0.antipar whisker_right [of "f" "(r ⋆ ε) ⋅ 𝖺[r, f, f⇧*]" "ρ ⋆ f⇧*"] comp_assoc
by fastforce
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ (𝖺[r, f, f⇧*] ⋆ f) ⋅
((ρ ⋆ f⇧*) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] ⋅ (g ⋆ η) ⋅ 𝗋⇧-⇧1[g]"
using T0.antipar whisker_right [of "f" "r ⋆ ε" "𝖺[r, f, f⇧*]"] comp_assoc by fastforce
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ (𝖺[r, f, f⇧*] ⋆ f) ⋅
𝖺⇧-⇧1[r ⋆ f, f⇧*, f] ⋅ (ρ ⋆ f⇧* ⋆ f) ⋅ (g ⋆ η) ⋅ 𝗋⇧-⇧1[g]"
proof -
have "((ρ ⋆ f⇧*) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇧*, f] = 𝖺⇧-⇧1[r ⋆ f, f⇧*, f] ⋅ (ρ ⋆ f⇧* ⋆ f)"
using assoc'_naturality [of ρ "f⇧*" "f"] T0.antipar by simp
thus ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅
(𝖺[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇧*, f] ⋅
((r ⋆ f) ⋆ η) ⋅ (ρ ⋆ src (f)) ⋅ 𝗋⇧-⇧1[g]"
proof -
have "(ρ ⋆ f⇧* ⋆ f) ⋅ (g ⋆ η) = ((r ⋆ f) ⋆ η) ⋅ (ρ ⋆ src (f))"
using comp_arr_dom comp_cod_arr T0.antipar interchange [of ρ "g" "f⇧* ⋆ f" η]
interchange [of "r ⋆ f" ρ η "src (f)"]
by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ (𝖺[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇧*, f] ⋅
((r ⋆ f) ⋆ η) ⋅ 𝗋⇧-⇧1[r ⋆ f] ⋅ ρ"
using runit'_naturality [of ρ] by simp
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅
𝖺⇧-⇧1[r, f ⋆ f⇧*, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ 𝖺[r, f, f⇧* ⋆ f] ⋅
((r ⋆ f) ⋆ η) ⋅ 𝗋⇧-⇧1[r ⋆ f] ⋅ ρ"
proof -
have "(𝖺[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇧*, f] =
𝖺⇧-⇧1[r, f ⋆ f⇧*, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ 𝖺[r, f, f⇧* ⋆ f]"
proof -
have "𝖺⇧-⇧1[r ⋆ f, f⇧*, f] =
(𝖺⇧-⇧1[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇧*, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ 𝖺[r, f, f⇧* ⋆ f]"
using pentagon' [of r "f" "f⇧*" "f"] T0.antipar iso_assoc comp_assoc
invert_side_of_triangle(2)
[of "((𝖺⇧-⇧1[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇧*, f]) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f])"
"𝖺⇧-⇧1[r ⋆ f, f⇧*, f]" "𝖺⇧-⇧1[r, f, f⇧* ⋆ f]"]
by fastforce
hence "(𝖺[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇧*, f] =
((𝖺[r, f, f⇧*] ⋆ f) ⋅ (𝖺⇧-⇧1[r, f, f⇧*] ⋆ f)) ⋅
𝖺⇧-⇧1[r, f ⋆ f⇧*, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ 𝖺[r, f, f⇧* ⋆ f]"
using comp_assoc by simp
also have "... = 𝖺⇧-⇧1[r, f ⋆ f⇧*, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ 𝖺[r, f, f⇧* ⋆ f]"
proof -
have "(𝖺[r, f, f⇧*] ⋆ f) ⋅ (𝖺⇧-⇧1[r, f, f⇧*] ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇧*, f] =
((r ⋆ f ⋆ f⇧*) ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇧*, f]"
using comp_cod_arr comp_assoc iso_assoc comp_arr_inv T0.antipar
whisker_right [of "f" "𝖺[r, f, f⇧*]" "𝖺⇧-⇧1[r, f, f⇧*]"] comp_assoc_assoc'
by simp
also have "... = 𝖺⇧-⇧1[r, f ⋆ f⇧*, 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] ⋆ f) ⋅ 𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ ε ⋆ f) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ (r ⋆ f ⋆ η) ⋅ 𝖺[r, f, src (f)] ⋅ 𝗋⇧-⇧1[r ⋆ f] ⋅ ρ"
proof -
have "((r ⋆ ε) ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇧*, f] = 𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ ε ⋆ f)"
using assoc'_naturality [of r ε "f"] by auto
moreover have "𝖺[r, f, f⇧* ⋆ f] ⋅ ((r ⋆ f) ⋆ η) = (r ⋆ f ⋆ η) ⋅ 𝖺[r, f, src (f)]"
using assoc_naturality [of r "f" η] T0.antipar by auto
ultimately show ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋆ f) ⋅ 𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ (ε ⋆ f) ⋅
𝖺⇧-⇧1[f, f⇧*, f] ⋅ (f ⋆ η)) ⋅ 𝖺[r, f, src (f)] ⋅ 𝗋⇧-⇧1[r ⋆ f] ⋅ ρ"
proof -
have "seq 𝖺⇧-⇧1[f, f⇧*, f] (f ⋆ η)"
using T0.antipar by force
moreover have "seq (ε ⋆ f) (𝖺⇧-⇧1[f, f⇧*, f] ⋅ (f ⋆ η))"
using T0.antipar by fastforce
ultimately have "(r ⋆ ε ⋆ f) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f]) ⋅ (r ⋆ f ⋆ η) =
r ⋆ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇧*, f] ⋅ (f ⋆ η)"
using T0.antipar whisker_left [of r "𝖺⇧-⇧1[f, f⇧*, f]" "f ⋆ η"]
whisker_left [of r "ε ⋆ f" "𝖺⇧-⇧1[f, f⇧*, f] ⋅ (f ⋆ η)"]
by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋆ f) ⋅ 𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f]) ⋅
𝖺[r, f, src (f)] ⋅ 𝗋⇧-⇧1[r ⋆ f] ⋅ ρ"
using T0.triangle_left by simp
also have "... = ((𝗋[r] ⋆ f) ⋅ 𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ 𝗅⇧-⇧1[f])) ⋅
((r ⋆ 𝗋[f]) ⋅ 𝖺[r, f, src (f)] ⋅ 𝗋⇧-⇧1[r ⋆ f]) ⋅ ρ"
using whisker_left [of r "𝗅⇧-⇧1[f]" "𝗋[f]"] comp_assoc by simp
also have "... = ((r ⋆ 𝗅[f]) ⋅ (r ⋆ 𝗅⇧-⇧1[f])) ⋅ (𝗋[r ⋆ f] ⋅ 𝗋⇧-⇧1[r ⋆ f]) ⋅ ρ"
using triangle' [of r "f"] runit_hcomp [of r "f"] comp_assoc by simp
also have "... = ρ"
proof -
have "(r ⋆ 𝗅[f]) ⋅ (r ⋆ 𝗅⇧-⇧1[f]) = r ⋆ f"
using iso_lunit comp_arr_inv' whisker_left [of r "𝗅[f]" "𝗅⇧-⇧1[f]"] by simp
moreover have "(𝗋[r ⋆ f] ⋅ 𝗋⇧-⇧1[r ⋆ f]) = r ⋆ 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 ‹
The following corresponds to what CKS call ``tabulation''; it supposes axiom ‹T0›,
but involves weaker versions of ‹T1› and ‹T2›. I am calling it ``narrow tabulation''.
›
locale narrow_tabulation =
tabulation_data_with_T0 +
assumes T1: "⋀u ω.
⟦ is_left_adjoint u; «ω : dom ω ⇒ r ⋆ u» ⟧ ⟹
∃w θ ν. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧ iso ν ∧
composite_cell w θ ⋅ ν = ω"
and T2: "⋀u w w' θ θ' β.
⟦ is_left_adjoint u; ide w; ide w';
«θ : f ⋆ w ⇒ u»; «θ' : f ⋆ w' ⇒ u»; «β : g ⋆ w ⇒ g ⋆ w'»;
composite_cell w θ = composite_cell w' θ' ⋅ β ⟧ ⟹
∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
text ‹
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.
›
locale uwθ =
tabulation_data +
fixes u :: 'a
and w :: 'a
and θ :: 'a
assumes uwθ: "ide w ∧ «θ : f ⋆ w ⇒ u»"
begin
lemma ide_u:
shows "ide u"
using uwθ by force
lemma u_in_hom [intro]:
shows "«u : src u → src r»"
using uwθ ide_u ide_cod [of θ] hseq_char [of f w]
apply (intro in_hhomI, simp_all)
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θ by auto
lemma w_in_hom [intro]:
shows "«w : src u → src f»" and "«w : w ⇒ w»"
proof -
show "«w : w ⇒ w»"
using ide_w by auto
show "«w : src u → src f»"
proof
show "arr w" using ide_w by simp
show "src w = src u"
using uwθ ide_dom [of θ] 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θ ide_dom [of θ] 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 θ_in_hom [intro]:
shows "«θ : src u → src r»" and "«θ : f ⋆ w ⇒ u»"
proof -
show "«θ : f ⋆ w ⇒ u»"
using uwθ by simp
show "«θ : src u → src r»"
using uwθ hcomp_simps(1-2)
by (metis arrI in_hhomI u_simps(3) vconn_implies_hpar(1-4))
qed
lemma θ_simps [simp]:
shows "arr θ" and "src θ = src u" and "trg θ = src r"
and "dom θ = f ⋆ w" and "cod θ = u"
using θ_in_hom by auto
end
locale uwθω =
uwθ +
fixes ω :: 'a
assumes uwθω: "uwθω u w θ ω"
begin
lemma ω_in_hom [intro]:
shows "«ω : src w → trg r»" and "«ω : dom ω ⇒ r ⋆ u»"
proof -
show "«ω : src w → trg r»"
using uwθω src_cod [of ω] trg_cod [of ω]
apply (elim conjE in_homE)
by simp
show "«ω : dom ω ⇒ r ⋆ u»"
using uwθω by auto
qed
lemma ω_simps [simp]:
shows "arr ω" and "src ω = src w" and "trg ω = trg r"
and "cod ω = r ⋆ u"
using ω_in_hom by auto
end
locale uwθων =
uwθ +
fixes ω :: 'a
and ν :: 'a
assumes uwθων: "uwθων u w θ ω ν"
begin
lemma ν_in_hom [intro]:
shows "«ν : src u → trg r»" and "«ν : dom ω ⇒ g ⋆ w»"
proof -
show "«ν : dom ω ⇒ g ⋆ w»"
using uwθων by auto
show "«ν : src u → trg r»"
proof
show 1: "arr ν"
using uwθων by auto
show "src ν = src u"
proof -
have "src (cod ν) = src u"
using uwθων
by (metis arr_cod hcomp_simps(1) in_homE w_simps(3))
thus ?thesis by simp
qed
show "trg ν = trg r"
proof -
have "trg (cod ν) = trg r"
using uwθων
by (metis arr_cod hcomp_simps(2) in_homE leg1_simps(4))
thus ?thesis by simp
qed
qed
qed
lemma ν_simps [simp]:
shows "iso ν" and "arr ν" and "src ν = src u" and "trg ν = trg r"
and "cod ν = g ⋆ w"
using uwθων ν_in_hom by auto
sublocale uwθω
proof (unfold_locales, intro conjI)
show "ide w"
using uwθων by simp
show "«θ : f ⋆ w ⇒ u»"
using uwθων by simp
have "«(r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν : dom ν ⇒ r ⋆ u»"
using ide_base ide_leg0 ide_w by fastforce
thus "«ω : dom ω ⇒ r ⋆ u»"
using uwθων by auto
qed
end
locale uwθw'θ' =
tabulation_data V H 𝖺 ι src trg r ρ f g +
uwθ: uwθ V H 𝖺 ι src trg r ρ f g u w θ +
uw'θ': uwθ V H 𝖺 ι src trg r ρ f g u w' θ'
for V :: "'a comp" (infixr "⋅" 55)
and H :: "'a ⇒ 'a ⇒ 'a" (infixr "⋆" 53)
and 𝖺 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a" ("𝖺[_, _, _]")
and ι :: "'a ⇒ 'a" ("𝗂[_]")
and src :: "'a ⇒ 'a"
and trg :: "'a ⇒ 'a"
and r :: 'a
and ρ :: 'a
and f :: 'a
and g :: 'a
and u :: 'a
and w :: 'a
and θ :: 'a
and w' :: 'a
and θ' :: 'a
locale uwθw'θ'γ =
uwθw'θ' +
fixes γ :: 'a
assumes γ_in_vhom: "«γ : w ⇒ w'»"
and "θ = θ' ⋅ (f ⋆ γ)"
begin
lemma γ_in_hom [intro]:
shows "«γ : src u → src f»" and "«γ : w ⇒ w'»"
proof -
show "«γ : w ⇒ w'»"
using γ_in_vhom by simp
show "«γ : src u → src f»"
proof
show "arr γ"
using γ_in_vhom by auto
show "src γ = src u"
using γ_in_vhom src_dom [of γ]
apply (elim in_homE) by simp
show "trg γ = src f"
using γ_in_vhom trg_dom [of γ]
apply (elim in_homE) by simp
qed
qed
lemma γ_simps [simp]:
shows "arr γ"
and "src γ = src u" and "trg γ = src f"
and "dom γ = w" and "cod γ = w'"
using γ_in_hom by auto
end
locale uwθw'θ'β =
uwθw'θ' +
fixes β :: 'a
assumes uwθw'θ'β: "uwθw'θ'β u w θ w' θ' β"
begin
lemma β_in_hom [intro]:
shows "«β : src u → trg r»" and "«β : g ⋆ w ⇒ g ⋆ w'»"
proof -
show "«β : g ⋆ w ⇒ g ⋆ w'»"
using uwθw'θ'β by auto
show "«β : src u → trg r»"
using uwθw'θ'β src_dom [of β] trg_dom [of β] hseq_char [of g w]
apply (elim conjE in_homE) by auto
qed
lemma β_simps [simp]:
shows "arr β" and "src β = src u" and "trg β = trg r"
and "dom β = g ⋆ w" and "cod β = g ⋆ w'"
using β_in_hom by auto
end
subsection "Tabulations yield Factorizations"
text ‹
If ‹(f, ρ, g)› is a (wide) tabulation, then ‹f› 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.
›
context tabulation
begin
text ‹
The following is used in order to allow us to apply the coherence theorem
to shortcut proofs of equations between canonical arrows.
›
interpretation E: self_evaluation_map V H 𝖺 𝗂 src trg ..
notation E.eval ("⦃_⦄")
lemma satisfies_T0:
shows "is_left_adjoint f"
proof -
text ‹
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.
›
text ‹
CKS say to first apply ‹T1› with ‹u = src r›, ‹v = r›, and ‹ρ' = r›.
However, ‹«r : r ⇒ r»›, not ‹«r : r ⇒ r ⋆ src r»›, so we have to take ‹ρ' = 𝗋⇧-⇧1[r]›.
›
obtain f⇩a ε ν
where f⇩a: "ide f⇩a ∧ «ε : f ⋆ f⇩a ⇒ src r» ∧ «ν : r ⇒ g ⋆ f⇩a» ∧ iso ν ∧
composite_cell f⇩a ε ⋅ ν = 𝗋⇧-⇧1[r]"
using T1 [of "src r" "𝗋⇧-⇧1[r]"] runit'_in_hom [of r] ide_base comp_assoc by auto
have f⇩a': "composite_cell f⇩a ε ⋅ ν = 𝗋⇧-⇧1[r]"
using f⇩a by simp
have f⇩a: "ide f⇩a ∧ «ε : f ⋆ f⇩a ⇒ src r» ∧ «ν : r ⇒ g ⋆ f⇩a» ∧ iso ν"
using f⇩a by simp
have 1: "src f⇩a = trg f"
using f⇩a f⇩a' comp_assoc
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⇩a = src g"
using f⇩a by force
have ε: "«ε : f ⋆ f⇩a ⇒ trg f» ∧ «ε : trg f → trg f» ∧
arr ε ∧ src ε = trg f ∧ trg ε = trg f ∧ dom ε = f ⋆ f⇩a ∧ cod ε = trg f"
using f⇩a 1 2
by (metis in_hhomI in_homE leg0_simps(3) src_src trg_src vconn_implies_hpar(1-4))
have ν: "«ν : r ⇒ g ⋆ f⇩a» ∧ «ν : trg f → trg g» ∧
arr ν ∧ src ν = trg f ∧ trg ν = trg g ∧ dom ν = r ∧ cod ν = g ⋆ f⇩a"
using f⇩a by force
text ‹
Next, CKS say to apply ‹T2› with ‹w = trg f⇩a = src f›, ‹w' = f⇩a ⋆ f›, ‹u = f›,
to obtain the unit and the adjunction conditions, but they don't say explicitly
what to use for ‹θ›, ‹θ'›, and ‹β›.
We need ‹«θ : f ⋆ w ⇒ u»› and ‹«θ' : f ⋆ w' ⇒ u»›;
\emph{i.e.}~‹«θ : f ⋆ trg f⇩a ⇒ f»› and ‹«θ' : f ⋆ f⇩a ⋆ f ⇒ f»›.
Evidently, we may take ‹θ = ρ[f]› and ‹θ' = 𝗅[f] ⋅ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f]›.
What should be taken for ‹β›? Reconstructing this is a little bit more difficult.
‹T2› requires ‹«β : g ⋆ w ⇒ g ⋆ w'»›, hence ‹«β : g ⋆ trg f⇩a ⇒ g ⋆ f⇩a ⋆ f»›.
We have the isomorphism ‹«ν : r ⇒ g ⋆ f⇩a»› from ‹T1›. Also ‹«ρ : g ⇒ r ⋆ f»›.
So ‹«𝖺[g, f⇩a, f] ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g] : g ⋆ trg f⇩a ⇒ g ⋆ f⇩a ⋆ f»›,
suggesting that we take ‹β = 𝖺[g, f⇩a, f] ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g]›.
Now, to apply ‹T2› we need to satisfy the equation:
\[
‹(r ⋆ θ) ⋅ 𝖺[r, f, trg f⇩a] ⋅ (ρ ⋆ trg f⇩a ) =
(r ⋆ θ') ⋅ 𝖺[r, f, f⇩a ⋆ f] ⋅ (ρ ⋆ f⇩a ⋆ f) ⋅ β›;
\]
that is, with our choice of ‹θ›, ‹θ'›, and ‹β›:
‹(r ⋆ 𝗋[f]) ⋅ 𝖺[r, f, trg f⇩a] ⋅ (ρ ⋆ trg f⇩a ) =
(r ⋆ 𝗅[f] ⋅ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f]) ⋅ 𝖺[r, f, f⇩a ⋆ f] ⋅ (ρ ⋅ (f⇩a ⋆ f)) ⋅
𝖺[g, f⇩a, f] ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g]›.
It is not too difficult to get the idea of showing that the left-hand side
is equal to ‹ρ ⋅ 𝗋[g]› (note that ‹trg f⇩a = src f = src g]› and ‹trg f = src r›),
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:
\[
‹𝗋⇧-⇧1[r] = (r ⋆ ε) ⋅ 𝖺[r, f, f⇩a] ⋅ (ρ ⋆ f⇩a ) ⋅ ν›.
\]
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.
›
let ?β = "𝖺[g, f⇩a, f] ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g]"
let ?θ = "𝗋[f]"
let ?θ' = "𝗅[f] ⋅ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f]"
have β: "«?β : g ⋆ src g ⇒ g ⋆ f⇩a ⋆ f» ∧ «?β : src f → trg g» ∧
src ?β = src g ∧ trg ?β = trg g ∧ dom ?β = g ⋆ src g ∧ cod ?β = g ⋆ f⇩a ⋆ f"
proof -
have 3: "«?β : g ⋆ src g ⇒ g ⋆ f⇩a ⋆ f»"
using f⇩a 1 2 by fastforce
moreover have "«?β : src f → trg g»"
using 1 2 3 f⇩a by auto
ultimately show ?thesis
by (auto simp add: in_hhom_def)
qed
have θ': "«?θ' : f ⋆ f⇩a ⋆ f ⇒ f»"
using f⇩a 1 2 ε by fastforce
have A: "composite_cell (trg f⇩a) 𝗋[f] = composite_cell (f⇩a ⋆ f) ?θ' ⋅ ?β"
proof -
have "composite_cell (trg f⇩a) 𝗋[f] = ρ ⋅ 𝗋[g]"
using 2 runit_hcomp runit_naturality [of ρ] comp_assoc by simp
also have "... = composite_cell (f⇩a ⋆ f) ?θ' ⋅ ?β"
proof -
have "composite_cell (f⇩a ⋆ f) ?θ' ⋅ ?β =
(composite_cell (f⇩a ⋆ f) ?θ' ⋅ 𝖺[g, f⇩a, f]) ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g]"
using comp_assoc by simp
also have "... = ρ ⋅ 𝗋[g]"
proof -
have "(composite_cell (f⇩a ⋆ f) ?θ' ⋅ 𝖺[g, f⇩a, f]) ⋅ (ν ⋆ f) = r ⋆ f"
proof -
have "(composite_cell (f⇩a ⋆ f) ?θ' ⋅ 𝖺[g, f⇩a, f]) ⋅ (ν ⋆ f) =
𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇩a] ⋅ (ρ ⋆ f⇩a) ⋅ ν ⋆ f"
proof -
have "(composite_cell (f⇩a ⋆ f) ?θ' ⋅ 𝖺[g, f⇩a, f]) ⋅ (ν ⋆ f) =
(r ⋆ 𝗅[f]) ⋅ (r ⋆ ε ⋆ f) ⋅
composite_cell (f⇩a ⋆ f) 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (𝖺[g, f⇩a, f] ⋅ (ν ⋆ f))"
using f⇩a 1 2 ε whisker_left comp_assoc by auto
also have "... = (𝗋[r] ⋆ f) ⋅ 𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ ε ⋆ f) ⋅
composite_cell (f⇩a ⋆ f) 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (𝖺[g, f⇩a, f] ⋅ (ν ⋆ f))"
using f⇩a 1 2 comp_assoc by (simp add: triangle')
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇩a, f] ⋅
composite_cell (f⇩a ⋆ f) 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (𝖺[g, f⇩a, f] ⋅ (ν ⋆ f))"
proof -
have "𝖺⇧-⇧1[r, src r, f] ⋅ (r ⋆ ε ⋆ f) = ((r ⋆ ε) ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇩a, f]"
using f⇩a ε assoc'_naturality [of r ε f] by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅
(𝖺[r, f, f⇩a] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇩a, f] ⋅ (ρ ⋆ f⇩a ⋆ f) ⋅
𝖺[g, f⇩a, f] ⋅ (ν ⋆ f)"
proof -
have "(𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ 𝖺⇧-⇧1[r, f ⋆ f⇩a, f] ⋅
composite_cell (f⇩a ⋆ f) 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (𝖺[g, f⇩a, f] ⋅ (ν ⋆ f)) =
(𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅
(𝖺⇧-⇧1[r, f ⋆ f⇩a, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇩a, f]) ⋅ 𝖺[r, f, f⇩a ⋆ f]) ⋅
(ρ ⋆ f⇩a ⋆ f) ⋅ 𝖺[g, f⇩a, f] ⋅ (ν ⋆ f)"
by (simp add: comp_assoc)
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅
((𝖺[r, f, f⇩a] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇩a, f]) ⋅
(ρ ⋆ f⇩a ⋆ f) ⋅ 𝖺[g, f⇩a, f] ⋅ (ν ⋆ f)"
proof -
have "𝖺⇧-⇧1[r, f ⋆ f⇩a, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇩a, f]) ⋅ 𝖺[r, f, f⇩a ⋆ f] =
(𝖺[r, f, f⇩a] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇩a, f]"
proof -
have "𝖺⇧-⇧1[r, f ⋆ f⇩a, f] ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇩a, f]) ⋅ 𝖺[r, f, f⇩a ⋆ f] =
⦃❙𝖺⇧-⇧1❙[❙⟨r❙⟩, ❙⟨f❙⟩ ❙⋆ ❙⟨f⇩a❙⟩, ❙⟨f❙⟩❙] ❙⋅ (❙⟨r❙⟩ ❙⋆ ❙𝖺⇧-⇧1❙[❙⟨f❙⟩, ❙⟨f⇩a❙⟩, ❙⟨f❙⟩❙]) ❙⋅
❙𝖺❙[❙⟨r❙⟩, ❙⟨f❙⟩, ❙⟨f⇩a❙⟩ ❙⋆ ❙⟨f❙⟩❙]⦄"
using f⇩a 1 2 𝖺'_def α_def assoc'_eq_inv_assoc by auto
also have "... = ⦃(❙𝖺❙[❙⟨r❙⟩, ❙⟨f❙⟩, ❙⟨f⇩a❙⟩❙] ❙⋆ ❙⟨f❙⟩) ❙⋅ ❙𝖺⇧-⇧1❙[❙⟨r❙⟩ ❙⋆ ❙⟨f❙⟩, ❙⟨f⇩a❙⟩, ❙⟨f❙⟩❙]⦄"
using f⇩a 1 2 by (intro E.eval_eqI, auto)
also have "... = (𝖺[r, f, f⇩a] ⋆ f) ⋅ 𝖺⇧-⇧1[r ⋆ f, f⇩a, f]"
using f⇩a 1 2 𝖺'_def α_def assoc'_eq_inv_assoc by auto
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ (𝖺[r, f, f⇩a] ⋆ f) ⋅
𝖺⇧-⇧1[r ⋆ f, f⇩a, f] ⋅ (ρ ⋆ f⇩a ⋆ f) ⋅ 𝖺[g, f⇩a, f] ⋅ (ν ⋆ f)"
by (simp add: comp_assoc)
finally show ?thesis by blast
qed
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅
(𝖺[r, f, f⇩a] ⋆ f) ⋅ ((ρ ⋆ f⇩a) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇩a, f] ⋅
𝖺[g, f⇩a, f] ⋅ (ν ⋆ f)"
proof -
have "𝖺⇧-⇧1[r ⋆ f, f⇩a, f] ⋅ (ρ ⋆ f⇩a ⋆ f) = ((ρ ⋆ f⇩a) ⋆ f) ⋅ 𝖺⇧-⇧1[g, f⇩a, f]"
using f⇩a 1 2 assoc'_naturality [of ρ f⇩a f] by auto
thus ?thesis
by (metis comp_assoc)
qed
also have "... = (𝗋[r] ⋆ f) ⋅ ((r ⋆ ε) ⋆ f) ⋅ (𝖺[r, f, f⇩a] ⋆ f) ⋅
((ρ ⋆ f⇩a) ⋆ f) ⋅ (ν ⋆ f)"
proof -
have "𝖺⇧-⇧1[g, f⇩a, f] ⋅ 𝖺[g, f⇩a, f] = (g ⋆ f⇩a) ⋆ f"
using f⇩a 1 2 comp_assoc_assoc' by auto
moreover have "((g ⋆ f⇩a) ⋆ f) ⋅ (ν ⋆ f) = ν ⋆ f"
by (simp add: ν comp_cod_arr)
ultimately show ?thesis
using comp_assoc by metis
qed
also have "... = (𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇩a] ⋅ (ρ ⋆ f⇩a) ⋅ ν) ⋆ f"
proof -
have "arr (𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇩a] ⋅ (ρ ⋆ f⇩a) ⋅ ν)"
using f⇩a' comp_assoc by auto
thus ?thesis
using whisker_right by fastforce
qed
finally show ?thesis by blast
qed
also have "... = (𝗋[r] ⋅ 𝗋⇧-⇧1[r]) ⋆ f"
using f⇩a' comp_assoc by simp
also have "... = r ⋆ 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 η where η: "«η : trg f⇩a ⇒ f⇩a ⋆ f» ∧ ?β = g ⋆ η ∧
(𝗅[f] ⋅ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f]) ⋅ (f ⋆ η) = 𝗋[f]"
using β θ' A 1 2 f⇩a runit_in_hom ide_leg0 ide_hcomp src.preserves_ide
T2 [of "trg f⇩a" "f⇩a ⋆ f" "𝗋[f]" f "𝗅[f] ⋅ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f]" ?β] comp_assoc
leg1_simps(3)
by metis
have η': "?β = g ⋆ η ∧ (𝗅[f] ⋅ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f]) ⋅ (f ⋆ η) = 𝗋[f]"
using η by simp
have η: "«η : trg f⇩a ⇒ f⇩a ⋆ f» ∧ «η : src f → src f» ∧
arr η ∧ src η = src f ∧ trg η = src f ∧ dom η = trg f⇩a ∧ cod η = f⇩a ⋆ f"
using η β 2 by force
have "adjunction_in_bicategory V H 𝖺 𝗂 src trg f f⇩a η ε"
proof
show "ide f" using ide_leg0 by simp
show "ide f⇩a" using f⇩a by blast
show η_in_hom: "«η : src f ⇒ f⇩a ⋆ f»"
using η 2 by simp
show ε_in_hom: "«ε : f ⋆ f⇩a ⇒ src f⇩a»"
using f⇩a 1 by simp
show *: "(ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (f ⋆ η) = 𝗅⇧-⇧1[f] ⋅ 𝗋[f]"
using ide_leg0 iso_lunit invert_side_of_triangle(1) η' comp_assoc by auto
text ‹
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 ‹T2› again, this time with the following:
\[\begin{array}{l}
‹w = src f ⋆ f⇩a›,\\
‹θ = (ε ⋆ ε) ⋅ 𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (f ⋆ η ⋆ f⇩a)›,\\
‹w' = f⇩a ⋆ trg›,\\
‹θ' = ε ⋆ trg f›,\\
‹β = g ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]›
\end{array}\]
Then the conditions for ‹γ› are satisfied by both
‹𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]› and ‹(f⇩a ⋆ ε) ⋅ 𝖺[f⇩a, f, f⇩a] ⋅ (η ⋆ f⇩a)› so they are equal,
as required.
›
show "(f⇩a ⋆ ε) ⋅ 𝖺[f⇩a, f, f⇩a] ⋅ (η ⋆ f⇩a) = 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]"
proof -
let ?u = "trg f ⋆ trg f"
let ?w = "src f ⋆ f⇩a"
let ?w' = "f⇩a ⋆ trg f"
let ?θ = "(ε ⋆ ε) ⋅ 𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (f ⋆ η ⋆ f⇩a)"
let ?θ' = "(ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, trg f]"
let ?β = "g ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]"
let ?γ = "𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]"
let ?γ' = "(f⇩a ⋆ ε) ⋅ 𝖺[f⇩a, f, f⇩a] ⋅ (η ⋆ f⇩a)"
have θ_eq': "?θ = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅ (𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, src f, f⇩a]"
proof -
have "?θ = (trg f ⋆ ε) ⋅ (ε ⋆ f ⋆ f⇩a) ⋅
(𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a])) ⋅ (f ⋆ η ⋆ f⇩a)"
using interchange [of "trg f" ε ε "f ⋆ f⇩a"] comp_arr_dom comp_cod_arr comp_assoc
by (simp add: ε)
also have "... = (trg f ⋆ ε) ⋅ (ε ⋆ f ⋆ f⇩a) ⋅
(𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]) ⋅
(f ⋆ η ⋆ f⇩a)"
proof -
have "𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) =
𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]"
proof -
have "(𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ ((𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a])) ⋅
(f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a]) =
𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]"
using 1 2 ‹ide f⇩a› ide_leg0 iso_assoc
invert_side_of_triangle(1)
[of "((𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]) ⋅ (f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a])"
"𝖺⇧-⇧1[f ⋆ f⇩a, f, f⇩a]" "𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]"]
pentagon' comp_assoc by auto
hence "(𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ ((𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a])) =
𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a])"
using 1 2 ‹ide f⇩a›
invert_side_of_triangle(2)
[of "𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]" "𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ ((𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a])"
"f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a]"]
by auto
thus ?thesis
using comp_assoc by simp
qed
thus ?thesis by simp
qed
also have "... = (trg f ⋆ ε) ⋅ ((ε ⋆ f ⋆ f⇩a) ⋅ 𝖺[f ⋆ f⇩a, f, f⇩a]) ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a] ⋅ (f ⋆ η ⋆ f⇩a)"
using comp_assoc by simp
also have "... = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅
((ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (f ⋆ η) ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, src f, f⇩a]"
proof -
have "((ε ⋆ f ⋆ f⇩a) ⋅ 𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]) ⋅ (f ⋆ η ⋆ f⇩a) =
(𝖺[trg f, f, f⇩a] ⋅ ((ε ⋆ f) ⋆ f⇩a)) ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅
((f ⋆ η) ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, src f, f⇩a]"
using assoc_naturality [of ε f f⇩a] assoc'_naturality [of f η f⇩a]
by (simp add: 2 ε η ‹ide f⇩a› comp_assoc)
also have "... = 𝖺[trg f, f, f⇩a] ⋅
(((ε ⋆ f) ⋆ f⇩a) ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ ((f ⋆ η) ⋆ f⇩a)) ⋅
𝖺⇧-⇧1[f, src f, f⇩a]"
using comp_assoc by simp
also have "... = 𝖺[trg f, f, f⇩a] ⋅
((ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (f ⋆ η) ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, src f, f⇩a]"
using η' comp_assoc whisker_right ‹ide f⇩a› null_is_zero(2) ide_leg0 ext
runit_simps(1)
by metis
finally show ?thesis
using comp_assoc by simp
qed
also have "... = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅ (𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, src f, f⇩a]"
using * by simp
finally show ?thesis by simp
qed
have θ_eq: "?θ = (ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, src f⇩a] ⋅ (f ⋆ ?γ)"
proof -
have "?θ = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅ (𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, src f, f⇩a]"
using θ_eq' by simp
also have "... =
(trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅ (𝗅⇧-⇧1[f] ⋆ f⇩a) ⋅ (𝗋[f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, src f, f⇩a]"
using ‹ide f⇩a› whisker_right comp_assoc by auto
also have "... = (trg f ⋆ ε) ⋅ ((𝖺[trg f, f, f⇩a] ⋅ (𝖺⇧-⇧1[trg f, f, f⇩a]) ⋅ 𝗅⇧-⇧1[f ⋆ f⇩a])) ⋅
(f ⋆ 𝗅[f⇩a])"
using 2 ‹ide f⇩a› lunit_hcomp [of f f⇩a] invert_side_of_triangle(2) triangle'
comp_assoc
by auto
also have "... = (trg f ⋆ ε) ⋅ 𝗅⇧-⇧1[f ⋆ f⇩a] ⋅ (f ⋆ 𝗅[f⇩a])"
using f⇩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 "... = 𝗅⇧-⇧1[trg f] ⋅ ε ⋅ (f ⋆ 𝗅[f⇩a])"
using ε lunit'_naturality comp_assoc by metis
also have "... = 𝗋⇧-⇧1[trg f] ⋅ ε ⋅ (f ⋆ 𝗅[f⇩a])"
using unitor_coincidence by simp
also have "... = (ε ⋆ trg f) ⋅ 𝗋⇧-⇧1[f ⋆ f⇩a] ⋅ (f ⋆ 𝗅[f⇩a])"
using ε runit'_naturality comp_assoc by metis
also have "... = (ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, src f⇩a] ⋅ (f ⋆ 𝗋⇧-⇧1[f⇩a]) ⋅ (f ⋆ 𝗅[f⇩a])"
using 2 ‹ide f⇩a› runit_hcomp(2) comp_assoc by auto
also have "... = (ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, src f⇩a] ⋅ (f ⋆ ?γ)"
using 2 ‹ide f⇩a› whisker_left by simp
finally show ?thesis by simp
qed
have θ: "«?θ : f ⋆ ?w ⇒ ?u»"
using 1 2 ‹ide f⇩a› η_in_hom ε by fastforce
have θ': "«?θ' : f ⋆ ?w' ⇒ ?u»"
using f⇩a 1 2 ε by auto
have ww': "ide ?w ∧ ide ?w'"
by (simp add: 1 2 ‹ide f⇩a›)
have "∃!γ. «γ : ?w ⇒ ?w'» ∧ ?β = g ⋆ γ ∧ ?θ = ?θ' ⋅ (f ⋆ γ)"
proof -
have "«?β : g ⋆ ?w ⇒ g ⋆ ?w'»"
using ‹ide f⇩a› 1 2 by auto
moreover have "composite_cell ?w ?θ = composite_cell ?w' ?θ' ⋅ ?β"
proof -
have "composite_cell ?w' ?θ' ⋅ ?β =
composite_cell ?w ((ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, src f⇩a] ⋅ (f ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]))"
proof -
have "𝖺[r, f, f⇩a ⋆ trg f] ⋅ (ρ ⋆ f⇩a ⋆ trg f) ⋅ (g ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]) =
composite_cell ?w (f ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a])"
proof -
have "𝖺[r, f, f⇩a ⋆ trg f] ⋅ (ρ ⋆ f⇩a ⋆ trg f) ⋅ (g ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]) =
(𝖺[r, f, f⇩a ⋆ trg f] ⋅ ((r ⋆ f) ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a])) ⋅ (ρ ⋆ src f ⋆ f⇩a)"
proof -
have "(ρ ⋆ f⇩a ⋆ trg f) ⋅ (g ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]) = ρ ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]"
using interchange [of ρ g "f⇩a ⋆ trg f" "𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]"]
comp_arr_dom comp_cod_arr 1 2 ‹ide f⇩a›
by simp
also have "... = ((r ⋆ f) ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]) ⋅ (ρ ⋆ src f ⋆ f⇩a)"
proof -
have "seq (f⇩a ⋆ trg f) (𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a])"
using f⇩a 1 2 ww' by auto
thus ?thesis
using interchange comp_arr_dom comp_cod_arr 1 2 ‹ide f⇩a›
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 ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a])"
using assoc_naturality [of r f "𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]"] 1 2 ‹ide f⇩a› comp_assoc by simp
finally show ?thesis by simp
qed
hence "composite_cell ?w' ?θ' ⋅ ?β =
((r ⋆ (ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, trg f]) ⋅ (r ⋆ f ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a])) ⋅
𝖺[r, f, src f ⋆ f⇩a] ⋅ (ρ ⋆ src f ⋆ f⇩a)"
using comp_assoc by simp
also have
"... = composite_cell ?w (((ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, trg f]) ⋅ (f ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]))"
using whisker_left 1 2 ‹ide f⇩a› ide_base
by (metis ‹«(ε ⋆ ε) ⋅ 𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (f ⋆ η ⋆ f⇩a) :
f ⋆ src f ⋆ f⇩a ⇒ trg f ⋆ trg f»›
θ_eq arrI comp_assoc)
finally show ?thesis
using comp_assoc by (simp add: "1")
qed
also have "... = composite_cell ?w ?θ"
using θ_eq by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using ww' θ θ' T2 [of ?w ?w' ?θ ?u ?θ' ?β] comp_assoc by metis
qed
moreover have "«?γ : ?w ⇒ ?w'» ∧ ?β = g ⋆ ?γ ∧ ?θ = ?θ' ⋅ (f ⋆ ?γ)"
using 1 2 ‹ide f⇩a› θ_eq comp_assoc by auto
moreover have "«?γ' : ?w ⇒ ?w'» ∧ ?β = g ⋆ ?γ' ∧ ?θ = ?θ' ⋅ (f ⋆ ?γ')"
proof (intro conjI)
show "«?γ' : ?w ⇒ ?w'»"
using 1 2 f⇩a η_in_hom ε_in_hom by fastforce
show "?β = g ⋆ ?γ'"
text ‹
This equation is not immediate.
To show it, we have to recall the properties from the construction of ‹ε› and ‹η›.
Use the property of ‹η› to replace ‹g ⋆ η ⋆ f⇩a› by a 2-cell involving
‹ε›, ‹ρ›, and ‹ν›.
Use the property ‹(r ⋆ ε) ⋅ (ρ ⋆ f⇩a) ⋅ ν = 𝗋[r]› from the construction of ‹ε› to
eliminate ‹ε› and ‹ρ› in favor of inv ‹ν› and canonical isomorphisms.
Cancelling ‹ν› and inv ‹ν› leaves the canonical 2-cell ‹g ⋆ 𝗋⇧-⇧1[f⇩a] ⋅ 𝗅[f⇩a]›.
›
proof -
have "g ⋆ ?γ' = (g ⋆ f⇩a ⋆ ε) ⋅ (g ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (g ⋆ η ⋆ f⇩a)"
using 1 2 ‹ide f⇩a› ε η whisker_left
by (metis ‹«?γ' : ?w ⇒ ?w'»› arrI ide_leg1 seqE)
also have "... = (g ⋆ f⇩a ⋆ ε) ⋅ (g ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (g ⋆ η ⋆ f⇩a) ⋅
𝖺[g, src f, f⇩a] ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using 1 2 ‹ide f⇩a› η comp_arr_dom hseq_char comp_assoc_assoc'
by simp
also have "... = (g ⋆ f⇩a ⋆ ε) ⋅ (g ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ ((g ⋆ η ⋆ f⇩a) ⋅
𝖺[g, src f, f⇩a]) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using comp_assoc by simp
also have "... = (g ⋆ f⇩a ⋆ ε) ⋅ (g ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅
(𝖺[g, f⇩a ⋆ f, f⇩a] ⋅ ((g ⋆ η) ⋆ f⇩a)) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using 1 2 ‹ide f⇩a› ε η assoc_naturality [of g η f⇩a] by simp
also have "... = (g ⋆ f⇩a ⋆ ε) ⋅ (g ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ 𝖺[g, f⇩a ⋆ f, f⇩a] ⋅
(𝖺[g, f⇩a, f] ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using η' comp_assoc by simp
also have "... = (g ⋆ f⇩a ⋆ ε) ⋅
((g ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ 𝖺[g, f⇩a ⋆ f, f⇩a] ⋅ (𝖺[g, f⇩a, f] ⋆ f⇩a)) ⋅
((ν ⋆ f) ⋆ f⇩a) ⋅ (ρ ⋆ f⇩a) ⋅ (𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
proof -
have "𝖺[g, f⇩a, f] ⋅ (ν ⋆ f) ⋅ ρ ⋅ 𝗋[g] ⋆ f⇩a =
(𝖺[g, f⇩a, f] ⋆ f⇩a) ⋅ ((ν ⋆ f) ⋆ f⇩a) ⋅ (ρ ⋆ f⇩a) ⋅ (𝗋[g] ⋆ f⇩a)"
using 1 2 ‹ide f⇩a› β ε η whisker_right by (metis arrI seqE)
thus ?thesis
using comp_assoc by simp
qed
also have "... = ((g ⋆ f⇩a ⋆ ε) ⋅
𝖺[g, f⇩a, f ⋆ f⇩a]) ⋅ (𝖺[g ⋆ f⇩a, f, f⇩a] ⋅
((ν ⋆ f) ⋆ f⇩a)) ⋅ (ρ ⋆ f⇩a) ⋅ (𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using 1 2 ‹ide f⇩a› pentagon comp_assoc by simp
also have "... = (𝖺[g, f⇩a, trg f] ⋅ ((g ⋆ f⇩a) ⋆ ε)) ⋅
((ν ⋆ f ⋆ f⇩a) ⋅ 𝖺[r, f, f⇩a]) ⋅
(ρ ⋆ f⇩a) ⋅ (𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using 1 2 ‹ide f⇩a› assoc_naturality [of g f⇩a ε] assoc_naturality [of ν f f⇩a]
by (simp add: ε ν)
also have "... = 𝖺[g, f⇩a, trg f] ⋅ (((g ⋆ f⇩a) ⋆ ε) ⋅ (ν ⋆ f ⋆ f⇩a)) ⋅ 𝖺[r, f, f⇩a] ⋅
(ρ ⋆ f⇩a) ⋅ (𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using 1 2 ‹ide f⇩a› assoc_naturality [of g f⇩a ε] assoc_naturality [of ν f f⇩a]
comp_assoc
by simp
also have "... = 𝖺[g, f⇩a, trg f] ⋅ (ν ⋆ trg f) ⋅
composite_cell f⇩a ε ⋅
(𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
proof -
have "((g ⋆ f⇩a) ⋆ ε) ⋅ (ν ⋆ f ⋆ f⇩a) = ν ⋆ ε"
using 1 2 ‹ide f⇩a› ν ε interchange [of "g ⋆ f⇩a" ν ε "f ⋆ f⇩a"]
comp_arr_dom comp_cod_arr
by simp
also have "... = (ν ⋆ trg f) ⋅ (r ⋆ ε)"
using ‹ide f⇩a› ν ε interchange [of ν r "trg f" ε] comp_arr_dom comp_cod_arr
by simp
finally show ?thesis
using comp_assoc by simp
qed
also have "... = 𝖺[g, f⇩a, trg f] ⋅ ((((ν ⋆ trg f) ⋅ 𝗋⇧-⇧1[r]) ⋅ inv ν) ⋅ (𝗋[g] ⋆ f⇩a)) ⋅
𝖺⇧-⇧1[g, src f, f⇩a]"
using ide_base f⇩a' comp_assoc f⇩a runit'_simps(1) invert_side_of_triangle(2)
comp_assoc
by presburger
also have "... = 𝖺[g, f⇩a, trg f] ⋅ 𝗋⇧-⇧1[g ⋆ f⇩a] ⋅ (𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
proof -
have "((ν ⋆ trg f) ⋅ 𝗋⇧-⇧1[r]) ⋅ inv ν = 𝗋⇧-⇧1[g ⋆ f⇩a]"
using 1 2 ‹ide f⇩a› ν ide_base runit'_naturality [of ν] comp_arr_dom
by (metis f⇩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 "... = ((𝖺[g, f⇩a, trg f] ⋅ 𝖺⇧-⇧1[g, f⇩a, src f⇩a]) ⋅
(g ⋆ 𝗋⇧-⇧1[f⇩a])) ⋅ (𝗋[g] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[g, src f, f⇩a]"
using f⇩a "2" runit_hcomp ‹ide f⇩a› comp_assoc by simp
also have "... = (g ⋆ 𝗋⇧-⇧1[f⇩a]) ⋅ (g ⋆ 𝗅[f⇩a])"
using 1 2 comp_cod_arr ‹ide f⇩a› comp_assoc_assoc' triangle' by simp
also have "... = ?β"
using 2 ‹ide f⇩a› whisker_left by simp
finally show ?thesis by simp
qed
show "?θ = ?θ' ⋅ (f ⋆ ?γ')"
proof -
have "((ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, trg f]) ⋅ (f ⋆ (f⇩a ⋆ ε) ⋅ 𝖺[f⇩a, f, f⇩a] ⋅ (η ⋆ f⇩a)) =
((ε ⋆ trg f) ⋅ 𝖺⇧-⇧1[f, f⇩a, trg f]) ⋅ (f ⋆ f⇩a ⋆ ε) ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (f ⋆ η ⋆ f⇩a)"
using 1 2 ‹ide f⇩a› ε η whisker_left
by (metis ‹«(f⇩a ⋆ ε) ⋅ 𝖺[f⇩a, f, f⇩a] ⋅ (η ⋆ f⇩a) : src f ⋆ f⇩a ⇒ f⇩a ⋆ trg f»›
arrI ide_leg0 seqE)
also have
"... = (ε ⋆ trg f) ⋅ (𝖺⇧-⇧1[f, f⇩a, trg f] ⋅ (f ⋆ f⇩a ⋆ ε)) ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅ (f ⋆ η ⋆ f⇩a)"
using comp_assoc by simp
also have "... = ((ε ⋆ trg f) ⋅ ((f ⋆ f⇩a) ⋆ ε)) ⋅
𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) ⋅
(f ⋆ η ⋆ f⇩a)"
using 1 2 ‹ide f⇩a› ε assoc'_naturality [of f f⇩a ε] comp_assoc by simp
also have "... = (trg f ⋆ ε) ⋅ (ε ⋆ f ⋆ f⇩a) ⋅
(𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a])) ⋅
(f ⋆ η ⋆ f⇩a)"
using 1 2 ‹ide f⇩a› ε interchange [of ε "f ⋆ f⇩a" "trg f" ε]
interchange [of "trg f" ε ε "f ⋆ f⇩a"] comp_arr_dom comp_cod_arr comp_assoc
by simp
also have "... = (trg f ⋆ ε) ⋅ ((ε ⋆ f ⋆ f⇩a) ⋅
(𝖺[f ⋆ f⇩a, f, f⇩a]) ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ (𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]) ⋅
(f ⋆ η ⋆ f⇩a))"
proof -
have "𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a] ⋅ (f ⋆ 𝖺[f⇩a, f, f⇩a]) =
𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]"
proof -
have A: "(𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a] ⋅ (f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a]) =
𝖺⇧-⇧1[f ⋆ f⇩a, f, f⇩a] ⋅ 𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]"
using 1 2 ‹ide f⇩a› pentagon' comp_assoc by fastforce
hence B: "𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a] ⋅
(f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a]) =
𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]"
using A 1 2 ‹ide f⇩a›
invert_side_of_triangle(1)
[of "(𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a] ⋅ (f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a])"
"𝖺⇧-⇧1[f ⋆ f⇩a, f, f⇩a]" "𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]"]
by auto
show ?thesis
proof -
have C: "iso (f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a])"
using 1 2 ‹ide f⇩a› by simp
moreover have "inv (f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a]) = f ⋆ 𝖺[f⇩a, f, f⇩a]"
using C 1 2 ‹ide f⇩a› by fastforce
ultimately show ?thesis
using B 1 2 ‹ide f⇩a› comp_assoc
invert_side_of_triangle(2)
[of "𝖺⇧-⇧1[f, f⇩a, f ⋆ f⇩a]"
"𝖺[f ⋆ f⇩a, f, f⇩a] ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, f⇩a ⋆ f, f⇩a]"
"f ⋆ 𝖺⇧-⇧1[f⇩a, f, f⇩a]"]
by simp
qed
qed
thus ?thesis
using comp_assoc by simp
qed
also have "... = (trg f ⋆ ε) ⋅ (𝖺[trg f, f, f⇩a] ⋅
((ε ⋆ f) ⋆ f⇩a)) ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ ((f ⋆ η) ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, src f, f⇩a]"
using 1 2 ‹ide f⇩a› ‹ide f› η ε assoc_naturality [of ε f f⇩a]
assoc'_naturality [of f η f⇩a] comp_assoc
by simp
also have "... = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅
(((ε ⋆ f) ⋆ f⇩a) ⋅ (𝖺⇧-⇧1[f, f⇩a, f] ⋆ f⇩a) ⋅ ((f ⋆ η) ⋆ f⇩a)) ⋅
𝖺⇧-⇧1[f, src f, f⇩a]"
using comp_assoc by simp
also have "... = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅
((ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇩a, f] ⋅ (f ⋆ η) ⋆ f⇩a) ⋅
𝖺⇧-⇧1[f, src f, f⇩a]"
using 1 2 ‹ide f⇩a› ‹ide f› η ε whisker_right
by (metis (full_types) * θ θ_eq' arrI hseqE seqE)
also have "... = (trg f ⋆ ε) ⋅ 𝖺[trg f, f, f⇩a] ⋅ (𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ f⇩a) ⋅ 𝖺⇧-⇧1[f, src f, f⇩a]"
using * by simp
also have "... = ?θ"
using θ_eq' by simp
finally show ?thesis by simp
qed
qed
ultimately show "?γ' = ?γ" 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 ‹
A tabulation ‹(f, ρ, g)› of ‹r› yields an isomorphism ‹«ψ : g ⋆ f⇧* ⇒ r»›
via adjoint transpose.
The proof requires ‹T0›, in order to obtain ‹ψ› as the transpose of ‹«ρ : g ⇒ r ⋆ f»›.
However, it uses only the weaker versions of ‹T1› and ‹T2›.
›
context narrow_tabulation
begin
interpretation E: self_evaluation_map V H 𝖺 𝗂 src trg ..
notation E.eval ("⦃_⦄")
text ‹
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 ‹T1› that there is some 1-cell ‹f⇩a› and isomorphism ‹ψ›
such that ‹«ψ : f ⋆ f⇩a ⇒ r»› (this was already part of the proof that a tabulation
satisfies ‹T0›). The more difficult content in the present result is that we may
actually take ‹f⇩a› to be the left adjoint ‹f⇧*› of ‹f›.
›
lemma yields_isomorphic_representation:
shows "«T0.trnr⇩ε r ρ : g ⋆ f⇧* ⇒ r»" and "iso (T0.trnr⇩ε r ρ)"
proof -
text ‹
As stated in CKS, the first step of the proof is:
\begin{quotation}
``Apply ‹T1› with ‹X = A›, ‹u = 1⇩A›, ‹v = r›, ‹ω = 1⇩R›, to obtain ‹f'›, ‹θ': ff' ⇒ 1⇩A›,
‹ν : r ≃ g f'› with ‹1⇩R = (rθ')(ρf')ν›.''
\end{quotation}
In our nomenclature: ‹X = trg f›, ‹u = trg f›, ‹v = r›, but ‹ω = src f›
does not make any sense, since we need ‹«ω : v ⇒ r ⋆ u»›. We have to take ‹ω = 𝗋⇧-⇧1[r]›.
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:
\[
‹𝗋⇧-⇧1[r] = (r ⋆ θ') ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν›,
\]
which has ‹𝗋⇧-⇧1[r]› on the left-hand side, rather than ‹1⇩R›, as in CKS.
Also, we have inserted the omitted associativity.
›
obtain w θ' ν where wθ'ν: "ide w ∧ «θ' : f ⋆ w ⇒ src r» ∧ «ν : r ⇒ g ⋆ w» ∧ iso ν ∧
composite_cell w θ' ⋅ ν = 𝗋⇧-⇧1[r]"
using ide_base obj_is_self_adjoint T1 [of "src r" "𝗋⇧-⇧1[r]"] comp_assoc by auto
interpret uwθων V H 𝖺 𝗂 src trg r ρ f g ‹src r› w θ' ‹𝗋⇧-⇧1[r]› ν
using ide_base tab_in_hom wθ'ν comp_assoc by (unfold_locales, auto)
text ‹
CKS now say:
\begin{quotation}
``Apply ‹T2› with ‹u = 1⇩A›, ‹w = f⇧*›, ‹w' = f'›, ‹θ = ε: ff⇧* ⇒ 1›, ‹θ': ff' ⇒ 1›,
‹β = ν(rε)(ρf⇧*)› to obtain ‹γ : f⇧* ⇒ f'› with ‹gγ = ν(rε)(ρf⇧*)ε = θ'(fγ).›''
\end{quotation}
The last equation is mysterious, but upon consideration one eventually realizes
that it is definitely a typo, and what is meant is ``‹gγ = ν(rε)(ρf⇧*)›, ‹ε = θ'(fγ)›''.
So, we take ‹u = trg f›, ‹w = f⇧*›, ‹w' = w›, ‹θ'› as obtained from ‹T1›, ‹θ = ε›,
and ‹β = ν ⋅ 𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅ (ρ ⋆ f⇧*)›.
(CKS mention neither the unitor term ‹𝗋[r]› nor the associativity ‹𝖺[r, f, f⇧*]›
which are required for the expression for ‹β› to make sense.)
›
let ?ψ = "𝗋[r] ⋅ composite_cell f⇧* ε"
show ψ_in_hom: "«T0.trnr⇩ε r ρ : g ⋆ f⇧* ⇒ r»"
using ide_base T0.trnr⇩ε_def rep_in_hom by simp
have A: "«ν ⋅ ?ψ : g ⋆ f⇧* ⇒ g ⋆ w»"
using ide_base T0.antipar hseq_char T0.trnr⇩ε_def rep_in_hom wθ'ν
apply (intro comp_in_homI') by auto
have B: "composite_cell f⇧* ε = composite_cell w θ' ⋅ ν ⋅ ?ψ"
using ide_base T0.antipar wθ'ν comp_assoc
by (metis A arrI invert_side_of_triangle(1) iso_runit)
obtain γ where γ: "«γ : f⇧* ⇒ w» ∧ ν ⋅ ?ψ = g ⋆ γ ∧ ε = θ' ⋅ (f ⋆ γ)"
using A B T0.counit_in_hom obj_is_self_adjoint T0.antipar comp_assoc
T2 [of "trg f" "f⇧*" w ε θ' "ν ⋅ 𝗋[r] ⋅ composite_cell f⇧* ε"]
by auto
have trg_γ_eq: "trg γ = trg w"
using γ by fastforce
text ‹
CKS say:
\begin{quotation}
``The last equation implies ‹γ: f⇧* ⇒ f'› is a split monic (coretraction), while
the calculation:
\begin{eqnarray*}
‹(gγ)(gf⇧*θ')(gηf')› &‹=›& ‹ν(rε)(ρf⇧*)(gf⇧*θ')(gηf')›\\
&‹=›& ‹ν(rε)(rff⇧*θ')(ρf⇧*ff')(gηf')›\\
&‹=›& ‹ν(rθ')(rεff')(rfηf')(ρf')›\\
&‹=›& ‹ν(rθ')(ρf') = 1⇩g⇩f⇩'›,
\end{eqnarray*}
shows that ‹gγ› is a split epic. So ‹gγ = ν(rε)(ρf⇧*): gf⇧* ⇒ gf'› is invertible.
So ‹(rε)(ρf⇧*) = ν⇧-⇧1(gγ)› 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.
›
have "section (g ⋆ γ)"
proof
have "(g ⋆ 𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w] ⋅ (η ⋆ w) ⋅ 𝗅⇧-⇧1[w]) ⋅ (g ⋆ γ) = g ⋆ f⇧*"
proof -
have "(𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w] ⋅ (η ⋆ w) ⋅ 𝗅⇧-⇧1[w]) ⋅ γ = f⇧*"
proof -
have "(𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w] ⋅ (η ⋆ w) ⋅ 𝗅⇧-⇧1[w]) ⋅ γ =
(𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w] ⋅ (η ⋆ w)) ⋅ 𝗅⇧-⇧1[w] ⋅ γ"
using comp_assoc by auto
also have "... = (𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w]) ⋅ ((η ⋆ w) ⋅ (trg w ⋆ γ)) ⋅ 𝗅⇧-⇧1[f⇧*]"
using γ trg_γ_eq lunit'_naturality [of γ] comp_assoc by auto
also have "... = 𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ (𝖺[f⇧*, f, w] ⋅ ((f⇧* ⋆ f) ⋆ γ)) ⋅ (η ⋆ f⇧*) ⋅ 𝗅⇧-⇧1[f⇧*]"
proof -
have "(η ⋆ w) ⋅ (trg w ⋆ γ) = η ⋆ γ"
using A γ interchange comp_arr_dom comp_cod_arr
by (metis T0.unit_simps(1-2) comp_ide_arr seqI' uwθ w_in_hom(2) w_simps(4))
also have "... = ((f⇧* ⋆ f) ⋆ γ) ⋅ (η ⋆ f⇧*)"
using γ 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 "... = 𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ ((f⇧* ⋆ f ⋆ γ) ⋅ 𝖺[f⇧*, f, f⇧*]) ⋅ (η ⋆ f⇧*) ⋅ 𝗅⇧-⇧1[f⇧*]"
using γ assoc_naturality [of "f⇧*" f γ] trg_γ_eq T0.antipar by auto
also have "... = 𝗋[f⇧*] ⋅ ((f⇧* ⋆ ε) ⋅ 𝖺[f⇧*, f, f⇧*] ⋅ (η ⋆ f⇧*)) ⋅ 𝗅⇧-⇧1[f⇧*]"
using γ whisker_left trg_γ_eq T0.antipar comp_assoc by auto
also have "... = 𝗋[f⇧*] ⋅ (𝗋⇧-⇧1[f⇧*] ⋅ 𝗅[f⇧*]) ⋅ 𝗅⇧-⇧1[f⇧*]"
using T0.triangle_right by simp
also have "... = f⇧*"
using comp_assoc by (simp add: comp_arr_dom comp_arr_inv')
finally show ?thesis by blast
qed
thus ?thesis
using γ whisker_left [of g "𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w] ⋅ (η ⋆ w) ⋅ 𝗅⇧-⇧1[w]" γ]
T0.antipar
by simp
qed
thus "ide ((g ⋆ 𝗋[f⇧*] ⋅ (f⇧* ⋆ θ') ⋅ 𝖺[f⇧*, f, w] ⋅ (η ⋆ w) ⋅ 𝗅⇧-⇧1[w]) ⋅ (g ⋆ γ))"
using T0.antipar by simp
qed
moreover have "retraction (g ⋆ γ)"
proof
have "«(g ⋆ γ) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅ (g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]) :
g ⋆ w ⇒ g ⋆ w»"
using γ T0.antipar hseq_char by force
hence **: "arr ((g ⋆ γ) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅
(g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]))"
by auto
show "ide ((g ⋆ γ) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅
(g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]))"
proof -
have "((g ⋆ γ) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅
(g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w])) =
g ⋆ w"
proof -
have "((g ⋆ γ) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅
(g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w])) =
ν ⋅ 𝗋[r] ⋅ ((r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ 𝖺[src f⇧*, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
(ρ ⋆ trg w ⋆ w)) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
proof -
have "(g ⋆ γ) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅
(g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]) =
(ν ⋅ 𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅ (ρ ⋆ f⇧*)) ⋅
(g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅
(g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
using γ by auto
also have "... =
ν ⋅ 𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅
((ρ ⋆ f⇧*) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ')) ⋅
(g ⋆ 𝖺[f⇧*, f, w]) ⋅ (g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
using comp_assoc by simp
also have "... = ν ⋅ 𝗋[r] ⋅ (r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅
(((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ ((r ⋆ f) ⋆ f⇧* ⋆ θ') ⋅ (ρ ⋆ f⇧* ⋆ f ⋆ w)) ⋅
(g ⋆ 𝖺[f⇧*, f, w]) ⋅ (g ⋆ η ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
proof -
have "(ρ ⋆ f⇧*) ⋅ (g ⋆ 𝗋[f⇧*]) ⋅ (g ⋆ f⇧* ⋆ θ') =
((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ (ρ ⋆ f⇧* ⋆ src f⇧*) ⋅ (g ⋆ f⇧* ⋆ θ')"
proof -
have "(ρ ⋆ f⇧*) ⋅ (g ⋆ 𝗋[f⇧*]) = ((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ (ρ ⋆ f⇧* ⋆ src f⇧*)"
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 ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ (ρ ⋆ f⇧* ⋆ θ')"
using comp_arr_dom comp_cod_arr T0.antipar
interchange [of ρ g "f⇧* ⋆ src f⇧*" "f⇧* ⋆ θ'"]
by simp
also have "... = ((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ ((r ⋆ f) ⋆ f⇧* ⋆ θ') ⋅ (ρ ⋆ f⇧* ⋆ f ⋆ w)"
using comp_arr_dom comp_cod_arr T0.antipar
interchange [of "r ⋆ f" ρ "f⇧* ⋆ θ'" "f⇧* ⋆ f ⋆ w"]
by simp
finally show ?thesis by simp
qed
also have "... =
ν ⋅ 𝗋[r] ⋅
((r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅ ((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ ((r ⋆ f) ⋆ f⇧* ⋆ θ')) ⋅
((ρ ⋆ f⇧* ⋆ f ⋆ w) ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅ (g ⋆ η ⋆ w)) ⋅
(g ⋆ 𝗅⇧-⇧1[w])"
using comp_assoc by simp
also have "... = ν ⋅ 𝗋[r] ⋅
((r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ ε ⋆ f ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]) ⋅
(((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ ((r ⋆ f) ⋆ η ⋆ w) ⋅ (ρ ⋆ trg w ⋆ w)) ⋅
(g ⋆ 𝗅⇧-⇧1[w])"
proof -
have 1: "(r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅ ((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ ((r ⋆ f) ⋆ f⇧* ⋆ θ') =
(r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ ε ⋆ f ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]"
proof -
have "(r ⋆ ε) ⋅ 𝖺[r, f, f⇧*] ⋅ ((r ⋆ f) ⋆ 𝗋[f⇧*]) ⋅ ((r ⋆ f) ⋆ f⇧* ⋆ θ') =
(r ⋆ ε) ⋅ (r ⋆ f ⋆ 𝗋[f⇧*]) ⋅ 𝖺[r, f, f⇧* ⋆ src f⇧*] ⋅ ((r ⋆ f) ⋆ f⇧* ⋆ θ')"
proof -
have "𝖺[r, f, f⇧*] ⋅ ((r ⋆ f) ⋆ 𝗋[f⇧*]) = (r ⋆ f ⋆ 𝗋[f⇧*]) ⋅ 𝖺[r, f, f⇧* ⋆ src f⇧*]"
using assoc_naturality [of r f "𝗋[f⇧*]"] T0.antipar by auto
thus ?thesis
using comp_assoc by metis
qed
also have "... = (r ⋆ ε) ⋅ (r ⋆ f ⋆ 𝗋[f⇧*]) ⋅ (r ⋆ f ⋆ f⇧* ⋆ θ') ⋅
𝖺[r, f, f⇧* ⋆ f ⋆ w]"
using assoc_naturality [of r f "f⇧* ⋆ θ'"] T0.antipar by fastforce
also have "... = (r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*]) ⋅
(r ⋆ f ⋆ f⇧* ⋆ θ') ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]"
proof -
have "(r ⋆ ε) ⋅ (r ⋆ f ⋆ 𝗋[f⇧*]) =
(r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*])"
proof -
have "(r ⋆ ε) ⋅ (r ⋆ f ⋆ 𝗋[f⇧*]) = r ⋆ (ε ⋅ (f ⋆ 𝗋[f⇧*]))"
using whisker_left T0.antipar by simp
also have "... =
(r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*])"
proof -
have "ε ⋅ (f ⋆ 𝗋[f⇧*]) = 𝗋[src f⇧*] ⋅ (ε ⋆ src f⇧*) ⋅ 𝖺⇧-⇧1[f, f⇧*, src f⇧*]"
using ide_leg0 T0.antipar runit_hcomp invert_side_of_triangle(2)
runit_naturality comp_assoc
by (metis (no_types, lifting) T0.counit_simps(1-4) T0.ide_right)
thus ?thesis
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 ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ ε ⋆ src f⇧*) ⋅
((r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*]) ⋅ (r ⋆ f ⋆ f⇧* ⋆ θ')) ⋅
𝖺[r, f, f⇧* ⋆ f ⋆ w]"
using comp_assoc by simp
also have "... = (r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ ε ⋆ src f⇧*) ⋅
((r ⋆ (f ⋆ f⇧*) ⋆ θ') ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w])) ⋅
𝖺[r, f, f⇧* ⋆ f ⋆ w]"
proof -
have "(r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*]) ⋅ (r ⋆ f ⋆ f⇧* ⋆ θ') =
(r ⋆ (f ⋆ f⇧*) ⋆ θ') ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w])"
proof -
have "(r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*]) ⋅ (r ⋆ f ⋆ f⇧* ⋆ θ') =
r ⋆ 𝖺⇧-⇧1[f, f⇧*, src f⇧*] ⋅ (f ⋆ f⇧* ⋆ θ')"
using whisker_left T0.antipar by simp
also have "... = r ⋆ ((f ⋆ f⇧*) ⋆ θ') ⋅ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]"
using assoc'_naturality [of f "f⇧*" θ'] T0.antipar by auto
also have "... = (r ⋆ (f ⋆ f⇧*) ⋆ θ') ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w])"
using whisker_left T0.antipar by auto
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = (r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ (f ⋆ f⇧*) ⋆ θ') ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]"
using comp_assoc by simp
also have "... =
(r ⋆ 𝗋[src f⇧*]) ⋅ ((r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ (f ⋆ f⇧*) ⋆ θ')) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]"
using comp_assoc by simp
also have "... = (r ⋆ 𝗋[src f⇧*]) ⋅ ((r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ ε ⋆ f ⋆ w)) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]"
proof -
have "(r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ (f ⋆ f⇧*) ⋆ θ') =
(r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ ε ⋆ f ⋆ w)"
proof -
have "(r ⋆ ε ⋆ src f⇧*) ⋅ (r ⋆ (f ⋆ f⇧*) ⋆ θ') =
r ⋆ (ε ⋆ src f⇧*) ⋅ ((f ⋆ f⇧*) ⋆ θ')"
using whisker_left T0.antipar by simp
also have "... = r ⋆ ε ⋆ θ'"
using interchange [of ε "f ⋆ f⇧*" "src f⇧*" θ']
T0.antipar comp_arr_dom comp_cod_arr
by auto
also have "... = r ⋆ (src f⇧* ⋆ θ') ⋅ (ε ⋆ f ⋆ w)"
using interchange [of "src f⇧*" ε θ' "f ⋆ w"]
T0.antipar comp_arr_dom comp_cod_arr
by auto
also have "... = (r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ ε ⋆ f ⋆ w)"
using whisker_left T0.antipar by simp
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = (r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ ε ⋆ f ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]"
using comp_assoc by simp
finally show ?thesis by simp
qed
have 2: "(ρ ⋆ f⇧* ⋆ f ⋆ w) ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅ (g ⋆ η ⋆ w) =
((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ ((r ⋆ f) ⋆ η ⋆ w) ⋅ (ρ ⋆ trg w ⋆ w)"
proof -
have "(ρ ⋆ f⇧* ⋆ f ⋆ w) ⋅ (g ⋆ 𝖺[f⇧*, f, w]) ⋅ (g ⋆ η ⋆ w) =
((ρ ⋆ f⇧* ⋆ f ⋆ w) ⋅ (g ⋆ 𝖺[f⇧*, f, w])) ⋅ (g ⋆ η ⋆ w)"
using comp_assoc by simp
also have "... = (((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ (ρ ⋆ (f⇧* ⋆ f) ⋆ w)) ⋅ (g ⋆ η ⋆ w)"
proof -
have "(ρ ⋆ f⇧* ⋆ f ⋆ w) ⋅ (g ⋆ 𝖺[f⇧*, f, w]) =
((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ (ρ ⋆ (f⇧* ⋆ f) ⋆ w)"
proof -
have "(ρ ⋆ f⇧* ⋆ f ⋆ w) ⋅ (g ⋆ 𝖺[f⇧*, f, w]) =
ρ ⋅ g ⋆ (f⇧* ⋆ f ⋆ w) ⋅ 𝖺[f⇧*, f, w]"
using interchange T0.antipar by auto
also have "... = ρ ⋆ 𝖺[f⇧*, f, w]"
using comp_arr_dom comp_cod_arr T0.antipar by auto
also have "... = (r ⋆ f) ⋅ ρ ⋆ 𝖺[f⇧*, f, w] ⋅ ((f⇧* ⋆ f) ⋆ w)"
using comp_arr_dom comp_cod_arr T0.antipar by auto
also have "... = ((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ (ρ ⋆ (f⇧* ⋆ f) ⋆ w)"
using interchange T0.antipar by auto
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = ((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ (ρ ⋆ (f⇧* ⋆ f) ⋆ w) ⋅ (g ⋆ η ⋆ w)"
using comp_assoc by simp
also have "... = ((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅ ((r ⋆ f) ⋆ η ⋆ w) ⋅ (ρ ⋆ trg w ⋆ w)"
proof -
have "(ρ ⋆ (f⇧* ⋆ f) ⋆ w) ⋅ (g ⋆ η ⋆ w) = ((r ⋆ f) ⋆ η ⋆ w) ⋅ (ρ ⋆ trg w ⋆ w)"
proof -
have "(ρ ⋆ (f⇧* ⋆ f) ⋆ w) ⋅ (g ⋆ η ⋆ w) = ρ ⋅ g ⋆ (f⇧* ⋆ f) ⋅ η ⋆ w ⋅ w"
proof -
have "«g ⋆ η ⋆ w : g ⋆ trg w ⋆ w ⇒ g ⋆ (f⇧* ⋆ f) ⋆ w»"
by (intro hcomp_in_vhom, auto)
thus ?thesis
using interchange whisker_right T0.antipar by auto
qed
also have "... = (r ⋆ f) ⋅ ρ ⋆ η ⋅ trg w ⋆ w ⋅ w"
using comp_arr_dom comp_cod_arr by auto
also have "... = ((r ⋆ f) ⋆ η ⋆ w) ⋅ (ρ ⋆ trg w ⋆ w)"
using interchange [of "r ⋆ f" ρ "η ⋆ w" "trg w ⋆ w"]
interchange [of η "trg w" w w]
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 "... =
ν ⋅ 𝗋[r] ⋅
((r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ') ⋅
((r ⋆ 𝖺[src r, f, w]) ⋅ (r ⋆ (ε ⋆ f) ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f ⋆ f⇧*, f, w])) ⋅
(r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅ 𝖺[r, f, f⇧* ⋆ f ⋆ w]) ⋅
(((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅
(𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅ (r ⋆ 𝖺[f, f⇧* ⋆ f, w]) ⋅
(r ⋆ (f ⋆ η) ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w]) ⋅
(ρ ⋆ trg w ⋆ w)) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
proof -
have 3: "r ⋆ ε ⋆ f ⋆ w =
(r ⋆ 𝖺[src r, f, w]) ⋅ (r ⋆ (ε ⋆ f) ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f ⋆ f⇧*, f, w])"
proof -
have "r ⋆ ε ⋆ f ⋆ w =
((r ⋆ 𝖺[src r, f, w]) ⋅ (r ⋆ 𝖺⇧-⇧1[src r, f, w])) ⋅ (r ⋆ ε ⋆ f ⋆ w)"
using T0.antipar whisker_left [of r "𝖺[src r, f, w]" "𝖺⇧-⇧1[src r, f, w]"]
comp_cod_arr comp_assoc_assoc'
by simp
also have "... = (r ⋆ 𝖺[src r, f, w]) ⋅ (r ⋆ (ε ⋆ f) ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f ⋆ f⇧*, f, w])"
using assoc'_naturality [of ε f w]
whisker_left [of r "𝖺⇧-⇧1[src r, f, w]" "ε ⋆ f ⋆ w"]
whisker_left comp_assoc T0.antipar
by simp
finally show ?thesis
using T0.antipar by simp
qed
have 4: "(r ⋆ f) ⋆ η ⋆ w =
𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅ (r ⋆ 𝖺[f, f⇧* ⋆ f, w]) ⋅
(r ⋆ (f ⋆ η) ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w]"
proof -
have "(r ⋆ f) ⋆ η ⋆ w =
(𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅
((r ⋆ 𝖺[f, f⇧* ⋆ f, w]) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧* ⋆ f, w])) ⋅
𝖺[r, f, (f⇧* ⋆ f) ⋆ w]) ⋅
((r ⋆ f) ⋆ η ⋆ w)"
proof -
have "ide r" by simp
moreover have "seq 𝖺[f, f⇧* ⋆ f, w] 𝖺⇧-⇧1[f, f⇧* ⋆ f, w]"
using T0.antipar comp_cod_arr ide_base by simp
ultimately have "(r ⋆ 𝖺[f, f⇧* ⋆ f, w]) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧* ⋆ f, w]) =
r ⋆ 𝖺[f, f⇧* ⋆ f, w] ⋅ 𝖺⇧-⇧1[f, f⇧* ⋆ f, w]"
using whisker_left by metis
thus ?thesis
using T0.antipar comp_cod_arr comp_assoc_assoc' by simp
qed
also have "... =
𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅
(r ⋆ 𝖺[f, f⇧* ⋆ f, w]) ⋅ ((r ⋆ 𝖺⇧-⇧1[f, f⇧* ⋆ f, w]) ⋅
(r ⋆ f ⋆ η ⋆ w)) ⋅
𝖺[r, f, trg w ⋆ w]"
using assoc_naturality [of r f "η ⋆ w"] comp_assoc by fastforce
also have "... =
𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅
(r ⋆ 𝖺[f, f⇧* ⋆ f, w]) ⋅ (r ⋆ (f ⋆ η) ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
𝖺[r, f, trg w ⋆ w]"
using assoc'_naturality [of f η w] T0.antipar comp_assoc
whisker_left [of r "𝖺⇧-⇧1[f, f⇧* ⋆ f, w]" "f ⋆ η ⋆ w"]
whisker_left [of r "(f ⋆ η) ⋆ w" "𝖺⇧-⇧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 "... = ν ⋅ 𝗋[r] ⋅ ((r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ') ⋅
(r ⋆ 𝖺[src r, f, w]) ⋅
((r ⋆ (ε ⋆ f) ⋆ w) ⋅
((r ⋆ 𝖺⇧-⇧1[f ⋆ f⇧*, f, w]) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅
𝖺[r, f, f⇧* ⋆ f ⋆ w] ⋅ ((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅
𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅ (r ⋆ 𝖺[f, f⇧* ⋆ f, w])) ⋅
(r ⋆ (f ⋆ η) ⋆ w)) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
(ρ ⋆ trg w ⋆ w)) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
using comp_assoc T0.antipar by auto
also have "... = ν ⋅ 𝗋[r] ⋅ ((r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ') ⋅
(r ⋆ 𝖺[src r, f, w]) ⋅
((r ⋆ (ε ⋆ f) ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f] ⋆ w) ⋅
(r ⋆ (f ⋆ η) ⋆ w)) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
(ρ ⋆ trg w ⋆ w)) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
proof -
have "(r ⋆ 𝖺⇧-⇧1[f ⋆ f⇧*, f, w]) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅
𝖺[r, f, f⇧* ⋆ f ⋆ w] ⋅ ((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅
𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅ (r ⋆ 𝖺[f, f⇧* ⋆ f, w]) =
r ⋆ 𝖺⇧-⇧1[f, f⇧*, f] ⋆ w"
proof -
text ‹We can compress the reasoning about the associativities using coherence.›
have "(r ⋆ 𝖺⇧-⇧1[f ⋆ f⇧*, f, w]) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f ⋆ w]) ⋅
𝖺[r, f, f⇧* ⋆ f ⋆ w] ⋅ ((r ⋆ f) ⋆ 𝖺[f⇧*, f, w]) ⋅
𝖺⇧-⇧1[r, f, (f⇧* ⋆ f) ⋆ w] ⋅ (r ⋆ 𝖺[f, f⇧* ⋆ f, w]) =
⦃(❙⟨r❙⟩ ❙⋆ ❙𝖺⇧-⇧1❙[❙⟨f❙⟩ ❙⋆ ❙⟨f⇧*❙⟩, ❙⟨f❙⟩, ❙⟨w❙⟩❙]) ❙⋅ (❙⟨r❙⟩ ❙⋆ ❙𝖺⇧-⇧1❙[❙⟨f❙⟩, ❙⟨f⇧*❙⟩, ❙⟨f❙⟩ ❙⋆ ❙⟨w❙⟩❙]) ❙⋅
❙𝖺❙[❙⟨r❙⟩, ❙⟨f❙⟩, ❙⟨f⇧*❙⟩ ❙⋆ ❙⟨f❙⟩ ❙⋆ ❙⟨w❙⟩❙] ❙⋅ ((❙⟨r❙⟩ ❙⋆ ❙⟨f❙⟩) ❙⋆ ❙𝖺❙[❙⟨f⇧*❙⟩, ❙⟨f❙⟩, ❙⟨w❙⟩❙]) ❙⋅
❙𝖺⇧-⇧1❙[❙⟨r❙⟩, ❙⟨f❙⟩, (❙⟨f⇧*❙⟩ ❙⋆ ❙⟨f❙⟩) ❙⋆ ❙⟨w❙⟩❙] ❙⋅ (❙⟨r❙⟩ ❙⋆ ❙𝖺❙[❙⟨f❙⟩, ❙⟨f⇧*❙⟩ ❙⋆ ❙⟨f❙⟩, ❙⟨w❙⟩❙])⦄"
using T0.antipar 𝖺'_def α_def assoc'_eq_inv_assoc by auto
also have "... = ⦃❙⟨r❙⟩ ❙⋆ ❙𝖺⇧-⇧1❙[❙⟨f❙⟩, ❙⟨f⇧*❙⟩, ❙⟨f❙⟩❙] ❙⋆ ❙⟨w❙⟩⦄"
using T0.antipar by (intro E.eval_eqI, auto)
also have "... = r ⋆ 𝖺⇧-⇧1[f, f⇧*, f] ⋆ w"
using T0.antipar 𝖺'_def α_def assoc'_eq_inv_assoc by simp
finally show ?thesis
by simp
qed
thus ?thesis by simp
qed
also have "... = ν ⋅ 𝗋[r] ⋅ ((r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ') ⋅
(r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
(ρ ⋆ trg w ⋆ w)) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
proof -
have "(r ⋆ (ε ⋆ f) ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f] ⋆ w) ⋅ (r ⋆ (f ⋆ η) ⋆ w) =
r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w"
proof -
have "(r ⋆ (ε ⋆ f) ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, f⇧*, f] ⋆ w) ⋅ (r ⋆ (f ⋆ η) ⋆ w) =
r ⋆ (ε ⋆ f) ⋅ 𝖺⇧-⇧1[f, f⇧*, f] ⋅ (f ⋆ η) ⋆ w"
using whisker_left whisker_right T0.antipar by simp
also have "... = r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w"
using T0.triangle_left by simp
finally show ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = ν ⋅ 𝗋[r] ⋅ ((r ⋆ 𝗋[src f⇧*]) ⋅ (r ⋆ src f⇧* ⋆ θ') ⋅ (r ⋆ 𝖺[src f⇧*, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
(ρ ⋆ trg w ⋆ w)) ⋅ (g ⋆ 𝗅⇧-⇧1[w])"
using T0.antipar by simp
finally show ?thesis by simp
qed
also have "... = ν ⋅ 𝗋[r] ⋅
((r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ')) ⋅
(r ⋆ 𝖺[src r, f, w]) ⋅ (r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
((ρ ⋆ trg w ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]))"
using comp_assoc T0.antipar by simp
also have "... = ν ⋅ 𝗋[r] ⋅
((r ⋆ θ') ⋅ (r ⋆ 𝗅[f ⋆ w])) ⋅
(r ⋆ 𝖺[src r, f, w]) ⋅ (r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅
(r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅ 𝖺[r, f, trg w ⋆ w] ⋅
(((r ⋆ f) ⋆ 𝗅⇧-⇧1[w]) ⋅ (ρ ⋆ w))"
proof -
have "(r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ') = (r ⋆ θ') ⋅ (r ⋆ 𝗅[f ⋆ w])"
proof -
have "(r ⋆ 𝗋[src r]) ⋅ (r ⋆ src r ⋆ θ') = r ⋆ 𝗋[src r] ⋅ (src r ⋆ θ')"
using whisker_left by simp
also have "... = r ⋆ θ' ⋅ 𝗅[f ⋆ w]"
using lunit_naturality [of θ'] unitor_coincidence by simp
also have "... = (r ⋆ θ') ⋅ (r ⋆ 𝗅[f ⋆ w])"
using whisker_left by simp
finally show ?thesis by simp
qed
moreover have "(ρ ⋆ trg w ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]) = ((r ⋆ f) ⋆ 𝗅⇧-⇧1[w]) ⋅ (ρ ⋆ w)"
proof -
have "(ρ ⋆ trg w ⋆ w) ⋅ (g ⋆ 𝗅⇧-⇧1[w]) = ρ ⋅ g ⋆ (trg w ⋆ w) ⋅ 𝗅⇧-⇧1[w]"
using interchange by simp
also have "... = ρ ⋆ 𝗅⇧-⇧1[w]"
using comp_arr_dom comp_cod_arr by simp
also have "... = (r ⋆ f) ⋅ ρ ⋆ 𝗅⇧-⇧1[w] ⋅ w"
using comp_arr_dom comp_cod_arr by simp
also have "... = ((r ⋆ f) ⋆ 𝗅⇧-⇧1[w]) ⋅ (ρ ⋆ w)"
using interchange by simp
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
also have "... = ν ⋅ 𝗋[r] ⋅ (r ⋆ θ') ⋅
((r ⋆ 𝗅[f ⋆ w]) ⋅ (r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
𝖺[r, f, trg w ⋆ w] ⋅ ((r ⋆ f) ⋆ 𝗅⇧-⇧1[w])) ⋅
(ρ ⋆ w)"
using comp_assoc by simp
also have "... = ν ⋅ 𝗋[r] ⋅ (r ⋆ θ') ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w)"
proof -
have "((r ⋆ 𝗅[f ⋆ w]) ⋅ (r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
𝖺[r, f, trg w ⋆ w] ⋅ ((r ⋆ f) ⋆ 𝗅⇧-⇧1[w])) =
𝖺[r, f, w]"
proof -
have "((r ⋆ 𝗅[f ⋆ w]) ⋅ (r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
𝖺[r, f, trg w ⋆ w] ⋅ ((r ⋆ f) ⋆ 𝗅⇧-⇧1[w])) =
((r ⋆ (𝗅[f] ⋆ w) ⋅ 𝖺⇧-⇧1[trg f, f, w]) ⋅ (r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
(r ⋆ f ⋆ 𝗅⇧-⇧1[w])) ⋅ 𝖺[r, f, w]"
using comp_assoc assoc_naturality [of r f "𝗅⇧-⇧1[w]"] lunit_hcomp by simp
also have "... = 𝖺[r, f, w]"
proof -
have "(r ⋆ (𝗅[f] ⋆ w) ⋅ 𝖺⇧-⇧1[trg f, f, w]) ⋅ (r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
(r ⋆ f ⋆ 𝗅⇧-⇧1[w]) =
r ⋆ f ⋆ w"
proof -
text ‹Again, get a little more mileage out of coherence.›
have "(r ⋆ (𝗅[f] ⋆ w) ⋅ 𝖺⇧-⇧1[trg f, f, w]) ⋅ (r ⋆ 𝖺[src r, f, w]) ⋅
(r ⋆ 𝗅⇧-⇧1[f] ⋅ 𝗋[f] ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, trg w, w]) ⋅
(r ⋆ f ⋆ 𝗅⇧-⇧1[w]) =
⦃(❙⟨r❙⟩ ❙⋆ (❙𝗅❙[❙⟨f❙⟩❙] ❙⋆ ❙⟨w❙⟩) ❙⋅ ❙𝖺⇧-⇧1❙[E.Trg ❙⟨f❙⟩, ❙⟨f❙⟩, ❙⟨w❙⟩❙]) ❙⋅
(❙⟨r❙⟩ ❙⋆ ❙𝖺❙[E.Src ❙⟨r❙⟩, ❙⟨f❙⟩, ❙⟨w❙⟩❙]) ❙⋅
(❙⟨r❙⟩ ❙⋆ ❙𝗅⇧-⇧1❙[❙⟨f❙⟩❙] ❙⋅ ❙𝗋❙[❙⟨f❙⟩❙] ❙⋆ ❙⟨w❙⟩) ❙⋅ (❙⟨r❙⟩ ❙⋆ ❙𝖺⇧-⇧1❙[❙⟨f❙⟩, E.Trg ❙⟨w❙⟩, ❙⟨w❙⟩❙]) ❙⋅
(❙⟨r❙⟩ ❙⋆ ❙⟨f❙⟩ ❙⋆ ❙𝗅⇧-⇧1❙[❙⟨w❙⟩❙])⦄"
using 𝔩_ide_simp 𝔯_ide_simp 𝖺'_def α_def assoc'_eq_inv_assoc by simp
also have "... = ⦃❙⟨r❙⟩ ❙⋆ ❙⟨f❙⟩ ❙⋆ ❙⟨w❙⟩⦄"
by (intro E.eval_eqI, auto)
also have "... = r ⋆ f ⋆ w"
by simp
finally show ?thesis by blast
qed
thus ?thesis
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 "... = ν ⋅ 𝗋[r] ⋅ 𝗋⇧-⇧1[r] ⋅ inv ν"
proof -
have "𝗋⇧-⇧1[r] ⋅ inv ν = (r ⋆ θ') ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w)"
using ** wθ'ν 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 ⋆ w"
using ** wθ'ν 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 ⋆ γ)"
using iso_iff_section_and_retraction by simp
have "iso (inv (ν ⋅ 𝗋[r]) ⋅ (g ⋆ γ))"
proof -
have "iso (inv (ν ⋅ 𝗋[r]))"
using wθ'ν γ iso_runit
by (elim conjE in_homE, intro iso_inv_iso isos_compose, auto)
thus ?thesis
using 1 wθ'ν γ trg_γ_eq isos_compose
by (elim conjE in_homE, auto)
qed
moreover have "inv (ν ⋅ 𝗋[r]) ⋅ (g ⋆ γ) = composite_cell f⇧* ε"
proof -
have "inv (ν ⋅ 𝗋[r]) ⋅ (g ⋆ γ) = inv (ν ⋅ 𝗋[r]) ⋅ ν ⋅ 𝗋[r] ⋅ composite_cell f⇧* ε"
using γ by auto
also have "... = ((inv (ν ⋅ 𝗋[r]) ⋅ (ν ⋅ 𝗋[r])) ⋅ (r ⋆ ε)) ⋅ 𝖺[r, f, f⇧*] ⋅ (ρ ⋆ f⇧*)"
using wθ'ν comp_assoc by auto
also have "... = composite_cell f⇧* ε"
proof -
have "dom ν = r"
using wθ'ν by auto
thus ?thesis
using iso_runit wθ'ν isos_compose comp_cod_arr whisker_left comp_inv_arr'
by auto
qed
finally show ?thesis by blast
qed
ultimately have "iso (composite_cell f⇧* ε)" by simp
thus "iso (T0.trnr⇩ε r ρ)"
using T0.trnr⇩ε_def ide_base runit_in_hom iso_runit isos_compose
by (metis A arrI seqE)
qed
text ‹
It is convenient to have a simpler version of the previous result for when we do
not care about the details of the isomorphism.
›
lemma yields_isomorphic_representation':
obtains ψ where "«ψ : g ⋆ f⇧* ⇒ r»" and "iso ψ"
using yields_isomorphic_representation adjoint_pair_def by simp
end
text ‹
It is natural to ask whether if ‹«ψ : g ⋆ f⇧* ⇒ r»› is an isomorphism
then ‹ρ = (ψ ⋆ f) ⋅ T0.trnr⇩η g (g ⋆ f⇧*)› is a tabulation of ‹r›.
This is not true without additional conditions on ‹f› and ‹g›
(\emph{cf.}~the comments following CKS Proposition 6).
So only rather special isomorphisms ‹«ψ : g ⋆ f⇧* ⇒ r»› result from tabulations of ‹r›.
›
subsection "Tabulation of a Right Adjoint"
text ‹
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.
›
context adjunction_in_bicategory
begin
lemma tabulation_of_right_adjoint:
shows "tabulation V H 𝖺 𝗂 src trg g η f (src f)"
proof -
interpret T: tabulation_data V H 𝖺 𝗂 src trg g η f ‹src f›
using unit_in_hom antipar by (unfold_locales, simp_all)
show ?thesis
proof
show T1: "⋀u ω. ⟦ ide u; «ω : dom ω ⇒ g ⋆ u» ⟧ ⟹
∃w θ ν. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ src f ⋆ w» ∧ iso ν ∧
T.composite_cell w θ ⋅ ν = ω"
proof -
fix u v ω
assume u: "ide u"
assume ω: "«ω : v ⇒ g ⋆ u»"
have v: "ide v"
using ω by auto
have 1: "src g = trg u"
using ω by (metis arr_cod in_homE not_arr_null seq_if_composable)
have 2: "src f = trg v"
using ω 1 u ide_right antipar(1) vconn_implies_hpar(4) by force
text ‹It seems clear that we need to take ‹w = v› and ‹ν = 𝗅⇧-⇧1[v]›. ›
let ?w = v
let ?ν = "𝗅⇧-⇧1[v]"
have ν: "«?ν : v ⇒ src f ⋆ ?w» ∧ iso ?ν"
using v 2 iso_lunit' by auto
text ‹
We need ‹θ›, defined to satisfy ‹«θ : f ⋆ v ⇒ u»› and
‹ω = (v ⋆ θ) ⋅ 𝖺[v, f, v] ⋅ (η ⋆ w) ⋅ 𝗅⇧-⇧1[v]›.
We have ‹«ω : v ⇒ g ⋆ u»›, so we can get arrow ‹«θ : f ⋆ v ⇒ u»› by adjoint transpose.
Note that this uses adjoint transpose on the \emph{left}, rather than on the right.
›
let ?θ = "trnl⇩ε u ω"
have θ: "«?θ : f ⋆ ?w ⇒ u»"
using u v antipar 1 2 ω adjoint_transpose_left(2) [of u v] by auto
text ‹
Now, ‹trnl⇩η v θ ≡ (g ⋆ θ) ⋅ 𝖺[g, f, v] ⋅ (η ⋆ v) ⋅ 𝗅⇧-⇧1[v]›, which suggests that
we ought to have ‹ω = trnl⇩η v θ› and ‹ν = 𝗅⇧-⇧1[v]›;
›
have "T.composite_cell ?w ?θ ⋅ ?ν = ω"
using u v ω 1 2 adjoint_transpose_left(4) [of u v ω] trnl⇩η_def comp_assoc by simp
thus "∃w θ ν. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : v ⇒ src f ⋆ w» ∧ iso ν ∧
T.composite_cell w θ ⋅ ν = ω"
using v θ ν antipar comp_assoc by blast
qed
show T2: "⋀u w w' θ θ' β.
⟦ ide w; ide w'; «θ : f ⋆ w ⇒ u»; «θ' : f ⋆ w' ⇒ u»;
«β : src f ⋆ w ⇒ src f ⋆ w'»;
T.composite_cell w θ = T.composite_cell w' θ' ⋅ β ⟧ ⟹
∃!γ. «γ : w ⇒ w'» ∧ β = src f ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
proof -
fix u w w' θ θ' β
assume w: "ide w"
assume w': "ide w'"
assume θ: "«θ : f ⋆ w ⇒ u»"
assume θ': "«θ' : f ⋆ w' ⇒ u»"
assume β: "«β : src f ⋆ w ⇒ src f ⋆ w'»"
assume E: "T.composite_cell w θ = T.composite_cell w' θ' ⋅ β"
interpret T: uwθw'θ'β V H 𝖺 𝗂 src trg g η f ‹src f› u w θ w' θ' β
using w w' θ θ' β E comp_assoc by (unfold_locales, auto)
have 2: "src f = trg β"
using antipar by simp
show "∃!γ. «γ : w ⇒ w'» ∧ β = src f ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
proof -
text ‹
The requirement ‹β = src f ⋆ γ› means we have to essentially invert ‹λγ. src f ⋆ γ›
to obtain ‹γ›. CKS say only: ``the strong form of ‹T2› is clear since ‹g = 1›"
(here by ``‹g›'' they are referring to ‹dom η›, the ``output leg'' of the span in
the tabulation). This would mean that we would have to take ‹γ = β›, which doesn't
work for a general bicategory (we don't necessarily have ‹src f ⋆ γ = γ›).
For a general bicategory, we have to take ‹γ = 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w]›.
›
let ?γ = "𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w]"
have γ: "«?γ : w ⇒ w'»"
using β by simp
have 3: "β = src f ⋆ ?γ"
proof -
have "β = 𝗅⇧-⇧1[w'] ⋅ ?γ ⋅ 𝗅[w]"
using β iso_lunit
by (simp add: comp_arr_dom invert_side_of_triangle(1) comp_assoc)
also have "... = 𝗅⇧-⇧1[w'] ⋅ 𝗅[w'] ⋅ (src f ⋆ ?γ)"
using γ lunit_naturality
by (metis T.uwθ.w_simps(4) in_homE trg_dom)
also have "... = (𝗅⇧-⇧1[w'] ⋅ 𝗅[w']) ⋅ (src f ⋆ ?γ)"
using comp_assoc by simp
also have "... = src f ⋆ ?γ"
using γ iso_lunit comp_inv_arr comp_cod_arr
by (metis T.β_simps(1) calculation comp_ide_arr inv_is_inverse inverse_arrowsE w')
finally show ?thesis by simp
qed
have "θ = θ' ⋅ (f ⋆ ?γ)"
proof -
have "θ = trnl⇩ε u (trnl⇩η w θ)"
using θ adjoint_transpose_left(3) [of u w θ] by simp
also have "... = trnl⇩ε u (trnl⇩η w' θ' ⋅ 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w])"
proof -
have "trnl⇩η w θ = trnl⇩η w' θ' ⋅ 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w]"
proof -
have "trnl⇩η w θ ⋅ 𝗅[w] = (T.composite_cell w θ ⋅ 𝗅⇧-⇧1[w]) ⋅ 𝗅[w]"
unfolding trnl⇩η_def using comp_assoc by simp
also have "... = T.composite_cell w θ ⋅ (𝗅⇧-⇧1[w] ⋅ 𝗅[w])"
using comp_assoc by simp
also have 4: "... = T.composite_cell w θ"
using comp_arr_dom by (simp add: comp_inv_arr')
also have "... = T.composite_cell w' θ' ⋅ β"
using E by simp
also have "... = (T.composite_cell w' θ' ⋅ 𝗅⇧-⇧1[w']) ⋅ 𝗅[w'] ⋅ β"
proof -
have "(𝗅⇧-⇧1[w'] ⋅ 𝗅[w']) ⋅ β = β"
using iso_lunit β comp_cod_arr comp_assoc comp_inv_arr' by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = trnl⇩η w' θ' ⋅ 𝗅[w'] ⋅ β"
unfolding trnl⇩η_def using comp_assoc by simp
finally have "trnl⇩η w θ ⋅ 𝗅[w] = trnl⇩η w' θ' ⋅ 𝗅[w'] ⋅ β"
by simp
thus ?thesis
using β 4 invert_side_of_triangle(2) adjoint_transpose_left iso_lunit
trnl⇩η_def comp_assoc
by metis
qed
thus ?thesis by simp
qed
also have "... = 𝗅[u] ⋅ (ε ⋆ u) ⋅ 𝖺⇧-⇧1[f, g, u] ⋅ (f ⋆ trnl⇩η w' θ' ⋅ 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w])"
using trnl⇩ε_def by simp
also have
"... = 𝗅[u] ⋅ (ε ⋆ u) ⋅ 𝖺⇧-⇧1[f, g, u] ⋅ (f ⋆ trnl⇩η w' θ') ⋅ (f ⋆ 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w])"
using ide_left ide_right w w' 2 β θ antipar trnl⇩ε_def adjoint_transpose_left
whisker_left
by (metis T.uwθ.θ_simps(1) calculation hseqE seqE)
also have
"... = (𝗅[u] ⋅ (ε ⋆ u) ⋅ 𝖺⇧-⇧1[f, g, u] ⋅ (f ⋆ trnl⇩η w' θ')) ⋅ (f ⋆ 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w])"
using comp_assoc by simp
also have "... = trnl⇩ε u (trnl⇩η w' θ') ⋅ (f ⋆ 𝗅[w'] ⋅ β ⋅ 𝗅⇧-⇧1[w])"
unfolding trnl⇩ε_def by simp
also have "... = θ' ⋅ (f ⋆ ?γ)"
using θ' adjoint_transpose_left(3) by auto
finally show ?thesis by simp
qed
hence "∃γ. «γ : w ⇒ w'» ∧ β = src f ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
using γ 3 hcomp_obj_arr by blast
moreover have "⋀γ γ'. «γ : w ⇒ w'» ∧ β = src f ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ) ∧
«γ' : w ⇒ w'» ∧ β = src f ⋆ γ' ∧ θ = θ' ⋅ (f ⋆ γ') ⟹ γ = γ'"
proof -
fix γ γ'
assume γγ': "«γ : w ⇒ w'» ∧ β = src f ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ) ∧
«γ' : w ⇒ w'» ∧ β = src f ⋆ γ' ∧ θ = θ' ⋅ (f ⋆ γ')"
show "γ = γ'"
using γγ' vconn_implies_hpar(2) L.is_faithful [of γ γ'] by force
qed
ultimately show ?thesis by blast
qed
qed
qed
qed
end
subsection "Preservation by Isomorphisms"
text ‹
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.
›
context tabulation
begin
text ‹
Tabulations are preserved under composition of an isomorphism with the ``input leg''.
›
lemma preserved_by_input_iso:
assumes "«φ : f ⇒ f'»" and "iso φ"
shows "tabulation V H 𝖺 𝗂 src trg r ((r ⋆ φ) ⋅ ρ) f' g"
proof -
interpret T': tabulation_data V H 𝖺 𝗂 src trg r ‹(r ⋆ φ) ⋅ ρ› f'
using assms(1) tab_in_hom
apply unfold_locales
apply auto
by force
show ?thesis
proof
show "⋀u ω. ⟦ ide u; «ω : dom ω ⇒ r ⋆ u» ⟧ ⟹
∃w θ ν. ide w ∧ «θ : f' ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧
iso ν ∧ T'.composite_cell w θ ⋅ ν = ω"
proof -
fix u ω
assume u: "ide u" and ω: "«ω : dom ω ⇒ r ⋆ u»"
obtain w θ ν where wθν: "ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧
iso ν ∧ composite_cell w θ ⋅ ν = ω"
using u ω T1 by blast
interpret T1: uwθων V H 𝖺 𝗂 src trg r ρ f g u w θ ω ν
using wθν comp_assoc by (unfold_locales, auto)
have 1: "«inv φ ⋆ w : f' ⋆ w ⇒ f ⋆ w»"
using assms by (intro hcomp_in_vhom, auto)
have "ide w ∧ «θ ⋅ (inv φ ⋆ w) : f' ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧ iso ν ∧
T'.composite_cell w (θ ⋅ (inv φ ⋆ w)) ⋅ ν = ω"
using wθν 1
apply (intro conjI)
apply auto[4]
proof -
show "T'.composite_cell w (θ ⋅ (inv φ ⋆ w)) ⋅ ν = ω"
proof -
have "T'.composite_cell w (θ ⋅ (inv φ ⋆ w)) ⋅ ν =
(r ⋆ θ) ⋅ ((r ⋆ inv φ ⋆ w) ⋅ 𝖺[r, f', w]) ⋅ ((r ⋆ φ) ⋅ ρ ⋆ w) ⋅ ν"
using assms(1) 1 whisker_left [of r θ "inv φ ⋆ w"] comp_assoc by auto
also have "... = (r ⋆ θ) ⋅ (𝖺[r, f, w] ⋅ ((r ⋆ inv φ) ⋆ w)) ⋅ ((r ⋆ φ) ⋅ ρ ⋆ w) ⋅ ν"
using assms assoc_naturality [of r "inv φ" 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 ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ ((((r ⋆ inv φ) ⋆ w) ⋅ ((r ⋆ φ) ⋆ w)) ⋅ (ρ ⋆ w)) ⋅ ν"
using whisker_right [of w "r ⋆ φ" ρ] comp_assoc T1.ide_w vseq_implies_hpar(1)
by auto
also have "... = composite_cell w θ ⋅ ν"
proof -
have "(((r ⋆ inv φ) ⋆ w) ⋅ ((r ⋆ φ) ⋆ w)) ⋅ (ρ ⋆ w) = ρ ⋆ w"
proof -
have "«r ⋆ φ : r ⋆ f ⇒ r ⋆ f'»"
using assms(1) by (intro hcomp_in_vhom, auto)
moreover have "«r ⋆ inv φ : r ⋆ f' ⇒ r ⋆ f»"
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 "... = ω"
using wθν by simp
finally show ?thesis by simp
qed
qed
thus "∃w θ ν. ide w ∧ «θ : f' ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧ iso ν ∧
T'.composite_cell w θ ⋅ ν = ω"
by blast
qed
show "⋀u w w' θ θ' β. ⟦ ide w; ide w'; «θ : f' ⋆ w ⇒ u»; «θ' : f' ⋆ w' ⇒ u»;
«β : g ⋆ w ⇒ g ⋆ w'»;
T'.composite_cell w θ = T'.composite_cell w' θ' ⋅ β ⟧ ⟹
∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f' ⋆ γ)"
proof -
fix u w w' θ θ' β
assume w: "ide w" and w': "ide w'"
and θ: "«θ : f' ⋆ w ⇒ u»" and θ': "«θ' : f' ⋆ w' ⇒ u»"
and β: "«β : g ⋆ w ⇒ g ⋆ w'»"
and eq: "T'.composite_cell w θ = T'.composite_cell w' θ' ⋅ β"
interpret uwθw'θ'β V H 𝖺 𝗂 src trg r ‹(r ⋆ φ) ⋅ ρ› f' g u w θ w' θ' β
using w w' θ θ' β eq comp_assoc by (unfold_locales, auto)
show "∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f' ⋆ γ)"
proof -
have φ_w: "«φ ⋆ w : f ⋆ w ⇒ f' ⋆ w»"
using assms(1) by (intro hcomp_in_vhom, auto)
have φ_w': "«φ ⋆ w' : f ⋆ w' ⇒ f' ⋆ w'»"
using assms(1) by (intro hcomp_in_vhom, auto)
have "«θ ⋅ (φ ⋆ w) : f ⋆ w ⇒ u»"
using θ assms(1) by fastforce
moreover have "«θ' ⋅ (φ ⋆ w') : f ⋆ w' ⇒ u»"
using θ' assms(1) by fastforce
moreover have "composite_cell w (θ ⋅ (φ ⋆ w)) = composite_cell w' (θ' ⋅ (φ ⋆ w')) ⋅ β"
proof -
have "composite_cell w (θ ⋅ (φ ⋆ w)) =
(r ⋆ θ) ⋅ ((r ⋆ φ ⋆ w) ⋅ 𝖺[r, f, w]) ⋅ (ρ ⋆ w)"
using assms(2) φ_w θ whisker_left comp_assoc by auto
also have "... = (r ⋆ θ) ⋅ 𝖺[r, f', w] ⋅ ((r ⋆ φ) ⋆ w) ⋅ (ρ ⋆ w)"
using assms(1) assoc_naturality [of r φ w] comp_assoc
by (metis φ_w T'.tab_simps(1) base_simps(3) base_simps(4) hseq_char
in_homE seqE uwθ.w_simps(5) uwθ.w_simps(6))
also have "... = T'.composite_cell w θ"
using assms(2) w whisker_right [of w] by simp
also have "... = T'.composite_cell w' θ' ⋅ β"
using eq by simp
also have "... = (r ⋆ θ') ⋅ (𝖺[r, f', w'] ⋅ ((r ⋆ φ) ⋆ w')) ⋅ (ρ ⋆ w') ⋅ β"
using assms(2) w' whisker_right [of w'] comp_assoc by simp
also have "... = ((r ⋆ θ') ⋅ (r ⋆ φ ⋆ w')) ⋅ 𝖺[r, f, w'] ⋅ (ρ ⋆ w') ⋅ β"
using assms(1) assoc_naturality [of r φ w'] comp_assoc
by (metis φ_w' T'.tab_simps(1) base_simps(3) base_simps(4) hseqE in_homE seqE
uw'θ'.w_simps(5) uw'θ'.w_simps(6))
also have "... = composite_cell w' (θ' ⋅ (φ ⋆ w')) ⋅ β"
using assms(2) whisker_left [of r] ‹«θ' ⋅ (φ ⋆ w') : f ⋆ w' ⇒ u»› comp_assoc
by auto
finally show ?thesis by simp
qed
ultimately have *: "∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧
θ ⋅ (φ ⋆ w) = (θ' ⋅ (φ ⋆ w')) ⋅ (f ⋆ γ)"
using w w' β T2 by auto
show ?thesis
proof -
have **: "⋀γ. «γ : w ⇒ w'» ⟹ θ' ⋅ (φ ⋆ w') ⋅ (f ⋆ γ) ⋅ (inv φ ⋆ w) = θ' ⋅ (f' ⋆ γ)"
proof -
fix γ
assume γ: "«γ : w ⇒ w'»"
have "θ' ⋅ (φ ⋆ w') ⋅ (f ⋆ γ) ⋅ (inv φ ⋆ w) = θ' ⋅ (φ ⋆ w') ⋅ (f ⋅ inv φ ⋆ γ ⋅ w)"
using γ assms(1-2) interchange
by (metis arr_inv cod_inv in_homE leg0_simps(2) leg0_simps(4) uwθ.w_in_hom(2)
seqI)
also have "... = θ' ⋅ (φ ⋅ f ⋅ inv φ ⋆ w' ⋅ γ ⋅ w)"
using assms(1-2) interchange
by (metis γ arr_inv cod_inv comp_arr_dom comp_cod_arr in_homE seqI)
also have "... = θ' ⋅ (f' ⋆ γ)"
proof -
have "φ ⋅ f ⋅ inv φ = f'"
using assms(1-2) comp_cod_arr comp_arr_inv' by auto
moreover have "w' ⋅ γ ⋅ w = γ"
using γ comp_arr_dom comp_cod_arr by auto
ultimately show ?thesis by simp
qed
finally show "θ' ⋅ (φ ⋆ w') ⋅ (f ⋆ γ) ⋅ (inv φ ⋆ w) = θ' ⋅ (f' ⋆ γ)" by simp
qed
obtain γ where γ: "«γ : w ⇒ w'» ∧ β = g ⋆ γ ∧
θ ⋅ (φ ⋆ w) = (θ' ⋅ (φ ⋆ w')) ⋅ (f ⋆ γ)"
using * by blast
have "θ = θ' ⋅ (φ ⋆ w') ⋅ (f ⋆ γ) ⋅ (inv φ ⋆ w)"
proof -
have "seq (θ' ⋅ (φ ⋆ w')) (f ⋆ γ)"
using assms(2) φ_w φ_w' γ β θ
apply (intro seqI)
apply auto
by (metis seqE seqI')
thus ?thesis
using assms φ_w γ comp_assoc invert_side_of_triangle(2) iso_hcomp
by (metis hcomp_in_vhomE ide_is_iso inv_hcomp inv_ide w)
qed
hence "θ = θ' ⋅ (f' ⋆ γ)"
using γ ** by simp
hence "∃γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f' ⋆ γ)"
using γ by auto
moreover have "⋀γ γ'. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f' ⋆ γ) ∧
«γ' : w ⇒ w'» ∧ β = g ⋆ γ' ∧ θ = θ' ⋅ (f' ⋆ γ')
⟹ γ = γ'"
proof -
fix γ γ'
assume A: "«γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f' ⋆ γ) ∧
«γ' : w ⇒ w'» ∧ β = g ⋆ γ' ∧ θ = θ' ⋅ (f' ⋆ γ')"
have "θ ⋅ (φ ⋆ w) = (θ' ⋅ (φ ⋆ w')) ⋅ (f ⋆ γ)"
proof -
have "θ = ((θ' ⋅ (φ ⋆ w')) ⋅ (f ⋆ γ)) ⋅ (inv φ ⋆ 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 "θ ⋅ (φ ⋆ w) = (θ' ⋅ (φ ⋆ w')) ⋅ (f ⋆ γ')"
proof -
have "θ = ((θ' ⋅ (φ ⋆ w')) ⋅ (f ⋆ γ')) ⋅ (inv φ ⋆ 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 "γ = γ'"
using A * by blast
qed
ultimately show "∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f' ⋆ γ)"
by metis
qed
qed
qed
qed
qed
text ‹
Similarly, tabulations are preserved under composition of an isomorphism with
the ``output leg''.
›
lemma preserved_by_output_iso:
assumes "«φ : g' ⇒ g»" and "iso φ"
shows "tabulation V H 𝖺 𝗂 src trg r (ρ ⋅ φ) f g'"
proof -
have τφ: "«ρ ⋅ φ : g' ⇒ r ⋆ f»"
using assms by auto
interpret T': tabulation_data V H 𝖺 𝗂 src trg r ‹ρ ⋅ φ› f g'
using assms(2) τφ by (unfold_locales, auto)
have φ_in_hhom: "«φ : src f → trg r»"
using assms src_cod [of φ] trg_cod [of φ]
by (elim in_homE, simp)
show ?thesis
proof
fix u ω
assume u: "ide u" and ω: "«ω : dom ω ⇒ r ⋆ u»"
show "∃w θ ν'. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν' : dom ω ⇒ g' ⋆ w» ∧ iso ν' ∧
T'.composite_cell w θ ⋅ ν' = ω"
proof -
obtain w θ ν where wθν: "ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω ⇒ g ⋆ w» ∧
iso ν ∧ composite_cell w θ ⋅ ν = ω"
using u ω T1 [of u ω] by auto
interpret uwθων: uwθων V H 𝖺 𝗂 src trg r ρ f g u w θ ω ν
using wθν comp_assoc by (unfold_locales, auto)
let ?ν' = "(inv φ ⋆ w) ⋅ ν"
have ν': "«?ν' : dom ω ⇒ g' ⋆ w»"
using assms φ_in_hhom uwθων.ν_in_hom
by (intro comp_in_homI, auto)
moreover have "iso ?ν'"
using assms ν' wθν φ_in_hhom
by (intro iso_hcomp isos_compose) auto
moreover have "T'.composite_cell w θ ⋅ ?ν' = ω"
proof -
have "composite_cell w θ ⋅ ((φ ⋆ w) ⋅ ?ν') = ω"
proof -
have "(φ ⋆ w) ⋅ ?ν' = ν"
using assms ν' φ_in_hhom whisker_right comp_cod_arr comp_assoc
by (metis comp_arr_inv' in_homE leg1_simps(2) uwθων.uwθων)
thus ?thesis
using wθν by simp
qed
moreover have "(ρ ⋅ φ ⋆ w) ⋅ ?ν' = (ρ ⋆ w) ⋅ ((φ ⋆ w) ⋅ ?ν')"
using assms φ_in_hhom whisker_right comp_assoc by simp
ultimately show ?thesis
using comp_assoc by simp
qed
ultimately show ?thesis
using wθν by blast
qed
next
fix u w w' θ θ' β'
assume w: "ide w" and w': "ide w'"
and θ: "«θ : f ⋆ w ⇒ u»" and θ': "«θ' : f ⋆ w' ⇒ u»"
and β': "«β' : g' ⋆ w ⇒ g' ⋆ w'»"
and eq': "T'.composite_cell w θ = T'.composite_cell w' θ' ⋅ β'"
interpret uwθw'θ'β: uwθw'θ'β V H 𝖺 𝗂 src trg r ‹ρ ⋅ φ› f g' u w θ w' θ' β'
using assms w w' θ θ' β' eq' comp_assoc by (unfold_locales, auto)
let ?β = "(φ ⋆ w') ⋅ β' ⋅ (inv φ ⋆ w)"
have β: "«?β : g ⋆ w ⇒ g ⋆ w'»"
using assms φ_in_hhom β'
by (intro comp_in_homI hcomp_in_vhom, auto)
have eq: "composite_cell w θ = composite_cell w' θ' ⋅ ((φ ⋆ w') ⋅ β' ⋅ (inv φ ⋆ w))"
proof -
have "composite_cell w θ = (r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ ((ρ ⋆ w) ⋅ (φ ⋆ w)) ⋅ (inv φ ⋆ w)"
proof -
have "ρ ⋆ w = (ρ ⋆ w) ⋅ (φ ⋆ w) ⋅ (inv φ ⋆ w)"
using assms w φ_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 θ ⋅ (inv φ ⋆ w)"
using assms φ_in_hhom whisker_right comp_assoc by simp
also have "... = T'.composite_cell w' θ' ⋅ (β' ⋅ (inv φ ⋆ w))"
using eq' comp_assoc by simp
also have "... = composite_cell w' θ' ⋅ ((φ ⋆ w') ⋅ β' ⋅ (inv φ ⋆ w))"
using assms φ_in_hhom whisker_right comp_assoc by simp
finally show ?thesis by simp
qed
show "∃!γ. «γ : w ⇒ w'» ∧ β' = g' ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
proof -
obtain γ where γ: "«γ : w ⇒ w'» ∧ ?β = g ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
using assms w w' θ θ' β eq φ_in_hhom T2 [of w w' θ u θ' ?β] by auto
have "β' = g' ⋆ γ"
proof -
have "g ⋆ γ = (φ ⋆ w') ⋅ β' ⋅ (inv φ ⋆ w)"
using γ by simp
hence "(inv φ ⋆ w') ⋅ (g ⋆ γ) = β' ⋅ (inv φ ⋆ w)"
using assms w' β φ_in_hhom invert_side_of_triangle arrI iso_hcomp
hseqE ide_is_iso inv_hcomp inv_ide seqE
by metis
hence "β' = (inv φ ⋆ w') ⋅ (g ⋆ γ) ⋅ (φ ⋆ w)"
using assms w β φ_in_hhom invert_side_of_triangle comp_assoc seqE
by (metis comp_arr_dom in_homE local.uwθw'θ'β.β_simps(4) whisker_right)
also have "... = (inv φ ⋆ w') ⋅ (φ ⋆ γ)"
using assms φ_in_hhom γ interchange comp_arr_dom comp_cod_arr
by (metis in_homE)
also have "... = g' ⋆ γ"
using assms φ_in_hhom γ interchange comp_inv_arr inv_is_inverse comp_cod_arr
by (metis arr_dom calculation in_homE)
finally show ?thesis by simp
qed
hence "∃γ. «γ : w ⇒ w'» ∧ β' = g' ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
using β γ by auto
moreover have "⋀γ γ'. ⟦ «γ : w ⇒ w'» ∧ β' = g' ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ);
«γ' : w ⇒ w'» ∧ β' = g' ⋆ γ' ∧ θ = θ' ⋅ (f ⋆ γ') ⟧ ⟹ γ = γ'"
proof -
have *: "⋀γ. «γ : w ⇒ w'» ⟹ (φ ⋆ w') ⋅ (g' ⋆ γ) ⋅ (inv φ ⋆ w) = g ⋆ γ"
proof -
fix γ
assume γ: "«γ : w ⇒ w'»"
have "(φ ⋆ w') ⋅ (g' ⋆ γ) ⋅ (inv φ ⋆ w) = (φ ⋆ w') ⋅ (inv φ ⋆ γ)"
using assms φ_in_hhom γ interchange comp_arr_dom comp_cod_arr
by (metis arr_dom comp_inv_arr' in_homE invert_side_of_triangle(2))
also have "... = g ⋆ γ"
using assms φ_in_hhom interchange comp_arr_inv inv_is_inverse comp_cod_arr
by (metis γ comp_arr_inv' in_homE leg1_simps(2))
finally show "(φ ⋆ w') ⋅ (g' ⋆ γ) ⋅ (inv φ ⋆ w) = g ⋆ γ" by blast
qed
fix γ γ'
assume γ: "«γ : w ⇒ w'» ∧ β' = g' ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
and γ': "«γ' : w ⇒ w'» ∧ β' = g' ⋆ γ' ∧ θ = θ' ⋅ (f ⋆ γ')"
show "γ = γ'"
using w w' θ θ' β γ γ' eq * T2 by metis
qed
ultimately show "∃!γ. «γ : w ⇒ w'» ∧ β' = g' ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)" by blast
qed
qed
qed
text ‹
Finally, tabulations are preserved by composition with an isomorphism on the ``base''.
›
lemma is_preserved_by_base_iso:
assumes "«φ : r ⇒ r'»" and "iso φ"
shows "tabulation V H 𝖺 𝗂 src trg r' ((φ ⋆ f) ⋅ ρ) f g"
proof -
have φf: "«φ ⋆ f : r ⋆ f ⇒ r' ⋆ f»"
using assms ide_leg0 by auto
interpret T: tabulation_data V H 𝖺 𝗂 src trg r' ‹(φ ⋆ f) ⋅ ρ› f
proof
show ide_r': "ide r'" using assms by auto
show "ide f" using ide_leg0 by auto
show "«(φ ⋆ f) ⋅ ρ : g ⇒ r' ⋆ f»"
using tab_in_hom φf by force
qed
show ?thesis
proof
have *: "⋀u v w θ ν. ⟦ ide u; ide v; ide w; «θ : f ⋆ w ⇒ u»; «ν : v ⇒ g ⋆ w» ⟧ ⟹
((φ ⋆ u) ⋅ (r ⋆ θ)) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν =
T.composite_cell w θ ⋅ ν"
proof -
fix u v w θ ν
assume u: "ide u" and v: "ide v" and w: "ide w"
and θ: "«θ : f ⋆ w ⇒ u»" and ν: "«ν : v ⇒ g ⋆ w»"
have fw: "hseq f w"
using θ ide_dom [of θ] by fastforce
have rθ: "hseq r θ"
using θ ide_base ide_dom [of θ] trg_dom [of θ]
using arrI fw vconn_implies_hpar(2) by auto
have "((φ ⋆ u) ⋅ (r ⋆ θ)) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν =
((r' ⋆ θ) ⋅ (φ ⋆ f ⋆ w)) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν"
using assms u w ide_base ide_leg0 θ interchange comp_arr_dom comp_cod_arr
by (metis rθ hseq_char in_homE)
also have "... = (r' ⋆ θ) ⋅ ((φ ⋆ f ⋆ w) ⋅ 𝖺[r, f, w]) ⋅ (ρ ⋆ w) ⋅ ν"
using comp_assoc by simp
also have "... = (r' ⋆ θ) ⋅ 𝖺[r', f, w] ⋅ (((φ ⋆ f) ⋆ w) ⋅ (ρ ⋆ w)) ⋅ ν"
proof -
have "(φ ⋆ f ⋆ w) ⋅ 𝖺[r, f, w] = 𝖺[r', f, w] ⋅ ((φ ⋆ f) ⋆ w)"
using assms ide_leg0 w assoc_naturality [of φ f w] fw by fastforce
thus ?thesis
using comp_assoc by simp
qed
also have "... = T.composite_cell w θ ⋅ ν"
using assms ide_leg0 whisker_right fw T.tab_in_hom arrI w comp_assoc by auto
finally show "((φ ⋆ u) ⋅ (r ⋆ θ)) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν = T.composite_cell w θ ⋅ ν"
by simp
qed
show "⋀u ω'. ⟦ ide u; «ω' : dom ω' ⇒ r' ⋆ u» ⟧ ⟹
∃w θ ν. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : dom ω' ⇒ g ⋆ w» ∧ iso ν ∧
T.composite_cell w θ ⋅ ν = ω'"
proof -
fix u v ω'
assume u: "ide u" and ω': "«ω' : v ⇒ r' ⋆ u»"
have ω: "«(inv φ ⋆ u) ⋅ ω' : v ⇒ r ⋆ u»"
proof
show "«ω' : v ⇒ r' ⋆ u»" by fact
show "«inv φ ⋆ u : r' ⋆ u ⇒ r ⋆ u»"
proof -
have "ide (r' ⋆ u)"
using ω' ide_cod by fastforce
hence "hseq r' u" by simp
thus ?thesis
using assms u by auto
qed
qed
have φu: "hseq φ u"
using assms ω hseqI
by (metis arrI ide_is_iso iso_hcomp iso_is_arr seqE seq_if_composable
src_inv u)
obtain w θ ν where wθν: "ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : v ⇒ g ⋆ w» ∧ iso ν ∧
composite_cell w θ ⋅ ν = (inv φ ⋆ u) ⋅ ω'"
using u ω T1 [of u "(inv φ ⋆ u) ⋅ ω'"] φf in_homE seqI' by auto
interpret uwθων V H 𝖺 𝗂 src trg r ρ f g u w θ ‹(inv φ ⋆ u) ⋅ ω'› ν
using wθν ω comp_assoc by (unfold_locales, auto)
have "ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : v ⇒ g ⋆ w» ∧ iso ν ∧
T.composite_cell w θ ⋅ ν = ω'"
proof -
have "ω' = ((φ ⋆ u) ⋅ (r ⋆ θ)) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν"
proof -
have "seq (r ⋆ θ) (𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ ν)" by fastforce
moreover have "iso (inv φ ⋆ u)"
using assms u φu by auto
moreover have "inv (inv φ ⋆ u) = φ ⋆ u"
using assms u φu by auto
ultimately show ?thesis
using invert_side_of_triangle(1) wθν comp_assoc by metis
qed
also have "... = T.composite_cell w θ ⋅ ν"
using u wθν * [of u v w θ ν] by force
finally have "ω' = T.composite_cell w θ ⋅ ν" by simp
thus ?thesis
using wθν by simp
qed
thus "∃w θ ν. ide w ∧ «θ : f ⋆ w ⇒ u» ∧ «ν : v ⇒ g ⋆ w» ∧ iso ν ∧
T.composite_cell w θ ⋅ ν = ω'"
by blast
qed
show "⋀u w w' θ θ' β. ⟦ ide w; ide w'; «θ : f ⋆ w ⇒ u»; «θ' : f ⋆ w' ⇒ u»;
«β : g ⋆ w ⇒ g ⋆ w'»;
T.composite_cell w θ = T.composite_cell w' θ' ⋅ β ⟧ ⟹
∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
proof -
fix u w w' θ θ' β
assume w: "ide w" and w': "ide w'"
and θ: "«θ : f ⋆ w ⇒ u»" and θ': "«θ' : f ⋆ w' ⇒ u»"
and β: "«β : g ⋆ w ⇒ g ⋆ w'»"
and eq': "T.composite_cell w θ = T.composite_cell w' θ' ⋅ β"
interpret T: uwθw'θ'β V H 𝖺 𝗂 src trg r' ‹(φ ⋆ f) ⋅ ρ› f g u w θ w' θ' β
using w w' θ θ' β eq' comp_assoc
by (unfold_locales, auto)
have eq: "composite_cell w θ = composite_cell w' θ' ⋅ β"
proof -
have "(φ ⋆ u) ⋅ composite_cell w θ = (φ ⋆ u) ⋅ composite_cell w' θ' ⋅ β"
proof -
have "(φ ⋆ u) ⋅ composite_cell w θ =
((φ ⋆ u) ⋅ (r ⋆ θ)) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w) ⋅ (g ⋆ w)"
proof -
have "«ρ ⋆ w : g ⋆ w ⇒ (r ⋆ f) ⋆ w»"
using w by auto
thus ?thesis
using comp_arr_dom comp_assoc by auto
qed
also have "... = T.composite_cell w θ ⋅ (g ⋆ w)"
using * [of u "g ⋆ w" w θ "g ⋆ w"] by fastforce
also have "... = T.composite_cell w θ"
proof -
have "«(φ ⋆ f) ⋅ ρ ⋆ w : g ⋆ w ⇒ (r' ⋆ f) ⋆ w»"
using assms by fastforce
thus ?thesis
using comp_arr_dom comp_assoc by auto
qed
also have "... = T.composite_cell w' θ' ⋅ β"
using eq' by simp
also have "... = ((φ ⋆ u) ⋅ (r ⋆ θ')) ⋅ 𝖺[r, f, w'] ⋅ (ρ ⋆ w') ⋅ β"
using * [of u "g ⋆ w" w' θ' β] by fastforce
finally show ?thesis
using comp_assoc by simp
qed
moreover have "iso (φ ⋆ u)"
using assms by auto
moreover have "seq (φ ⋆ u) ((r ⋆ θ) ⋅ 𝖺[r, f, w] ⋅ (ρ ⋆ w))"
proof -
have "«φ ⋆ u : r ⋆ u ⇒ r' ⋆ u»"
using assms by (intro hcomp_in_vhom, auto)
thus ?thesis
using composite_cell_in_hom [of w u θ] by auto
qed
moreover have "seq (φ ⋆ u) (composite_cell w' θ' ⋅ β)"
using assms ide_leg0 w w' θ θ' β calculation(1) calculation(3) by auto
ultimately show ?thesis
using monoE section_is_mono iso_is_section by metis
qed
show "∃!γ. «γ : w ⇒ w'» ∧ β = g ⋆ γ ∧ θ = θ' ⋅ (f ⋆ γ)"
using w w' θ θ' β eq T2 by simp
qed
qed
qed
end
subsection "Canonical Tabulations"
text ‹
If the 1-cell ‹g ⋆ f⇧*› has any tabulation ‹(f, ρ, g)›, then it has the canonical
tabulation obtained as the adjoint transpose of (the identity on) ‹g ⋆ f⇧*›.
›
context map_in_bicategory
begin
lemma canonical_tabulation:
assumes "ide g" and "src f = src g"
and "∃ρ. tabulation V H 𝖺 𝗂 src trg (g ⋆ f⇧*) ρ f g"
shows "tabulation V H 𝖺 𝗂 src trg (g ⋆ f⇧*) (trnr⇩η g (g ⋆ f⇧*)) f g"
proof -
have 1: "ide (g ⋆ f⇧*)"
using assms(1-2) ide_right antipar by simp
obtain ρ where ρ: "tabulation V H 𝖺 𝗂 src trg (g ⋆ f⇧*) ρ f g"
using assms(3) by auto
interpret ρ: tabulation V H 𝖺 𝗂 src trg ‹g ⋆ f⇧*› ρ f g
using ρ by auto
let ?ψ = "trnr⇩ε (g ⋆ f⇧*) ρ"
have 3: "«?ψ : g ⋆ f⇧* ⇒ g ⋆ f⇧*» ∧ iso ?ψ"
using ρ.yields_isomorphic_representation by blast
hence "tabulation (⋅) (⋆) 𝖺 𝗂 src trg (g ⋆ f⇧*) ((inv ?ψ ⋆ f) ⋅ ρ) f g"
using ρ.is_preserved_by_base_iso [of "inv ?ψ" "g ⋆ f⇧*"] by simp
moreover have "(inv ?ψ ⋆ f) ⋅ ρ = trnr⇩η g (g ⋆ f⇧*)"
proof -
have "(inv ?ψ ⋆ f) ⋅ ρ = ((inv ?ψ ⋆ f) ⋅ (?ψ ⋆ f)) ⋅ trnr⇩η g (g ⋆ f⇧*)"
using ρ.ρ_in_terms_of_rep comp_assoc by simp
also have "... = ((g ⋆ f⇧*) ⋆ f) ⋅ trnr⇩η g (g ⋆ f⇧*)"
proof -
have "src (inv ?ψ) = trg f"
using 3 antipar
by (metis ρ.leg0_simps(3) ρ.base_in_hom(2) seqI' src_inv vseq_implies_hpar(1))
hence "(inv ?ψ ⋆ f) ⋅ (?ψ ⋆ f) = (g ⋆ f⇧*) ⋆ f"
using 3 whisker_right [of f "inv ?ψ" ?ψ] inv_is_inverse comp_inv_arr by auto
thus ?thesis
using comp_cod_arr by simp
qed
also have "... = trnr⇩η g (g ⋆ f⇧*)"
proof -
have "src (g ⋆ f⇧*) = trg f" by simp
moreover have "ide g" by simp
ultimately have "«trnr⇩η g (g ⋆ f⇧*) : g ⇒ (g ⋆ f⇧*) ⋆ f»"
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 ‹
We now intend to show that a tabulation of ‹r› 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 ‹(f, ρ)› and ‹(f', ρ')› of the same 1-cell ‹r›, then this
induces ‹«w : src f' → src f»›, ‹«w' : src f → src f'»›, ‹«θ : f ⋆ w ⇒ f'»›, and
‹«θ : f ⋆ w ⇒ f'»›, such that ‹ρ'› is recovered up to isomorphism ‹«ν : g' ⇒ g ⋆ w»›
from ‹(w, θ)› by composition with ‹ρ› and ‹ρ› is recovered up to isomorphism
‹«ν' : g ⇒ g' ⋆ w'»› from ‹(w', θ')› by composition with ‹ρ'›.
This means that we obtain isomorphisms ‹«(ν' ⋆ w') ⋅ ν : g' ⇒ g' ⋆ w' ⋆ w»› and
‹«(ν ⋆ w') ⋅ ν' : g ⇒ g ⋆ w ⋆ w'»›.
These isomorphisms then induce, via ‹T2›, unique 2-cells from ‹src f'› to ‹w' ⋆ w›
and from ‹src f› to ‹w ⋆ w'›, which must be isomorphisms, thus showing ‹w› and ‹w'› are
equivalence maps.
›
context tabulation
begin
text ‹
We will need the following technical lemma.
›
lemma apex_equivalence_lemma:
assumes "«ρ' : g' ⇒ r ⋆ f'»"
and "ide w ∧ «θ : f' ⋆ w ⇒ f» ∧ «ν : g ⇒ g' ⋆ w» ∧ iso ν ∧
(r ⋆ θ) ⋅ 𝖺[r, f', w] ⋅ (ρ' ⋆ w) ⋅ ν = ρ"
and "ide w' ∧ «θ' : f ⋆ w' ⇒ f'» ∧ «ν' : g' ⇒ g ⋆ w'» ∧ iso ν' ∧
(r ⋆ θ') ⋅ 𝖺[r, f, w'] ⋅ (ρ ⋆ w') ⋅ ν' = ρ'"
shows "∃φ. «φ : src f ⇒ w' ⋆ w» ∧ iso φ"
proof -
interpret T': uwθων V H 𝖺 𝗂 src trg r ρ f g f' w' θ' ρ' ν'
using assms(1,3) apply unfold_locales by auto
interpret T: tabulation_data V H 𝖺 𝗂 src trg r ρ' f' g'
using assms(1,2) apply unfold_locales by auto
interpret T: uwθων V H 𝖺 𝗂 src trg r ρ' f' g' f w θ ρ ν
using assms(1,2) apply unfold_locales by auto
have dom_ν [simp]: "dom ν = dom ρ"
using assms(2) by auto
have dom_ν' [simp]: "dom ν' = dom ρ'"
using assms(3) by auto
let ?ν'ν = "𝖺[dom ρ, w', w] ⋅ (ν' ⋆ w) ⋅ ν"
have ν'ν: "«?ν'ν : dom ρ ⇒ dom ρ ⋆ w' ⋆ w»"
by fastforce
have "«ν : src ρ → trg r»" by simp
let ?θθ' = "θ ⋅ (θ' ⋆ w) ⋅ 𝖺⇧-⇧1[f, w', w]"
have θθ': "«?θθ' : f ⋆ w' ⋆ w ⇒ f»"
by fastforce
have iso_ν'ν_r: "iso (?ν'ν ⋅ 𝗋[g])"
using iso_runit ν'ν
apply (intro isos_compose) by auto
have eq: "composite_cell (src f) 𝗋[f] = composite_cell (w' ⋆ w) ?θθ' ⋅ (?ν'ν ⋅ 𝗋[g])"
proof -
have "composite_cell (w' ⋆ w) ?θθ' ⋅ (?ν'ν ⋅ 𝗋[g]) =
((r ⋆ θ) ⋅ (r ⋆ θ' ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, w', w])) ⋅
𝖺[r, f, w' ⋆ w] ⋅ ((ρ ⋆ w' ⋆ w) ⋅ 𝖺[g, w', w]) ⋅ (ν' ⋆ w) ⋅ ν ⋅ 𝗋[g]"
using whisker_left comp_assoc by simp
also have "... = ((r ⋆ θ) ⋅ (r ⋆ θ' ⋆ w) ⋅ (r ⋆ 𝖺⇧-⇧1[f, w', w])) ⋅
𝖺[r, f, w' ⋆ w] ⋅ (𝖺[r ⋆ f, w', w] ⋅
((ρ ⋆ w') ⋆ w)) ⋅ (ν' ⋆ w) ⋅ ν ⋅ 𝗋[g]"
using assoc_naturality [of ρ w' w] by simp
also have "... = (r ⋆ θ) ⋅ (r ⋆ θ' ⋆ w) ⋅
((r ⋆ 𝖺⇧-⇧1[f, w', w]) ⋅ 𝖺[r, f, w' ⋆ w] ⋅ 𝖺[r ⋆ f, w', w]) ⋅
((ρ ⋆ w') ⋆ w) ⋅ (ν' ⋆ w) ⋅ ν ⋅ 𝗋[g]"
using comp_assoc by simp
also have "... = (r ⋆ θ) ⋅ ((r ⋆ θ' ⋆ w) ⋅ 𝖺[r, f ⋆ w', w]) ⋅
(𝖺[r, f, w'] ⋆ w) ⋅
((ρ ⋆ w') ⋆ w) ⋅ (ν' ⋆ w) ⋅ ν ⋅ 𝗋[g]"
proof -
have "seq 𝖺[r, f, w' ⋆ w] 𝖺[r ⋆ f, w', w]" by simp
moreover have "inv (r ⋆ 𝖺[f, w', w]) = r ⋆ 𝖺⇧-⇧1[f, w', w]"
by simp
moreover have "(r ⋆ 𝖺[f, w', w]) ⋅ 𝖺[r, f ⋆ w', w] ⋅ (𝖺[r, f, w'] ⋆ w) =
𝖺[r, f, w' ⋆ w] ⋅ 𝖺[r ⋆ f, w', w]"
using pentagon by simp
ultimately have "(r ⋆ 𝖺⇧-⇧1[f, w', w]) ⋅ 𝖺[r, f, w' ⋆ w] ⋅ 𝖺[r ⋆ f, w', w] =
𝖺[r, f ⋆ w', w] ⋅ (𝖺[r, f, w'] ⋆ w)"
using iso_assoc [of f w' w] iso_hcomp
invert_side_of_triangle(1)
[of "𝖺[r, f, w' ⋆ w] ⋅ 𝖺[r ⋆ f, w', w]" "r ⋆ 𝖺[f, w', w]"
"𝖺[r, f ⋆ w', w] ⋅ (𝖺[r, f, w'] ⋆ w)"]
by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (r ⋆ θ) ⋅ 𝖺[r, f', w] ⋅
(((r ⋆ θ') ⋆ w) ⋅ (𝖺[r, f, w'] ⋆ w) ⋅ ((ρ ⋆ w') ⋆ w)) ⋅
(ν' ⋆ w) ⋅ ν ⋅ 𝗋[g]"
proof -
have "(r ⋆ θ' ⋆ w) ⋅ 𝖺[r, f ⋆ w', w] = 𝖺[r, f', w] ⋅ ((r ⋆ θ') ⋆ w)"
using assoc_naturality [of r θ' w] by simp
thus ?thesis
using comp_assoc by simp
qed
also have "... = (r ⋆ θ) ⋅ 𝖺[r, f', w] ⋅ (composite_cell w' θ' ⋆ w) ⋅ (ν' ⋆ w) ⋅ ν ⋅ 𝗋[g]"
using whisker_right
by (metis T'.uwθω T'.w_in_hom(1) composite_cell_in_hom T'.θ_simps(2) T'.ide_w
T.ide_w arrI seqE)
also have "... = (r ⋆ θ) ⋅ 𝖺[r, f', w] ⋅ ((ρ' ⋅ inv ν' ⋆ w) ⋅ (ν' ⋆ w)) ⋅ ν ⋅ 𝗋[g]"
proof -
have "composite_cell w' θ' = ρ' ⋅ inv ν'"
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 θ ⋅ ν) ⋅ 𝗋[g]"
using whisker_right [of w "ρ' ⋅ inv ν'" ν'] dom_ν' comp_assoc comp_inv_arr'
comp_arr_dom
by simp
also have "... = ρ ⋅ 𝗋[g]"
using assms(2) comp_assoc by simp
also have "... = composite_cell (src f) 𝗋[f]"
using comp_assoc runit_hcomp runit_naturality [of ρ] by simp
finally show ?thesis by simp
qed
have eq': "(r ⋆ 𝗋[f]) ⋅ 𝖺[r, f, src f] ⋅ (ρ ⋆ src f) ⋅ (inv (?ν'ν ⋅ 𝗋[g])) =
composite_cell (w' ⋆ w) ?θθ'"
proof -
have 1: "composite_cell (src f) 𝗋[f] = (composite_cell (w' ⋆ w) ?θθ') ⋅ ?ν'ν ⋅ 𝗋[g]"
using eq comp_assoc by simp
have "composite_cell (src f) 𝗋[f] ⋅ (inv (?ν'ν ⋅ 𝗋[g])) = composite_cell (w' ⋆ w) ?θθ'"
proof -
have "seq (r ⋆ 𝗋[f]) (𝖺[r, f, src f] ⋅ (ρ ⋆ src f))"
by fastforce
thus ?thesis
using iso_ν'ν_r 1 invert_side_of_triangle(2) by simp
qed
thus ?thesis
using comp_assoc by simp
qed
have ν'ν_r: "«?ν'ν ⋅ 𝗋[g] : g ⋆ src f ⇒ g ⋆ w' ⋆ w»"
by force
have inv_ν'ν_r: "«inv (?ν'ν ⋅ 𝗋[g]) : g ⋆ w' ⋆ w ⇒ g ⋆ src f»"
using ν'ν iso_ν'ν_r by auto
let ?P = "λγ. «γ : src f ⇒ w' ⋆ w» ∧ ?ν'ν ⋅ 𝗋[g] = dom ρ ⋆ γ ∧ 𝗋[f] = ?θθ' ⋅ (f ⋆ γ)"
let ?γ = "THE γ. ?P γ"
have "?P ?γ"
proof -
have "∃!γ. ?P γ"
using ν'ν_r θθ' eq T2 [of "src f" "w' ⋆ w" "𝗋[f]" f ?θθ' "?ν'ν ⋅ 𝗋[g]"] by simp
thus ?thesis
using the1_equality [of ?P] by blast
qed
hence γ: "«?γ : src f → src f» ∧ ?P ?γ"
using vconn_implies_hpar(1-2) by auto
let ?P' = "λγ. «γ : w' ⋆ w ⇒ src f» ∧ inv (?ν'ν ⋅ 𝗋[g]) = g ⋆ γ ∧ ?θθ' = 𝗋[f] ⋅ (f ⋆ γ)"
let ?γ' = "THE γ. ?P' γ"
have "?P' ?γ'"
proof -
have "∃!γ. ?P' γ"
using inv_ν'ν_r θθ' eq'
T2 [of "w' ⋆ w" "src f" "θ ⋅ (θ' ⋆ w) ⋅ 𝖺⇧-⇧1[f, w', w]" f] comp_assoc
by simp
thus ?thesis
using the1_equality [of ?P'] by blast
qed
hence γ': "«?γ' : src f → src f» ∧ ?P' ?γ'"
using vconn_implies_hpar(1-2) by auto
have "inverse_arrows ?γ ?γ'"
proof
let ?Q = "λγ. «γ : src f ⇒ src f» ∧ dom ρ ⋆ src f = g ⋆ γ ∧ 𝗋[f] = 𝗋[f] ⋅ (f ⋆ γ)"
have "∃!γ. ?Q γ"
proof -
have "ide (src f)" by simp
moreover have "«𝗋[f] : f ⋆ src f ⇒ f»" by simp
moreover have "«dom ρ ⋆ src f : g ⋆ src f ⇒ g ⋆ src f»" by auto
moreover have "(ρ ⋆ src f) ⋅ (dom ρ ⋆ src f) = ρ ⋆ src f"
proof -
have "(ρ ⋆ src ρ) ⋅ (dom ρ ⋆ src (dom ρ)) = ρ ⋆ src ρ"
using R.as_nat_trans.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" "𝗋[f]" f "𝗋[f]" "dom ρ ⋆ src f"]
comp_assoc
by metis
qed
moreover have "?Q (src f)"
using comp_arr_dom by auto
moreover have "?Q (?γ' ⋅ ?γ)"
proof (intro conjI)
show "«?γ' ⋅ ?γ : src f ⇒ src f»"
using γ γ' by auto
show "dom ρ ⋆ src f = g ⋆ ?γ' ⋅ ?γ"
proof -
have "g ⋆ ?γ' ⋅ ?γ = (g ⋆ ?γ') ⋅ (g ⋆ ?γ)"
using γ γ' whisker_left by fastforce
also have "... = inv (?ν'ν ⋅ 𝗋[g]) ⋅ (?ν'ν ⋅ 𝗋[g])"
using γ γ' by simp
also have "... = dom ρ ⋆ src f"
using ν'ν iso_ν'ν_r comp_inv_arr inv_is_inverse by auto
finally show ?thesis by simp
qed
show "𝗋[f] = 𝗋[f] ⋅ (f ⋆ ?γ' ⋅ ?γ)"
proof -
have "𝗋[f] ⋅ (f ⋆ ?γ' ⋅ ?γ) = 𝗋[f] ⋅ (f ⋆ ?γ') ⋅ (f ⋆ ?γ)"
using γ γ' whisker_left by fastforce
also have "... = (𝗋[f] ⋅ (f ⋆ ?γ')) ⋅ (f ⋆ ?γ)"
using comp_assoc by simp
also have "... = 𝗋[f]"
using γ γ' by simp
finally show ?thesis by simp
qed
qed
ultimately have "?γ' ⋅ ?γ = src f" by blast
thus "ide (?γ' ⋅ ?γ)" by simp
let ?Q' = "λγ. «γ : w' ⋆ w ⇒ w' ⋆ w» ∧ g ⋆ w' ⋆ w = g ⋆ γ ∧ ?θθ' = ?θθ' ⋅ (f ⋆ γ)"
have "∃!γ. ?Q' γ"
proof -
have "ide (w' ⋆ w)" by simp
moreover have "«?θθ' : f ⋆ w' ⋆ w ⇒ f»"
using θθ' by simp
moreover have "«g ⋆ w' ⋆ w : g ⋆ w' ⋆ w ⇒ g ⋆ w' ⋆ w»"
by auto
moreover have
"composite_cell (w' ⋆ w) ?θθ' = composite_cell (w' ⋆ w) ?θθ' ⋅ (g ⋆ w' ⋆ w)"
proof -
have "«ρ ⋆ w' ⋆ w : g ⋆ w' ⋆ w ⇒ (r ⋆ f) ⋆ w' ⋆ w»"
by (intro hcomp_in_vhom, auto)
hence "(ρ ⋆ w' ⋆ w) ⋅ (g ⋆ w' ⋆ w) = ρ ⋆ w' ⋆ w"
using comp_arr_dom by auto
thus ?thesis
using comp_assoc by simp
qed
ultimately show ?thesis
using T2 by presburger
qed
moreover have "?Q' (w' ⋆ w)"
using θθ' comp_arr_dom by auto
moreover have "?Q' (?γ ⋅ ?γ')"
proof (intro conjI)
show "«?γ ⋅ ?γ' : w' ⋆ w ⇒ w' ⋆ w»"
using γ γ' by auto
show "g ⋆ w' ⋆ w = g ⋆ ?γ ⋅ ?γ'"
proof -
have "g ⋆ ?γ ⋅ ?γ' = (g ⋆ ?γ) ⋅ (g ⋆ ?γ')"
using γ γ' whisker_left by fastforce
also have "... = (?ν'ν ⋅ 𝗋[g]) ⋅ inv (?ν'ν ⋅ 𝗋[g])"
using γ γ' by simp
also have "... = g ⋆ w' ⋆ w"
using ν'ν iso_ν'ν_r comp_arr_inv inv_is_inverse by auto
finally show ?thesis by simp
qed
show "?θθ' = ?θθ' ⋅ (f ⋆ ?γ ⋅ ?γ')"
proof -
have "?θθ' ⋅ (f ⋆ ?γ ⋅ ?γ') = ?θθ' ⋅ (f ⋆ ?γ) ⋅ (f ⋆ ?γ')"
using γ γ' whisker_left by fastforce
also have "... = (?θθ' ⋅ (f ⋆ ?γ)) ⋅ (f ⋆ ?γ')"
using comp_assoc by simp
also have "... = ?θθ'"
using γ γ' by simp
finally show ?thesis by simp
qed
qed
ultimately have "?γ ⋅ ?γ' = w' ⋆ w" by blast
thus "ide (?γ ⋅ ?γ')" by simp
qed
hence "«?γ : src f ⇒ w' ⋆ w» ∧ iso ?γ"
using γ by auto
thus ?thesis by auto
qed
text ‹
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.
›
lemma apex_unique_up_to_equivalence:
assumes "tabulation V H 𝖺 𝗂 src trg r ρ' f' g'"
shows "∃w w' φ ψ θ ν θ' ν'.
equivalence_in_bicategory V H 𝖺 𝗂 src trg w' w ψ φ ∧
«w : src f → src f'» ∧ «w' : src f' → src f» ∧
«θ : f' ⋆ w ⇒ f» ∧ «ν : g ⇒ g' ⋆ w» ∧ iso ν ∧
ρ = (r ⋆ θ) ⋅ 𝖺[r, f', w] ⋅ (ρ' ⋆ w) ⋅ ν ∧
«θ' : f ⋆ w' ⇒ f'» ∧ «ν' : g' ⇒ g ⋆ w'» ∧ iso ν' ∧
ρ' = (r ⋆ θ') ⋅ 𝖺[r, f, w'] ⋅ (ρ ⋆ w') ⋅ ν'"
proof -
interpret T': tabulation V H 𝖺 𝗂 src trg r ρ' f' g'
using assms by auto
obtain w θ ν
where wθν: "ide w ∧ «θ : f' ⋆ w ⇒ f» ∧ «ν : g ⇒ g' ⋆ w» ∧ iso ν ∧
ρ = T'.composite_cell w θ ⋅ ν"
using T'.T1 [of f ρ] ide_leg0 tab_in_hom by auto
obtain w' θ' ν'
where w'θ'ν': "ide w' ∧ «θ' : f ⋆ w' ⇒ f'» ∧ «ν' : g' ⇒ g ⋆ w'» ∧ iso ν' ∧
ρ' = composite_cell w' θ' ⋅ ν'"
using T1 [of f' ρ'] T'.ide_leg0 T'.tab_in_hom by auto
obtain φ where φ: "«φ : src f ⇒ w' ⋆ w» ∧ iso φ"
using wθν w'θ'ν' apex_equivalence_lemma T'.tab_in_hom comp_assoc by metis
obtain ψ where ψ: "«ψ : src f' ⇒ w ⋆ w'» ∧ iso ψ"
using wθν w'θ'ν' T'.apex_equivalence_lemma tab_in_hom comp_assoc by metis
have 1: "src f = src w"
using φ src_dom [of φ] hcomp_simps(1) [of w' w]
by (metis arr_cod in_homE leg0_simps(2) src_hcomp src_src vconn_implies_hpar(3))
have 2: "src f' = src w'"
using ψ src_dom [of ψ] hcomp_simps(1) [of w w']
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 𝖺 𝗂 src trg w' w ψ ‹inv φ›
using φ ψ 1 2 wθν w'θ'ν' by unfold_locales auto
have "«w : src f → src f'»"
using ψ wθν 1 2 trg_cod hcomp_simps(2) E.antipar(1) by simp
moreover have "«w' : src f' → src f»"
using φ w'θ'ν' 1 2 E.antipar(2) by simp
ultimately show ?thesis
using E.equivalence_in_bicategory_axioms wθν w'θ'ν' comp_assoc by metis
qed
end
subsection "`Tabulation' is Bicategorical"
text ‹
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.
›
context equivalence_pseudofunctor
begin
lemma preserves_tabulation:
assumes "tabulation (⋅⇩C) (⋆⇩C) 𝖺⇩C 𝗂⇩C src⇩C trg⇩C r ρ f g"
shows "tabulation (⋅⇩D) (⋆⇩D) 𝖺⇩D 𝗂⇩D src⇩D trg⇩D (F r) (D.inv (Φ (r, f)) ⋅⇩D F ρ) (F f) (F g)"
proof -
let ?ρ' = "D.inv (Φ (r, f)) ⋅⇩D F ρ"
interpret T: tabulation V⇩C H⇩C 𝖺⇩C 𝗂⇩C src⇩C trg⇩C r ρ f
using assms by auto
interpret T': tabulation_data V⇩D H⇩D 𝖺⇩D 𝗂⇩D src⇩D trg⇩D ‹F r› ?ρ' ‹F f› ‹F g›
using cmp_in_hom Φ.components_are_iso C.VV.ide_char⇩S⇩b⇩C C.VV.arr_char⇩S⇩b⇩C
apply unfold_locales
apply auto
by (intro D.comp_in_homI, auto)
interpret T': tabulation V⇩D H⇩D 𝖺⇩D 𝗂⇩D src⇩D trg⇩D ‹F r› ?ρ' ‹F f› ‹F g›
text ‹
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!
›
proof
fix u' ω'
assume u': "D.ide u'"
assume ω': "«ω' : D.dom ω' ⇒⇩D F r ⋆⇩D u'»"
show "∃w' θ' ν'. D.ide w' ∧ «θ' : F f ⋆⇩D w' ⇒⇩D u'» ∧
«ν' : D.dom ω' ⇒⇩D F g ⋆⇩D w'» ∧ D.iso ν' ∧
T'.composite_cell w' θ' ⋅⇩D ν' = ω'"
proof -
text ‹
First, obtain ‹ω› in ‹C› such that ‹F ω› is related to ‹ω'› by an equivalence in ‹D›.
›
define v' where "v' = D.dom ω'"
have v': "D.ide v'"
using assms v'_def D.ide_dom ω' by blast
have ω': "«ω' : v' ⇒⇩D F r ⋆⇩D u'»"
using v'_def ω' by simp
define a' where "a' = src⇩D ω'"
have [simp]: "src⇩D u' = a'"
using a'_def ω'
by (metis D.arr_cod D.ide_char D.in_homE D.src.preserves_cod D.src_dom
D.src_hcomp v')
have [simp]: "trg⇩D u' = src⇩D (F r)"
using ω'
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⇩D v' = a'"
using v'_def ω' a'_def by auto
have [simp]: "trg⇩D v' = trg⇩D (F r)"
using v'_def D.vconn_implies_hpar(4) ω' u' by force
have [simp]: "src⇩D ω' = a'"
using ω' a'_def by blast
have [simp]: "trg⇩D ω' = trg⇩D (F r)"
using ω' v'_def ‹trg⇩D v' = trg⇩D (F r)› by auto
obtain a where a: "C.obj a ∧ D.equivalent_objects (map⇩0 a) a'"
using u' ω' a'_def biessentially_surjective_on_objects D.obj_src by blast
obtain e' where e': "«e' : map⇩0 a →⇩D a'» ∧ D.equivalence_map e'"
using a D.equivalent_objects_def by auto
have u'_in_hhom: "«u' : a' →⇩D map⇩0 (src⇩C r)»"
by (simp add: u')
hence 1: "«u' ⋆⇩D e' : map⇩0 a →⇩D map⇩0 (src⇩C r)»"
using e' by blast
have v'_in_hhom: "«v' : a' →⇩D map⇩0 (trg⇩C r)»"
by (simp add: v')
hence 2: "«v' ⋆⇩D e' : map⇩0 a →⇩D map⇩0 (trg⇩C r)»"
using e' by blast
obtain d' η' ε'
where d'η'ε': "adjoint_equivalence_in_bicategory (⋅⇩D) (⋆⇩D) 𝖺⇩D 𝗂⇩D src⇩D trg⇩D e' d' η' ε'"
using e' D.equivalence_map_extends_to_adjoint_equivalence by blast
interpret e': adjoint_equivalence_in_bicategory ‹(⋅⇩D)› ‹(⋆⇩D)› 𝖺⇩D 𝗂⇩D src⇩D trg⇩D e' d' η' ε'
using d'η'ε' by auto
interpret d': adjoint_equivalence_in_bicategory ‹(⋅⇩D)› ‹(⋆⇩D)› 𝖺⇩D 𝗂⇩D src⇩D trg⇩D
d' e' "D.inv ε'" "D.inv η'"
using e'.dual_adjoint_equivalence by simp
have [simp]: "src⇩D e' = map⇩0 a"
using e' by auto
have [simp]: "trg⇩D e' = a'"
using e' by auto
have [simp]: "src⇩D d' = a'"
by (simp add: e'.antipar(2))
have [simp]: "trg⇩D d' = map⇩0 a"
using e'.antipar by simp
obtain u where u: "«u : a →⇩C src⇩C r» ∧ C.ide u ∧ D.isomorphic (F u) (u' ⋆⇩D e')"
using a e' u' 1 u'_in_hhom locally_essentially_surjective [of a "src⇩C r" "u' ⋆⇩D e'"]
C.obj_src D.equivalence_map_is_ide T.base_simps(2)
by blast
obtain φ where φ: "«φ : u' ⋆⇩D e' ⇒⇩D F u» ∧ D.iso φ"
using u D.isomorphic_symmetric by blast
obtain v where v: "«v : a →⇩C trg⇩C r» ∧ C.ide v ∧ D.isomorphic (F v) (v' ⋆⇩D e')"
using a e' v' v'_in_hhom locally_essentially_surjective [of a "trg⇩C r" "v' ⋆⇩D e'"]
C.obj_trg D.equivalence_map_is_ide T.base_simps(2)
by blast
obtain ψ where ψ: "«ψ : F v ⇒⇩D v' ⋆⇩D e'» ∧ D.iso ψ"
using v by blast
have [simp]: "src⇩C u = a" using u by auto
have [simp]: "trg⇩C u = src⇩C r" using u by auto
have [simp]: "src⇩C v = a" using v by auto
have [simp]: "trg⇩C v = trg⇩C r" using v by auto
have [simp]: "src⇩D φ = map⇩0 a"
using φ by (metis "1" D.dom_src D.in_hhomE D.in_homE D.src.preserves_dom)
have [simp]: "trg⇩D φ = trg⇩D u'"
using φ
by (metis D.cod_trg D.hseqI D.in_homE D.isomorphic_implies_hpar(4)
D.trg.preserves_cod D.trg_hcomp e' u u'_in_hhom)
have [simp]: "src⇩D ψ = map⇩0 a"
using ψ
by (metis C.in_hhomE D.in_homE D.src_dom ‹src⇩D e' = map⇩0 a› preserves_src v)
have [simp]: "trg⇩D ψ = trg⇩D v'"
using ψ
by (metis "2" D.cod_trg D.in_hhomE D.in_homE D.trg.preserves_cod T.base_simps(2)
‹trg⇩D v' = trg⇩D (F r)› preserves_trg)
define Fω where "Fω = Φ (r, u) ⋅⇩D (F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ"
have Fω: "«Fω : F v ⇒⇩D F (r ⋆⇩C u)»"
proof (unfold Fω_def, intro D.comp_in_homI)
show "«ψ : F v ⇒⇩D v' ⋆⇩D e'»"
using ψ by simp
show "«ω' ⋆⇩D e' : v' ⋆⇩D e' ⇒⇩D (F r ⋆⇩D u') ⋆⇩D e'»"
using e' ω' D.equivalence_map_is_ide v'_in_hhom by blast
show "«𝖺⇩D[F r, u', e'] : (F r ⋆⇩D u') ⋆⇩D e' ⇒⇩D F r ⋆⇩D u' ⋆⇩D e'»"
using e' u' D.equivalence_map_is_ide D.in_hhom_def u'_in_hhom by auto
show "«F r ⋆⇩D φ : F r ⋆⇩D u' ⋆⇩D e' ⇒⇩D F r ⋆⇩D F u»"
using e' u' u φ
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 "«Φ (r, u) : F r ⋆⇩D F u ⇒⇩D F (r ⋆⇩C u)»"
using u cmp_in_hom(2) [of r u] by auto
qed
obtain ω where ω: "«ω : v ⇒⇩C r ⋆⇩C u» ∧ F ω = Fω"
using u v ω' φ ψ Fω locally_full [of v "r ⋆⇩C u" Fω]
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⇩C ω = src⇩C u"
using ω
by (metis C.hseqI C.in_homE C.src_cod C.src_hcomp T.base_in_hom(1) u)
have [simp]: "trg⇩C ω = trg⇩C r"
using ω
by (metis C.ide_char C.ide_trg C.in_homE C.trg.preserves_hom ‹trg⇩C v = trg⇩C r›)
text ‹Apply ‹T.T1› to ‹u› and ‹ω› to obtain ‹w›, ‹θ›, ‹ν›.›
obtain w θ ν
where wθν: "C.ide w ∧ «θ : f ⋆⇩C w ⇒⇩C u» ∧ «ν : C.dom ω ⇒⇩C g ⋆⇩C w» ∧
C.iso ν ∧ T.composite_cell w θ ⋅⇩C ν = ω"
using u ω T.T1 [of u ω] by auto
text ‹
Combining ‹ω› and ‹wθν› 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
$$
›
have [simp]: "src⇩C w = src⇩C u"
by (metis C.arrI C.seqE C.src_hcomp C.src_vcomp C.vseq_implies_hpar(1)
ω ‹src⇩C ω = src⇩C u› wθν)
have [simp]: "trg⇩C w = src⇩C f"
by (metis C.arrI C.hseq_char C.seqE T.tab_simps(2) ω wθν)
have [simp]: "src⇩D (F u) = map⇩0 a"
using e'.antipar(1) u by auto
have [simp]: "src⇩D (F v) = map⇩0 a"
using v e' e'.antipar by force
have [simp]: "src⇩D (F w) = map⇩0 a"
by (simp add: wθν)
have *: "F (T.composite_cell w θ ⋅⇩C ν) =
Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w)) ⋅⇩D F ν"
text ‹
$$
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
$$
›
proof -
have "F (T.composite_cell w θ ⋅⇩C ν) = F ((r ⋆⇩C θ) ⋅⇩C 𝖺⇩C[r, f, w] ⋅⇩C (ρ ⋆⇩C w) ⋅⇩C ν)"
using C.comp_assoc by simp
also have "... = F (r ⋆⇩C θ) ⋅⇩D F 𝖺⇩C[r, f, w] ⋅⇩D F (ρ ⋆⇩C w) ⋅⇩D F ν"
by (metis C.arr_dom_iff_arr C.comp_assoc C.in_homE C.seqE
as_nat_trans.preserves_comp_2 wθν)
also have "... =
F (r ⋆⇩C θ) ⋅⇩D (Φ (r, f ⋆⇩C w) ⋅⇩D (F r ⋆⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D D.inv (Φ (r ⋆⇩C f, w))) ⋅⇩D F (ρ ⋆⇩C w) ⋅⇩D F ν"
using ω wθν 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 ⋆⇩C θ) ⋅⇩D Φ (r, f ⋆⇩C w)) ⋅⇩D (F r ⋆⇩D Φ (f, w))) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
((D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D D.inv (Φ (r ⋆⇩C f, w))) ⋅⇩D F (ρ ⋆⇩C w) ⋅⇩D F ν"
using D.comp_assoc by simp
also have "... =
Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
((D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D D.inv (Φ (r ⋆⇩C f, w)) ⋅⇩D F (ρ ⋆⇩C w)) ⋅⇩D F ν"
proof -
have "(F (r ⋆⇩C θ) ⋅⇩D Φ (r, f ⋆⇩C w)) ⋅⇩D (F r ⋆⇩D Φ (f, w)) =
(Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w)))"
proof -
have "F (r ⋆⇩C θ) ⋅⇩D Φ (r, f ⋆⇩C w) = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ)"
using ω Φ.naturality [of "(r, θ)"] FF_def wθν C.VV.arr_char⇩S⇩b⇩C
C.VV.dom_simp C.VV.cod_simp
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 "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w))"
proof -
have "(F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w)) = F r ⋆⇩D F θ ⋅⇩D Φ (f, w)"
using ω wθν D.whisker_right [of "F r" "F θ" "Φ (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 cmp_in_hom(2)
preserves_hom)
thus ?thesis by simp
qed
finally have "(F (r ⋆⇩C θ) ⋅⇩D Φ (r, f ⋆⇩C w)) ⋅⇩D (F r ⋆⇩D Φ (f, w)) =
Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w))"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w))) ⋅⇩D F ν"
proof -
have "(D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D D.inv (Φ (r ⋆⇩C f, w)) ⋅⇩D F (ρ ⋆⇩C w) =
((D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D (F ρ ⋆⇩D F w)) ⋅⇩D D.inv (Φ (g, w))"
proof -
have "D.inv (Φ (r ⋆⇩C f, w)) ⋅⇩D F (ρ ⋆⇩C w) = (F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w))"
proof -
have "src⇩C (r ⋆⇩C f) = trg⇩C w"
using ω wθν
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 (Φ (r ⋆⇩C f, w)) (F ρ ⋆⇩D F w)"
using ω wθν cmp_in_hom(2) [of "r ⋆⇩C f" w] C.VV.arr_char⇩S⇩b⇩C FF_def by auto
moreover have "Φ (r ⋆⇩C f, w) ⋅⇩D (F ρ ⋆⇩D F w) = F (ρ ⋆⇩C w) ⋅⇩D Φ (g, w)"
using ω wθν Φ.naturality [of "(ρ, w)"] cmp_components_are_iso FF_def
C.VV.arr_char⇩S⇩b⇩C C.VV.dom_simp C.VV.cod_simp
by simp
moreover have "D.iso (Φ (r ⋆⇩C f, w))"
using wθν cmp_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-3) ω)
moreover have "D.iso (Φ (g, w))"
using wθν cmp_components_are_iso
by (metis C.arrI C.hseqE C.seqE T.tab_simps(2) T.ide_leg1 T.leg1_simps(3) ω)
ultimately show ?thesis
using ω wθν Φ.naturality cmp_components_are_iso FF_def C.VV.arr_char⇩S⇩b⇩C
D.invert_opposite_sides_of_square
by presburger
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w))"
using ω wθν D.whisker_right cmp_components_are_iso cmp_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 ‹We can now define the ‹w'›, ‹θ'›, and ‹ν'› that we are required to exhibit.›
define φ' where "φ' = e'.trnr⇩ε u' (D.inv φ)"
have "φ' = 𝗋⇩D[u'] ⋅⇩D (u' ⋆⇩D ε') ⋅⇩D 𝖺⇩D[u', e', d'] ⋅⇩D (D.inv φ ⋆⇩D d')"
unfolding φ'_def e'.trnr⇩ε_def by simp
have φ': "«φ' : F u ⋆⇩D d' ⇒⇩D u'»"
using φ φ'_def u u' e'.adjoint_transpose_right(2) [of u' "F u"] by auto
have [simp]: "src⇩D φ' = src⇩D u'"
using φ' by fastforce
have [simp]: "trg⇩D φ' = trg⇩D u'"
using φ' by fastforce
define ψ' where "ψ' = d'.trnr⇩η v' (D.inv ψ)"
have ψ'_eq: "ψ' = (D.inv ψ ⋆⇩D d') ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d'] ⋅⇩D (v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
unfolding ψ'_def d'.trnr⇩η_def by simp
have ψ': "«ψ' : v' ⇒⇩D F v ⋆⇩D d'»"
using ψ ψ'_def v v' d'.adjoint_transpose_right(1) [of "F v" v'] by auto
have iso_ψ': "D.iso ψ'"
unfolding ψ'_def d'.trnr⇩η_def
using ψ 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 ψ'_eq
ψ' d'.unit_simps(5) e'.antipar(1) e'.antipar(2) e'.ide_left e'.ide_right v')
have [simp]: "src⇩D ψ' = src⇩D v'"
using ψ' by fastforce
have [simp]: "trg⇩D ψ' = trg⇩D v'"
using ψ' by fastforce
define w' where "w' = F w ⋆⇩D d'"
define θ' where "θ' = φ' ⋅⇩D (F θ ⋅⇩D Φ (f, w) ⋆⇩D d') ⋅⇩D 𝖺⇩D⇧-⇧1[F f, F w, d']"
define ν' where "ν' = 𝖺⇩D[F g, F w, d'] ⋅⇩D (D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
have w': "D.ide w' ∧ «w' : src⇩D u' →⇩D src⇩D (F f)»"
using w'_def ω wθν by simp
have θ': "«θ' : F f ⋆⇩D w' ⇒⇩D u'»"
unfolding θ'_def w'_def
using φ' ω wθν cmp_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 ν': "«ν' : v' ⇒⇩D F g ⋆⇩D w'»"
unfolding ν'_def w'_def
using ψ' ω wθν cmp_in_hom cmp_components_are_iso
apply (intro D.comp_in_homI)
apply auto
by (intro D.hcomp_in_vhom D.comp_in_homI, auto)
have iso_ν': "D.iso ν'"
using ν'_def iso_ψ' cmp_in_hom 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) cmp_components_are_iso
ν' ‹src⇩D (F w) = map⇩0 a› ‹src⇩D e' = map⇩0 a› ‹trg⇩C w = src⇩C f› e'.antipar(1)
e'.ide_right preserves_ide preserves_src preserves_trg wθν)
have "T'.composite_cell w' θ' ⋅⇩D ν' = ω'"
text ‹
$$
\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
$$
›
proof -
have 1: "«T'.composite_cell w' θ' ⋅⇩D ν' : v' ⇒⇩D F r ⋆⇩D u'»"
using w' θ' ν' wθν T'.composite_cell_in_hom by blast
have "T'.composite_cell w' θ' ⋅⇩D ν' =
(F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D
(F (T.composite_cell w θ ⋅⇩C ν) ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "T'.composite_cell w' θ' ⋅⇩D ν' =
(F r ⋆⇩D φ' ⋅⇩D (F θ ⋅⇩D Φ (f, w) ⋆⇩D d') ⋅⇩D 𝖺⇩D⇧-⇧1[F f, F w, d']) ⋅⇩D
𝖺⇩D[F r, F f, w'] ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D w') ⋅⇩D 𝖺⇩D[F g, F w, d'] ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
using θ'_def ν'_def D.comp_assoc by simp
also have
"... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D (F θ ⋅⇩D Φ (f, w) ⋆⇩D d') ⋅⇩D 𝖺⇩D⇧-⇧1[F f, F w, d']) ⋅⇩D
𝖺⇩D[F r, F f, F w ⋆⇩D d'] ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w ⋆⇩D d') ⋅⇩D
𝖺⇩D[F g, F w, d'] ⋅⇩D (D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
using θ' θ'_def w'_def D.comp_assoc D.whisker_left by auto
also have
"... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D (F θ ⋆⇩D d') ⋅⇩D (Φ (f, w) ⋆⇩D d') ⋅⇩D
𝖺⇩D⇧-⇧1[F f, F w, d']) ⋅⇩D 𝖺⇩D[F r, F f, F w ⋆⇩D d'] ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w ⋆⇩D d') ⋅⇩D
𝖺⇩D[F g, F w, d']) ⋅⇩D (D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
using θ' θ'_def D.whisker_right cmp_in_hom D.comp_assoc by fastforce
also have
"... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D (F θ ⋆⇩D d') ⋅⇩D (Φ (f, w) ⋆⇩D d') ⋅⇩D
𝖺⇩D⇧-⇧1[F f, F w, d']) ⋅⇩D 𝖺⇩D[F r, F f, F w ⋆⇩D d'] ⋅⇩D
𝖺⇩D[F r ⋆⇩D F f, F w, d'] ⋅⇩D ((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d') ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w ⋆⇩D d') ⋅⇩D 𝖺⇩D[F g, F w, d'] =
𝖺⇩D[F r ⋆⇩D F f, F w, d'] ⋅⇩D ((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d')"
using D.assoc_naturality [of "D.inv (Φ (r, f)) ⋅⇩D F ρ" "F w" d']
cmp_in_hom cmp_components_are_iso
by (simp add: wθν)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D F θ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D Φ (f, w) ⋆⇩D d') ⋅⇩D
((F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, F w, d']) ⋅⇩D
𝖺⇩D[F r, F f, F w ⋆⇩D d'] ⋅⇩D 𝖺⇩D[F r ⋆⇩D F f, F w, d']) ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d') ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
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 ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D F θ ⋆⇩D d') ⋅⇩D ((F r ⋆⇩D Φ (f, w) ⋆⇩D d') ⋅⇩D
𝖺⇩D[F r, F f ⋆⇩D F w, d']) ⋅⇩D (𝖺⇩D[F r, F f, F w] ⋆⇩D d') ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d') ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "D.seq 𝖺⇩D[F r, F f, F w ⋆⇩D d'] 𝖺⇩D[F r ⋆⇩D F f, F w, d']"
by (metis 1 D.arrI D.seqE calculation)
hence "(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, F w, d']) ⋅⇩D 𝖺⇩D[F r, F f, F w ⋆⇩D d'] ⋅⇩D
𝖺⇩D[F r ⋆⇩D F f, F w, d'] =
𝖺⇩D[F r, F f ⋆⇩D F w, d'] ⋅⇩D (𝖺⇩D[F r, F f, F w] ⋆⇩D d')"
using wθν D.pentagon
D.invert_side_of_triangle(1)
[of "𝖺⇩D[F r, F f, F w ⋆⇩D d'] ⋅⇩D 𝖺⇩D[F r ⋆⇩D F f, F w, d']"
"F r ⋆⇩D 𝖺⇩D[F f, F w, d']"
"𝖺⇩D[F r, F f ⋆⇩D F w, d'] ⋅⇩D (𝖺⇩D[F r, F f, F w] ⋆⇩D d')"]
by (simp add: wθν)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D ((F r ⋆⇩D F θ ⋆⇩D d') ⋅⇩D 𝖺⇩D[F r, F (f ⋆⇩C w), d']) ⋅⇩D
((F r ⋆⇩D Φ (f, w)) ⋆⇩D d') ⋅⇩D (𝖺⇩D[F r, F f, F w] ⋆⇩D d') ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d') ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "(F r ⋆⇩D Φ (f, w) ⋆⇩D d') ⋅⇩D 𝖺⇩D[F r, F f ⋆⇩D F w, d'] =
𝖺⇩D[F r, F (f ⋆⇩C w), d'] ⋅⇩D ((F r ⋆⇩D Φ (f, w)) ⋆⇩D d')"
using 1 wθν D.assoc_naturality [of "F r" "Φ (f, w)" d']
‹trg⇩C w = src⇩C f› 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 cmp_simps(1-5) w'_def)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (((F r ⋆⇩D F θ) ⋆⇩D d') ⋅⇩D
((F r ⋆⇩D Φ (f, w)) ⋆⇩D d') ⋅⇩D (𝖺⇩D[F r, F f, F w] ⋆⇩D d') ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d') ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d')) ⋅⇩D ψ'"
proof -
have "src⇩D (F r) = trg⇩D (F θ)"
using wθν by (metis C.arrI C.hseqE C.seqE ω preserves_hseq)
moreover have "src⇩D (F θ) = trg⇩D d'"
using wθν C.arrI C.vconn_implies_hpar(1) by auto
ultimately
have "(F r ⋆⇩D F θ ⋆⇩D d') ⋅⇩D 𝖺⇩D[F r, F (f ⋆⇩C w), d'] =
𝖺⇩D[F r, F u, d'] ⋅⇩D ((F r ⋆⇩D F θ) ⋆⇩D d')"
using wθν D.assoc_naturality [of "F r" "F θ" d'] by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
(((F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w))) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "((F r ⋆⇩D F θ) ⋆⇩D d') ⋅⇩D
((F r ⋆⇩D Φ (f, w)) ⋆⇩D d') ⋅⇩D (𝖺⇩D[F r, F f, F w] ⋆⇩D d') ⋅⇩D
((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋆⇩D d') ⋅⇩D
(D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') =
(F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w)) ⋅⇩D F ν
⋆⇩D d'"
proof -
have "«(F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w)) ⋅⇩D F ν :
F v ⇒⇩D F r ⋆⇩D F u»"
using wθν ω cmp_in_hom
apply (intro D.comp_in_homI)
apply auto
by (intro D.hcomp_in_vhom, auto)
hence "D.arr ((F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w)) ⋅⇩D F ν)"
by auto
thus ?thesis
using D.whisker_right by fastforce
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
((F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
using wθν D.whisker_left cmp_in_hom
by (metis D.seqI' T'.ide_base T.ide_leg0 ‹trg⇩C w = src⇩C f› preserves_hom)
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
((D.inv (Φ (r, u)) ⋅⇩D Φ (r, u) ⋅⇩D
(F r ⋆⇩D F θ ⋅⇩D Φ (f, w))) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "(D.inv (Φ (r, u)) ⋅⇩D Φ (r, u)) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) =
F r ⋆⇩D F θ ⋅⇩D Φ (f, w)"
proof -
have "(D.inv (Φ (r, u)) ⋅⇩D Φ (r, u)) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) =
(F r ⋆⇩D F u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w))"
using u cmp_components_are_iso
by (simp add: D.comp_inv_arr')
also have "... = F r ⋆⇩D F θ ⋅⇩D Φ (f, w)"
using u ω wθν cmp_in_hom ‹trg⇩C u = src⇩C r›
D.comp_cod_arr [of "F r ⋆⇩D F θ ⋅⇩D Φ (f, w)" "F r ⋆⇩D F u"]
by (metis (full_types) "*" D.arrI D.cod_comp D.seqE Fω T.ide_base
cmp_simps(4))
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
(D.inv (Φ (r, u)) ⋅⇩D Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D
𝖺⇩D[F r, F f, F w] ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
using D.comp_assoc by simp
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D
(Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "D.inv (Φ (r, u)) ⋅⇩D Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D
𝖺⇩D[F r, F f, F w] ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d' =
(D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D (Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ ⋅⇩D Φ (f, w)) ⋅⇩D
𝖺⇩D[F r, F f, F w] ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w) ⋅⇩D
D.inv (Φ (g, w)) ⋅⇩D F ν ⋆⇩D d')"
using D.whisker_right cmp_in_hom cmp_components_are_iso
by (metis * D.arrI D.invert_side_of_triangle(1) Fω T.ide_base ω
‹trg⇩C u = src⇩C r› e'.ide_right u wθν)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D
(F (T.composite_cell w θ ⋅⇩C ν) ⋆⇩D d') ⋅⇩D ψ'"
using D.comp_assoc * by simp
finally show ?thesis by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D
(F ω ⋆⇩D d') ⋅⇩D ψ'"
using wθν by simp
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D
(Φ (r, u) ⋅⇩D (F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D
ψ'"
using ω Fω_def by simp
text ‹
$$
\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
$$
›
also have "... = ω'"
text ‹
$$
\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
$$
›
proof -
have "(F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D (D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D
(Φ (r, u) ⋅⇩D (F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ' =
(F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
((D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D (Φ (r, u) ⋆⇩D d')) ⋅⇩D
((F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ'"
using D.whisker_right cmp_in_hom D.comp_assoc
by (metis D.arrI Fω Fω_def e'.ide_right)
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
((F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "(D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D (Φ (r, u) ⋆⇩D d') =
D.inv (Φ (r, u)) ⋅⇩D Φ (r, u) ⋆⇩D d'"
using cmp_in_hom cmp_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) ‹trg⇩C u = src⇩C r› e'.ide_right
preserves_arr u)
also have "... = (F r ⋆⇩D F u) ⋆⇩D d'"
using u cmp_components_are_iso D.comp_inv_arr' by simp
finally have "(F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
((D.inv (Φ (r, u)) ⋆⇩D d') ⋅⇩D (Φ (r, u) ⋆⇩D d')) ⋅⇩D
((F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ' =
(F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D ((F r ⋆⇩D F u) ⋆⇩D d') ⋅⇩D
((F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ'"
by simp
also have "... = (F r ⋆⇩D φ') ⋅⇩D (𝖺⇩D[F r, F u, d'] ⋅⇩D ((F r ⋆⇩D F u) ⋆⇩D d')) ⋅⇩D
((F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ'"
using D.comp_assoc by auto
also have "... = (F r ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F u, d'] ⋅⇩D
((F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d') ⋅⇩D ψ'"
using u D.comp_arr_dom by simp
finally show ?thesis by blast
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D (𝖺⇩D[F r, F u, d'] ⋅⇩D
((F r ⋆⇩D φ) ⋆⇩D d')) ⋅⇩D (𝖺⇩D[F r, u', e'] ⋆⇩D d') ⋅⇩D
((ω' ⋆⇩D e') ⋆⇩D d') ⋅⇩D (ψ ⋆⇩D d') ⋅⇩D ψ'"
proof -
have
"(F r ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, u', e'] ⋅⇩D (ω' ⋆⇩D e') ⋅⇩D ψ ⋆⇩D d' =
((F r ⋆⇩D φ) ⋆⇩D d') ⋅⇩D (𝖺⇩D[F r, u', e'] ⋆⇩D d') ⋅⇩D ((ω' ⋆⇩D e') ⋆⇩D d') ⋅⇩D (ψ ⋆⇩D d')"
using D.whisker_right φ φ' e' e'.antipar(1) u' u'_in_hhom
by (metis D.arrI D.seqE Fω Fω_def e'.ide_right)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d') ⋅⇩D 𝖺⇩D[F r, u' ⋆⇩D e', d'] ⋅⇩D
((𝖺⇩D[F r, u', e'] ⋆⇩D d') ⋅⇩D ((ω' ⋆⇩D e') ⋆⇩D d')) ⋅⇩D (ψ ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "𝖺⇩D[F r, F u, d'] ⋅⇩D ((F r ⋆⇩D φ) ⋆⇩D d') =
(F r ⋆⇩D φ ⋆⇩D d') ⋅⇩D 𝖺⇩D[F r, u' ⋆⇩D e', d']"
using D.assoc_naturality [of "F r" φ d'] φ by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d') ⋅⇩D 𝖺⇩D[F r, u' ⋆⇩D e', d'] ⋅⇩D
((𝖺⇩D[F r, u', e'] ⋆⇩D d') ⋅⇩D (𝖺⇩D⇧-⇧1[F r ⋆⇩D u', e', d'] ⋅⇩D
(ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D 𝖺⇩D[v', e', d'])) ⋅⇩D (ψ ⋆⇩D d') ⋅⇩D ψ'"
using Fω Fω_def ω' D.comp_assoc D.hcomp_reassoc(1) [of ω' e' d']
by (elim D.in_homE, simp)
also have "... = (F r ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) ⋅⇩D
𝖺⇩D[F r, u', e' ⋆⇩D d'] ⋅⇩D (ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D 𝖺⇩D[v', e', d'] ⋅⇩D
(ψ ⋆⇩D d') ⋅⇩D ψ'"
proof -
have "D.seq (F r ⋆⇩D 𝖺⇩D[u', e', d'])
(𝖺⇩D[F r, u' ⋆⇩D e', d'] ⋅⇩D (𝖺⇩D[F r, u', e'] ⋆⇩D d'))"
using u' by simp
moreover have "(F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D 𝖺⇩D[F r, u' ⋆⇩D e', d'] ⋅⇩D
(𝖺⇩D[F r, u', e'] ⋆⇩D d') =
𝖺⇩D[F r, u', e' ⋆⇩D d'] ⋅⇩D 𝖺⇩D[F r ⋆⇩D u', e', d']"
using u' D.pentagon by simp
moreover have "D.iso (F r ⋆⇩D 𝖺⇩D[u', e', d'])"
using u' by simp
moreover have "D.inv (F r ⋆⇩D 𝖺⇩D[u', e', d']) = F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']"
using u' by simp
ultimately
have "𝖺⇩D[F r, u' ⋆⇩D e', d'] ⋅⇩D (𝖺⇩D[F r, u', e'] ⋆⇩D d') ⋅⇩D 𝖺⇩D⇧-⇧1[F r ⋆⇩D u', e', d'] =
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d']"
using u' D.comp_assoc
D.invert_opposite_sides_of_square
[of "F r ⋆⇩D 𝖺⇩D[u', e', d']"
"𝖺⇩D[F r, u' ⋆⇩D e', d'] ⋅⇩D (𝖺⇩D[F r, u', e'] ⋆⇩D d')"
"𝖺⇩D[F r, u', e' ⋆⇩D d']" "𝖺⇩D[F r ⋆⇩D u', e', d']"]
by simp
thus ?thesis
using D.comp_assoc by metis
qed
also have
"... = (F r ⋆⇩D 𝗋⇩D[u'] ⋅⇩D (u' ⋆⇩D ε') ⋅⇩D 𝖺⇩D[u', e', d'] ⋅⇩D (D.inv φ ⋆⇩D d')) ⋅⇩D
(F r ⋆⇩D φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d'] ⋅⇩D
(ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D 𝖺⇩D[v', e', d'] ⋅⇩D (ψ ⋆⇩D d') ⋅⇩D (D.inv ψ ⋆⇩D d') ⋅⇩D
𝖺⇩D⇧-⇧1[v', e', d'] ⋅⇩D (v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
unfolding φ'_def ψ'_def e'.trnr⇩ε_def d'.trnr⇩η_def by simp
also have
"... = (F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D (F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D
(F r ⋆⇩D D.inv φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d') ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d'] ⋅⇩D (ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D
𝖺⇩D[v', e', d'] ⋅⇩D (ψ ⋆⇩D d') ⋅⇩D (D.inv ψ ⋆⇩D d') ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d'] ⋅⇩D
(v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "F r ⋆⇩D 𝗋⇩D[u'] ⋅⇩D (u' ⋆⇩D ε') ⋅⇩D 𝖺⇩D[u', e', d'] ⋅⇩D (D.inv φ ⋆⇩D d') =
(F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D (F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D
(F r ⋆⇩D D.inv φ ⋆⇩D d')"
proof -
have "D.ide (F r)" by simp
moreover have "D.seq 𝗋⇩D[u'] ((u' ⋆⇩D ε') ⋅⇩D 𝖺⇩D[u', e', d'] ⋅⇩D (D.inv φ ⋆⇩D d')) ∧
D.seq (u' ⋆⇩D ε') (𝖺⇩D[u', e', d'] ⋅⇩D (D.inv φ ⋆⇩D d')) ∧
D.seq 𝖺⇩D[u', e', d'] (D.inv φ ⋆⇩D d')"
using φ' φ'_def unfolding e'.trnr⇩ε_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 ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D (F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D
(((F r ⋆⇩D D.inv φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d')) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d'])) ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d'] ⋅⇩D (ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D
𝖺⇩D[v', e', d'] ⋅⇩D (((ψ ⋆⇩D d') ⋅⇩D (D.inv ψ ⋆⇩D d')) ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d']) ⋅⇩D
(v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
using D.comp_assoc by simp
also have
"... = (F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D (F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d'] ⋅⇩D (ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D
((𝖺⇩D[v', e', d'] ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d']) ⋅⇩D (v' ⋆⇩D D.inv ε')) ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "((F r ⋆⇩D D.inv φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d')) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) =
F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']"
proof -
have "(F r ⋆⇩D D.inv φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d') = F r ⋆⇩D D.inv φ ⋅⇩D φ ⋆⇩D d'"
using u u' φ 1 2 D.src_dom e'.antipar D.whisker_left D.whisker_right
by auto
also have "... = F r ⋆⇩D (u' ⋆⇩D e') ⋆⇩D d'"
using φ D.comp_inv_arr' by auto
finally have
"(F r ⋆⇩D D.inv φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d') = F r ⋆⇩D (u' ⋆⇩D e') ⋆⇩D d'"
by simp
hence
"((F r ⋆⇩D D.inv φ ⋆⇩D d') ⋅⇩D (F r ⋆⇩D φ ⋆⇩D d')) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']) =
(F r ⋆⇩D (u' ⋆⇩D e') ⋆⇩D d') ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d'])"
using D.comp_assoc by simp
also have "... = F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d']"
proof -
have "«F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d'] :
F r ⋆⇩D u' ⋆⇩D e' ⋆⇩D d' ⇒⇩D F r ⋆⇩D (u' ⋆⇩D e') ⋆⇩D d'»"
using u' e'.antipar φ' D.assoc'_in_hom
unfolding e'.trnr⇩ε_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
"((ψ ⋆⇩D d') ⋅⇩D (D.inv ψ ⋆⇩D d')) ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d'] = 𝖺⇩D⇧-⇧1[v', e', d']"
proof -
have "(ψ ⋆⇩D d') ⋅⇩D (D.inv ψ ⋆⇩D d') = (v' ⋆⇩D e') ⋆⇩D d'"
using ψ e'.antipar D.src_cod v' e'.antipar ψ' d'.trnr⇩η_def
D.whisker_right [of d' ψ "D.inv ψ"] D.comp_arr_inv'
by auto
moreover have "«𝖺⇩D⇧-⇧1[v', e', d'] : v' ⋆⇩D e' ⋆⇩D d' ⇒⇩D (v' ⋆⇩D e') ⋆⇩D d'»"
using v' e'.antipar ψ' D.assoc'_in_hom
unfolding d'.trnr⇩η_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 ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D (((F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d'])) ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d']) ⋅⇩D
(ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D (v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "(𝖺⇩D[v', e', d'] ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d']) ⋅⇩D (v' ⋆⇩D D.inv ε') = v' ⋆⇩D D.inv ε'"
proof -
have 1: "D.hseq v' e'"
using v' e'.antipar ψ' unfolding d'.trnr⇩η_def by fastforce
have "𝖺⇩D[v', e', d'] ⋅⇩D 𝖺⇩D⇧-⇧1[v', e', d'] = v' ⋆⇩D e' ⋆⇩D d'"
using v' e'.antipar 1 D.comp_assoc_assoc' by auto
moreover have "«v' ⋆⇩D D.inv ε' : v' ⋆⇩D trg⇩D e' ⇒⇩D v' ⋆⇩D e' ⋆⇩D d'»"
using v' e'.antipar 1
apply (intro D.hcomp_in_vhom)
apply auto
by (metis D.ideD(1) D.trg_src ‹trg⇩D e' = a'› 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 ⋆⇩D 𝗋⇩D[u']) ⋅⇩D ((F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d']) ⋅⇩D
(ω' ⋆⇩D e' ⋆⇩D d') ⋅⇩D (v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "((F r ⋆⇩D 𝖺⇩D[u', e', d']) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[u', e', d'])) ⋅⇩D
𝖺⇩D[F r, u', e' ⋆⇩D d'] =
𝖺⇩D[F r, u', e' ⋆⇩D d']"
using φ u' e'.antipar 1 D.comp_cod_arr D.comp_assoc_assoc'
D.whisker_left [of "F r" "𝖺⇩D[u', e', d']" "𝖺⇩D⇧-⇧1[u', e', d']"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D 𝖺⇩D[F r, u', trg⇩D e'] ⋅⇩D (((F r ⋆⇩D u') ⋆⇩D ε') ⋅⇩D
(ω' ⋆⇩D e' ⋆⇩D d')) ⋅⇩D (v' ⋆⇩D D.inv ε') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "(F r ⋆⇩D u' ⋆⇩D ε') ⋅⇩D 𝖺⇩D[F r, u', e' ⋆⇩D d'] =
𝖺⇩D[F r, u', trg⇩D e'] ⋅⇩D ((F r ⋆⇩D u') ⋆⇩D ε')"
using D.assoc_naturality [of "F r" u' ε'] e' u' u'_in_hhom by force
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D 𝖺⇩D[F r, u', trg⇩D e'] ⋅⇩D (ω' ⋆⇩D trg⇩D e') ⋅⇩D
((v' ⋆⇩D ε') ⋅⇩D (v' ⋆⇩D D.inv ε')) ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "((F r ⋆⇩D u') ⋆⇩D ε') ⋅⇩D (ω' ⋆⇩D e' ⋆⇩D d') = (ω' ⋆⇩D trg⇩D e') ⋅⇩D (v' ⋆⇩D ε')"
proof -
have "((F r ⋆⇩D u') ⋆⇩D ε') ⋅⇩D (ω' ⋆⇩D e' ⋆⇩D d') =
((F r ⋆⇩D u') ⋅⇩D ω' ⋆⇩D ε' ⋅⇩D (e' ⋆⇩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)
ω' e'.counit_simps(1) e'.counit_simps(2) preserves_src u' u'_in_hhom)
also have "... = ω' ⋅⇩D v' ⋆⇩D trg⇩D e' ⋅⇩D ε'"
using ω' D.comp_arr_dom D.comp_cod_arr by auto
also have "... = (ω' ⋆⇩D trg⇩D e') ⋅⇩D (v' ⋆⇩D ε')"
using D.interchange
by (metis D.arrI D.comp_cod_arr D.ide_char D.seqI ω' ‹trg⇩D e' = a'›
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 ⋆⇩D 𝗋⇩D[u']) ⋅⇩D 𝖺⇩D[F r, u', trg⇩D e'] ⋅⇩D (ω' ⋆⇩D trg⇩D e') ⋅⇩D 𝗋⇩D⇧-⇧1[v']"
proof -
have "(v' ⋆⇩D ε') ⋅⇩D (v' ⋆⇩D D.inv ε') = v' ⋆⇩D trg⇩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 "«𝗋⇩D⇧-⇧1[v'] : v' ⇒⇩D v' ⋆⇩D trg⇩D e'»"
using v' 1 by simp
ultimately show ?thesis
using v' D.comp_cod_arr by auto
qed
also have "... = (F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (𝖺⇩D[F r, u', trg⇩D e'] ⋅⇩D 𝗋⇩D⇧-⇧1[F r ⋆⇩D u']) ⋅⇩D ω'"
using u' v' ω' D.runit'_naturality D.comp_assoc
by (metis D.in_hhomE D.in_homE a'_def e')
also have "... = (F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D 𝗋⇩D⇧-⇧1[u']) ⋅⇩D ω'"
using 1 T'.ide_base u' D.runit_hcomp [of "F r" u'] by fastforce
also have "... = ((F r ⋆⇩D 𝗋⇩D[u']) ⋅⇩D (F r ⋆⇩D 𝗋⇩D⇧-⇧1[u'])) ⋅⇩D ω'"
using D.comp_assoc by simp
also have "... = (F r ⋆⇩D 𝗋⇩D[u'] ⋅⇩D 𝗋⇩D⇧-⇧1[u']) ⋅⇩D ω'"
using 1 T'.ide_base u' D.whisker_left by simp
also have "... = (F r ⋆⇩D u') ⋅⇩D ω'"
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 "... = ω'"
using ω' D.comp_cod_arr by auto
finally show ?thesis by simp
qed
finally show ?thesis by simp
qed
thus "∃w' θ' ν'. D.ide w' ∧ «θ' : F f ⋆⇩D w' ⇒⇩D u'» ∧
«ν' : D.dom ω' ⇒⇩D F g ⋆⇩D w'» ∧ D.iso ν' ∧ T'.composite_cell w' θ' ⋅⇩D ν' = ω'"
using w' θ' ν' iso_ν' v'_def by blast
qed
text ‹Now we establish ‹T'.T2›.›
next
fix u w w' θ θ' β
assume w: "D.ide w"
assume w': "D.ide w'"
assume θ: "«θ : F f ⋆⇩D w ⇒⇩D u»"
assume θ': "«θ' : F f ⋆⇩D w' ⇒⇩D u»"
assume β: "«β : F g ⋆⇩D w ⇒⇩D F g ⋆⇩D w'»"
assume eq: "T'.composite_cell w θ = T'.composite_cell w' θ' ⋅⇩D β"
show "∃!γ. «γ : w ⇒⇩D w'» ∧ β = F g ⋆⇩D γ ∧ θ = θ' ⋅⇩D (F f ⋆⇩D γ)"
proof -
define a where "a = src⇩D w"
have a: "D.obj a"
unfolding a_def by (simp add: w)
have [simp]: "src⇩D θ = a"
using θ a_def
by (metis D.dom_src D.in_homE D.src.preserves_dom D.src.preserves_reflects_arr
D.src_hcomp)
have [simp]: "trg⇩D θ = trg⇩D (F f)"
using θ
by (metis D.arr_dom D.in_homE D.trg_hcomp D.vconn_implies_hpar(2))
have [simp]: "src⇩D θ' = a"
using θ' a_def
by (metis D.horizontal_homs_axioms D.in_homE ‹src⇩D θ = a› θ horizontal_homs.src_cod)
have [simp]: "trg⇩D θ' = trg⇩D (F f)"
using θ'
by (metis D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) ‹trg⇩D θ = trg⇩D (F f)› θ)
have [simp]: "src⇩D w = a"
using a_def by simp
have [simp]: "trg⇩D w = map⇩0 (src⇩C ρ)"
by (metis D.horizontal_homs_axioms D.hseq_char D.in_homE T.tab_simps(2) T.leg0_simps(2)
θ category.ideD(1) category.ide_dom horizontal_homs_def preserves_src)
have [simp]: "src⇩D w' = a"
using a_def
by (metis D.ideD(1) D.in_homE D.src_hcomp D.vconn_implies_hpar(1) ‹src⇩D θ' = a›
θ' category.ide_dom horizontal_homs_def weak_arrow_of_homs_axioms
weak_arrow_of_homs_def)
have [simp]: "trg⇩D w' = map⇩0 (src⇩C ρ)"
by (metis D.horizontal_homs_axioms D.hseq_char D.in_homE T.tab_simps(2) T.leg0_simps(2)
θ' category.ideD(1) category.ide_dom horizontal_homs_def preserves_src)
text ‹First, reflect the picture back to ‹C›, so that we will be able to apply ‹T.T2›.
We need to choose arrows in ‹C› carefully, so that their ‹F› images will enable the
cancellation of the various isomorphisms that appear.›
obtain a⇩C where a⇩C: "C.obj a⇩C ∧ D.equivalent_objects (map⇩0 a⇩C) a"
using w a_def biessentially_surjective_on_objects D.obj_src D.ideD(1)
by presburger
obtain e where e: "«e : map⇩0 a⇩C →⇩D a» ∧ D.equivalence_map e"
using a⇩C D.equivalent_objects_def by auto
obtain d η ε
where dηε: "adjoint_equivalence_in_bicategory (⋅⇩D) (⋆⇩D) 𝖺⇩D 𝗂⇩D src⇩D trg⇩D e d η ε"
using e D.equivalence_map_extends_to_adjoint_equivalence by blast
interpret e: adjoint_equivalence_in_bicategory ‹(⋅⇩D)› ‹(⋆⇩D)› 𝖺⇩D 𝗂⇩D src⇩D trg⇩D e d η ε
using dηε by auto
interpret d: adjoint_equivalence_in_bicategory ‹(⋅⇩D)› ‹(⋆⇩D)› 𝖺⇩D 𝗂⇩D src⇩D trg⇩D
d e "D.inv ε" "D.inv η"
using e.dual_adjoint_equivalence by simp
have [simp]: "src⇩D e = map⇩0 a⇩C"
using e by auto
have [simp]: "trg⇩D e = a"
using e by auto
have [simp]: "src⇩D d = a"
using e.antipar by simp
have [simp]: "trg⇩D d = map⇩0 a⇩C"
using e.antipar by simp
have we: "«w ⋆⇩D e : map⇩0 a⇩C →⇩D map⇩0 (src⇩C ρ)»"
using a⇩C e D.ideD(1) ‹trg⇩D w = map⇩0 (src⇩C ρ)› a_def by blast
obtain w⇩C where
w⇩C: "C.ide w⇩C ∧ «w⇩C : a⇩C →⇩C src⇩C ρ» ∧ D.isomorphic (F w⇩C) (w ⋆⇩D e)"
using a⇩C e we locally_essentially_surjective [of a⇩C "src⇩C ρ" "w ⋆⇩D e"]
C.obj_src T.tab_simps(1) e.ide_left w by blast
have w'e: "«w' ⋆⇩D e : map⇩0 a⇩C →⇩D map⇩0 (src⇩C ρ)»"
using a⇩C e D.ideD(1) ‹trg⇩D w' = map⇩0 (src⇩C ρ)› a_def ‹src⇩D w' = a› w' by blast
obtain w⇩C' where
w⇩C': "C.ide w⇩C' ∧ «w⇩C' : a⇩C →⇩C src⇩C ρ» ∧ D.isomorphic (F w⇩C') (w' ⋆⇩D e)"
using a⇩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⇩C w⇩C = a⇩C"
using w⇩C by auto
have [simp]: "trg⇩C w⇩C = src⇩C ρ"
using w⇩C by auto
have [simp]: "src⇩C w⇩C' = a⇩C"
using w⇩C' by auto
have [simp]: "trg⇩C w⇩C' = src⇩C ρ"
using w⇩C' by auto
obtain φ where φ: "«φ : F w⇩C ⇒⇩D w ⋆⇩D e» ∧ D.iso φ"
using w⇩C D.isomorphicE by blast
obtain φ' where φ': "«φ' : F w⇩C' ⇒⇩D w' ⋆⇩D e» ∧ D.iso φ'"
using w⇩C' D.isomorphicE by blast
have ue: "«u ⋆⇩D e : map⇩0 a⇩C →⇩D map⇩0 (trg⇩C f)» ∧ D.ide (u ⋆⇩D e)"
using a⇩C e θ e.ide_left
by (intro conjI, auto)
obtain u⇩C where
u⇩C: "C.ide u⇩C ∧ «u⇩C : a⇩C →⇩C trg⇩C f» ∧ D.isomorphic (F u⇩C) (u ⋆⇩D e)"
using a⇩C e ue locally_essentially_surjective [of a⇩C "trg⇩C f" "u ⋆⇩D e"] by auto
have [simp]: "src⇩C u⇩C = a⇩C"
using u⇩C by auto
have [simp]: "trg⇩C u⇩C = trg⇩C f"
using u⇩C by auto
obtain ψ where ψ: "«ψ : u ⋆⇩D e ⇒⇩D F u⇩C» ∧ D.iso ψ"
using u⇩C D.isomorphic_symmetric D.isomorphicE by blast
define Fθ⇩C where
"Fθ⇩C = ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w⇩C))"
have 1: "«Fθ⇩C : F (f ⋆⇩C w⇩C) ⇒⇩D F u⇩C»"
proof (unfold Fθ⇩C_def, intro D.comp_in_homI)
show "«D.inv (Φ (f, w⇩C)) : F (f ⋆⇩C w⇩C) ⇒⇩D F f ⋆⇩D F w⇩C»"
by (simp add: cmp_in_hom(2) w⇩C)
show "«F f ⋆⇩D φ : F f ⋆⇩D F w⇩C ⇒⇩D F f ⋆⇩D w ⋆⇩D e»"
using w w⇩C φ by (intro D.hcomp_in_vhom, auto)
show "«𝖺⇩D⇧-⇧1[F f, w, e] : F f ⋆⇩D w ⋆⇩D e ⇒⇩D (F f ⋆⇩D w) ⋆⇩D e»"
using w D.assoc'_in_hom by simp
show "«θ ⋆⇩D e : (F f ⋆⇩D w) ⋆⇩D e ⇒⇩D u ⋆⇩D e»"
using w θ by (intro D.hcomp_in_vhom, auto)
show "«ψ : u ⋆⇩D e ⇒⇩D F u⇩C»"
using ψ by simp
qed
have 2: "∃θ⇩C. «θ⇩C : f ⋆⇩C w⇩C ⇒⇩C u⇩C» ∧ F θ⇩C = Fθ⇩C"
using u⇩C w⇩C 1 e θ φ locally_full by simp
obtain θ⇩C where θ⇩C: "«θ⇩C : f ⋆⇩C w⇩C ⇒⇩C u⇩C» ∧ F θ⇩C = Fθ⇩C"
using 2 by auto
define Fθ⇩C' where
"Fθ⇩C' = ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D D.inv (Φ (f, w⇩C'))"
have 1: "«Fθ⇩C' : F (f ⋆⇩C w⇩C') ⇒⇩D F u⇩C»"
proof (unfold Fθ⇩C'_def, intro D.comp_in_homI)
show "«D.inv (Φ (f, w⇩C')) : F (f ⋆⇩C w⇩C') ⇒⇩D F f ⋆⇩D F w⇩C'»"
by (simp add: cmp_in_hom(2) w⇩C')
show "«F f ⋆⇩D φ' : F f ⋆⇩D F w⇩C' ⇒⇩D F f ⋆⇩D w' ⋆⇩D e»"
using w' w⇩C' φ' by (intro D.hcomp_in_vhom, auto)
show "«𝖺⇩D⇧-⇧1[F f, w', e] : F f ⋆⇩D w' ⋆⇩D e ⇒⇩D (F f ⋆⇩D w') ⋆⇩D e»"
using w' D.assoc'_in_hom by simp
show "«θ' ⋆⇩D e : (F f ⋆⇩D w') ⋆⇩D e ⇒⇩D u ⋆⇩D e»"
using w' θ' by (intro D.hcomp_in_vhom, auto)
show "«ψ : u ⋆⇩D e ⇒⇩D F u⇩C»"
using ψ by simp
qed
have 2: "∃θ⇩C'. «θ⇩C' : f ⋆⇩C w⇩C' ⇒⇩C u⇩C» ∧ F θ⇩C' = Fθ⇩C'"
using u⇩C w⇩C' 1 e θ φ locally_full by simp
obtain θ⇩C' where θ⇩C': "«θ⇩C' : f ⋆⇩C w⇩C' ⇒⇩C u⇩C» ∧ F θ⇩C' = Fθ⇩C'"
using 2 by auto
define Fβ⇩C where
"Fβ⇩C = Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
have Fβ⇩C: "«Fβ⇩C: F (g ⋆⇩C w⇩C) ⇒⇩D F (g ⋆⇩C w⇩C')»"
proof (unfold Fβ⇩C_def, intro D.comp_in_homI)
show "«D.inv (Φ (g, w⇩C)) : F (g ⋆⇩C w⇩C) ⇒⇩D F g ⋆⇩D F w⇩C»"
by (simp add: cmp_in_hom(2) w⇩C)
show "«F g ⋆⇩D φ : F g ⋆⇩D F w⇩C ⇒⇩D F g ⋆⇩D w ⋆⇩D e»"
using w⇩C φ apply (intro D.hcomp_in_vhom) by auto
show "«𝖺⇩D⇧-⇧1[F g, w, e] : F g ⋆⇩D w ⋆⇩D e ⇒⇩D (F g ⋆⇩D w) ⋆⇩D e»"
using w D.assoc'_in_hom by simp
show "«β ⋆⇩D e : (F g ⋆⇩D w) ⋆⇩D e ⇒⇩D (F g ⋆⇩D w') ⋆⇩D e»"
using w β apply (intro D.hcomp_in_vhom) by auto
show "«𝖺⇩D[F g, w', e] : (F g ⋆⇩D w') ⋆⇩D e ⇒⇩D F g ⋆⇩D w' ⋆⇩D e»"
using w' e.antipar D.assoc_in_hom by simp
show "«F g ⋆⇩D D.inv φ' : F g ⋆⇩D w' ⋆⇩D e ⇒⇩D F g ⋆⇩D F w⇩C'»"
using w' w⇩C' φ' by (intro D.hcomp_in_vhom, auto)
show "«Φ (g, w⇩C') : F g ⋆⇩D F w⇩C' ⇒⇩D F (g ⋆⇩C w⇩C')»"
using w⇩C' cmp_in_hom by simp
qed
have 1: "∃β⇩C. «β⇩C : g ⋆⇩C w⇩C ⇒⇩C g ⋆⇩C w⇩C'» ∧ F β⇩C = Fβ⇩C"
using w⇩C w⇩C' Fβ⇩C locally_full by simp
obtain β⇩C where β⇩C: "«β⇩C : g ⋆⇩C w⇩C ⇒⇩C g ⋆⇩C w⇩C'» ∧ F β⇩C = Fβ⇩C"
using 1 by auto
text ‹
The following is the main calculation that needs to be done, to permit us
to apply ‹T.T2›.
Once again, it started out looking simple, but once all the necessary
isomorphisms are thrown in it looks much more complicated.
›
have *: "T.composite_cell w⇩C θ⇩C = T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C"
proof -
have par: "C.par (T.composite_cell w⇩C θ⇩C) (T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C)"
proof -
have "«T.composite_cell w⇩C θ⇩C : g ⋆⇩C w⇩C ⇒⇩C r ⋆⇩C u⇩C»"
using w⇩C θ⇩C T.composite_cell_in_hom by simp
moreover have "«T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C : g ⋆⇩C w⇩C ⇒⇩C r ⋆⇩C u⇩C»"
proof (intro C.comp_in_homI)
show "«β⇩C : g ⋆⇩C w⇩C ⇒⇩C g ⋆⇩C w⇩C'»"
using β⇩C by simp
show "«ρ ⋆⇩C w⇩C' : g ⋆⇩C w⇩C' ⇒⇩C (r ⋆⇩C f) ⋆⇩C w⇩C'»"
using w⇩C' by (intro C.hcomp_in_vhom, auto)
show "«𝖺⇩C[r, f, w⇩C'] : (r ⋆⇩C f) ⋆⇩C w⇩C' ⇒⇩C r ⋆⇩C f ⋆⇩C w⇩C'»"
using w⇩C' C.assoc_in_hom by simp
show "«r ⋆⇩C θ⇩C' : r ⋆⇩C f ⋆⇩C w⇩C' ⇒⇩C r ⋆⇩C u⇩C»"
using w⇩C' θ⇩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⇩C θ⇩C) = F (T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C)"
proof -
have "F (T.composite_cell w⇩C θ⇩C) = F (r ⋆⇩C θ⇩C) ⋅⇩D F 𝖺⇩C[r, f, w⇩C] ⋅⇩D F (ρ ⋆⇩C w⇩C)"
using par by auto
also have "... = (Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C) ⋅⇩D D.inv (Φ (r, f ⋆⇩C w⇩C))) ⋅⇩D
(Φ (r, f ⋆⇩C w⇩C) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C)) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w⇩C) ⋅⇩D D.inv (Φ (r ⋆⇩C f, w⇩C))) ⋅⇩D
(Φ (r ⋆⇩C f, w⇩C) ⋅⇩D (F ρ ⋆⇩D F w⇩C) ⋅⇩D D.inv (Φ (g, w⇩C)))"
proof -
have "src⇩C f = trg⇩C w⇩C ∧ C.hseq r θ⇩C ∧ C.hseq ρ w⇩C"
using par by auto
thus ?thesis
using w⇩C θ⇩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
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C) ⋅⇩D (((D.inv (Φ (r, f ⋆⇩C w⇩C))) ⋅⇩D
(Φ (r, f ⋆⇩C w⇩C))) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C))) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w⇩C) ⋅⇩D ((D.inv (Φ (r ⋆⇩C f, w⇩C))) ⋅⇩D
(Φ (r ⋆⇩C f, w⇩C)) ⋅⇩D (F ρ ⋆⇩D F w⇩C)) ⋅⇩D D.inv (Φ (g, w⇩C))"
using D.comp_assoc by simp
also have
"... = Φ (r, u⇩C) ⋅⇩D ((F r ⋆⇩D F θ⇩C) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C))) ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C] ⋅⇩D ((D.inv (Φ (r, f)) ⋆⇩D F w⇩C) ⋅⇩D (F ρ ⋆⇩D F w⇩C)) ⋅⇩D
D.inv (Φ (g, w⇩C))"
proof -
have
"(D.inv (Φ (r ⋆⇩C f, w⇩C)) ⋅⇩D Φ (r ⋆⇩C f, w⇩C)) ⋅⇩D (F ρ ⋆⇩D F w⇩C) = F ρ ⋆⇩D F w⇩C"
using w⇩C ‹trg⇩C w⇩C = src⇩C ρ› D.comp_inv_arr' cmp_in_hom cmp_components_are_iso
D.comp_cod_arr
by simp
moreover have
"((D.inv (Φ (r, f ⋆⇩C w⇩C))) ⋅⇩D (Φ (r, f ⋆⇩C w⇩C))) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C)) =
F r ⋆⇩D Φ (f, w⇩C)"
using w⇩C D.comp_cod_arr D.comp_inv_arr' cmp_simps(1,4) C.VV.cod_simp
by auto
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C ⋅⇩D Φ (f, w⇩C)) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C] ⋅⇩D
(?ρ' ⋆⇩D F w⇩C) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "(F r ⋆⇩D F θ⇩C) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C)) = F r ⋆⇩D F θ⇩C ⋅⇩D Φ (f, w⇩C)"
using θ⇩C w⇩C D.whisker_left cmp_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 (Φ (r, f)) ⋆⇩D F w⇩C) ⋅⇩D (F ρ ⋆⇩D F w⇩C) = ?ρ' ⋆⇩D F w⇩C"
using D.whisker_right by (simp add: w⇩C)
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D
D.inv (Φ (f, w⇩C)) ⋅⇩D Φ (f, w⇩C)) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C] ⋅⇩D
(?ρ' ⋆⇩D F w⇩C) ⋅⇩D D.inv (Φ (g, w⇩C))"
using θ⇩C Fθ⇩C_def D.comp_assoc by simp
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D
((F r ⋆⇩D F f ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C]) ⋅⇩D (?ρ' ⋆⇩D F w⇩C) ⋅⇩D
D.inv (Φ (g, w⇩C))"
proof -
have "F r ⋆⇩D ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D
D.inv (Φ (f, w⇩C)) ⋅⇩D Φ (f, w⇩C) =
F r ⋆⇩D ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D (F f ⋆⇩D φ)"
using cmp_in_hom cmp_components_are_iso D.comp_arr_dom
by (metis C.arrI D.cod_inv D.comp_inv_arr' D.seqE Fθ⇩C_def T.tab_simps(2)
T.ide_leg0 ‹trg⇩C w⇩C = src⇩C ρ› θ⇩C preserves_arr w⇩C)
also have "... = (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D
(F r ⋆⇩D F f ⋆⇩D φ)"
using D.whisker_left
by (metis (no_types, lifting) C.in_homE D.comp_assoc D.seqE Fθ⇩C_def T'.ide_base
θ⇩C preserves_arr)
finally have "F r ⋆⇩D ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D
D.inv (Φ (f, w⇩C)) ⋅⇩D Φ (f, w⇩C) =
(F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D
(F r ⋆⇩D F f ⋆⇩D φ)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D
𝖺⇩D[F r, F f, w ⋆⇩D e] ⋅⇩D (((F r ⋆⇩D F f) ⋆⇩D φ) ⋅⇩D (?ρ' ⋆⇩D F w⇩C)) ⋅⇩D
D.inv (Φ (g, w⇩C))"
proof -
have "(F r ⋆⇩D F f ⋆⇩D φ) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C] =
𝖺⇩D[F r, F f, w ⋆⇩D e] ⋅⇩D ((F r ⋆⇩D F f) ⋆⇩D φ)"
using w⇩C φ ‹trg⇩C w⇩C = src⇩C ρ› D.assoc_naturality [of "F r" "F f" φ]
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
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D ((F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D
𝖺⇩D[F r, F f, w ⋆⇩D e]) ⋅⇩D (?ρ' ⋆⇩D w ⋆⇩D e) ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D
D.inv (Φ (g, w⇩C))"
proof -
have "((F r ⋆⇩D F f) ⋆⇩D φ) ⋅⇩D (?ρ' ⋆⇩D F w⇩C) = ?ρ' ⋆⇩D φ ⋅⇩D F w⇩C"
using φ D.interchange
by (metis D.comp_arr_dom D.comp_cod_arr D.in_homE T'.tab_simps(1,5))
also have "... = ?ρ' ⋆⇩D (w ⋆⇩D e) ⋅⇩D φ"
using φ w⇩C D.comp_arr_dom D.comp_cod_arr by auto
also have "... = (?ρ' ⋆⇩D w ⋆⇩D e) ⋅⇩D (F g ⋆⇩D φ)"
using φ D.interchange
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 ⋆⇩D F f) ⋆⇩D φ) ⋅⇩D (?ρ' ⋆⇩D F w⇩C) = (?ρ' ⋆⇩D w ⋆⇩D e) ⋅⇩D (F g ⋆⇩D φ)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D ((F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D 𝖺⇩D[F r, F f ⋆⇩D w, e]) ⋅⇩D
(𝖺⇩D[F r, F f, w] ⋆⇩D e) ⋅⇩D (𝖺⇩D⇧-⇧1[F r ⋆⇩D F f, w, e] ⋅⇩D
(?ρ' ⋆⇩D w ⋆⇩D e)) ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "D.inv (F r ⋆⇩D 𝖺⇩D[F f, w, e]) = F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using w by simp
moreover have "D.seq (F r ⋆⇩D 𝖺⇩D[F f, w, e])
(𝖺⇩D[F r, F f ⋆⇩D w, e] ⋅⇩D (𝖺⇩D[F r, F f, w] ⋆⇩D e))"
using w by simp
moreover have
"(F r ⋆⇩D 𝖺⇩D[F f, w, e]) ⋅⇩D 𝖺⇩D[F r, F f ⋆⇩D w, e] ⋅⇩D (𝖺⇩D[F r, F f, w] ⋆⇩D e) =
𝖺⇩D[F r, F f, w ⋆⇩D e] ⋅⇩D 𝖺⇩D[F r ⋆⇩D F f, w, e]"
using w D.pentagon by simp
ultimately
have "(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D 𝖺⇩D[F r, F f, w ⋆⇩D e] =
𝖺⇩D[F r, F f ⋆⇩D w, e] ⋅⇩D (𝖺⇩D[F r, F f, w] ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F r ⋆⇩D F f, w, e]"
using w D.comp_assoc
D.invert_opposite_sides_of_square
[of "F r ⋆⇩D 𝖺⇩D[F f, w, e]" "𝖺⇩D[F r, F f ⋆⇩D w, e] ⋅⇩D (𝖺⇩D[F r, F f, w] ⋆⇩D e)"
"𝖺⇩D[F r, F f, w ⋆⇩D e]" "𝖺⇩D[F r ⋆⇩D F f, w, e]"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D (((F r ⋆⇩D θ) ⋆⇩D e) ⋅⇩D
(𝖺⇩D[F r, F f, w] ⋆⇩D e) ⋅⇩D ((?ρ' ⋆⇩D w) ⋆⇩D e)) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have
"(F r ⋆⇩D θ ⋆⇩D e) ⋅⇩D 𝖺⇩D[F r, F f ⋆⇩D w, e] = 𝖺⇩D[F r, u, e] ⋅⇩D ((F r ⋆⇩D θ) ⋆⇩D e)"
using D.assoc_naturality [of "F r" θ e] θ by auto
moreover have "𝖺⇩D⇧-⇧1[F r ⋆⇩D F f, w, e] ⋅⇩D (?ρ' ⋆⇩D w ⋆⇩D e) =
((?ρ' ⋆⇩D w) ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e]"
using w we e.ide_left D.assoc'_naturality [of ?ρ' w e] by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D
(T'.composite_cell w θ ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "((F r ⋆⇩D θ) ⋆⇩D e) ⋅⇩D (𝖺⇩D[F r, F f, w] ⋆⇩D e) ⋅⇩D ((?ρ' ⋆⇩D w) ⋆⇩D e) =
T'.composite_cell w θ ⋆⇩D e"
proof -
have "«T'.composite_cell w θ : F g ⋆⇩D w ⇒⇩D F r ⋆⇩D u»"
using w we θ ‹src⇩D θ = a› ‹trg⇩D e = a› 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)
‹trg⇩D w = map⇩0 (src⇩C ρ)› 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⇩C θ⇩C) =
Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D
(T'.composite_cell w θ ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
by simp
have "F (T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C) =
F ((r ⋆⇩C θ⇩C') ⋅⇩C 𝖺⇩C[r, f, w⇩C'] ⋅⇩C (ρ ⋆⇩C w⇩C') ⋅⇩C β⇩C)"
using C.comp_assoc by simp
also have "... = F(r ⋆⇩C θ⇩C') ⋅⇩D F 𝖺⇩C[r, f, w⇩C'] ⋅⇩D F (ρ ⋆⇩C w⇩C') ⋅⇩D F β⇩C"
using C.comp_assoc par by fastforce
also have "... = (Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C') ⋅⇩D D.inv (Φ (r, f ⋆⇩C w⇩C'))) ⋅⇩D
(Φ (r, f ⋆⇩C w⇩C') ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C')) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C'] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w⇩C') ⋅⇩D D.inv (Φ (r ⋆⇩C f, w⇩C'))) ⋅⇩D
(Φ (r ⋆⇩C f, w⇩C') ⋅⇩D (F ρ ⋆⇩D F w⇩C') ⋅⇩D D.inv (Φ (g, w⇩C'))) ⋅⇩D
Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "C.hseq r θ⇩C' ∧ C.hseq ρ w⇩C'"
using par by blast
thus ?thesis
using w⇩C' θ⇩C' β⇩C Fβ⇩C_def preserves_assoc [of r f w⇩C'] preserves_hcomp
by force
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C') ⋅⇩D ((D.inv (Φ (r, f ⋆⇩C w⇩C'))) ⋅⇩D
(Φ (r, f ⋆⇩C w⇩C')) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C'))) ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C'] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w⇩C') ⋅⇩D ((D.inv (Φ (r ⋆⇩C f, w⇩C')) ⋅⇩D
Φ (r ⋆⇩C f, w⇩C')) ⋅⇩D (F ρ ⋆⇩D F w⇩C')) ⋅⇩D ((D.inv (Φ (g, w⇩C')) ⋅⇩D
Φ (g, w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ')) ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using D.comp_assoc by simp
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C') ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C')) ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C'] ⋅⇩D
((D.inv (Φ (r, f)) ⋆⇩D F w⇩C') ⋅⇩D (F ρ ⋆⇩D F w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "(D.inv (Φ (r, f ⋆⇩C w⇩C'))) ⋅⇩D (Φ (r, f ⋆⇩C w⇩C')) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C')) =
F r ⋆⇩D Φ (f, w⇩C')"
proof -
have "D.seq (Φ (r, f ⋆⇩C w⇩C')) (F r ⋆⇩D Φ (f, w⇩C')) ∧
D.arr (D.inv (Φ (r, f ⋆⇩C w⇩C'))) ∧
D.dom (D.inv (Φ (r, f ⋆⇩C w⇩C'))) =
D.cod (Φ (r, f ⋆⇩C w⇩C') ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C')))"
by (metis D.seqE calculation par preserves_arr)
thus ?thesis
using C.ide_hcomp C.ideD(1) C.trg_hcomp D.invert_side_of_triangle(1)
T.ide_base T.ide_leg0 T.leg0_simps(3) T.tab_simps(2) cmp_components_are_iso
‹trg⇩C w⇩C' = src⇩C ρ› w⇩C'
by presburger
qed
moreover have
"(D.inv (Φ (r ⋆⇩C f, w⇩C')) ⋅⇩D Φ (r ⋆⇩C f, w⇩C')) ⋅⇩D (F ρ ⋆⇩D F w⇩C') =
F ρ ⋆⇩D F w⇩C'"
proof -
have "D.seq (F ρ ⋆⇩D F w⇩C') (D.inv (Φ (C.dom ρ, C.dom w⇩C'))) ∧
D.arr (Φ (r ⋆⇩C f, w⇩C')) ∧
D.dom (Φ (r ⋆⇩C f, w⇩C')) =
D.cod ((F ρ ⋆⇩D F w⇩C') ⋅⇩D D.inv (Φ (C.dom ρ, C.dom w⇩C')))"
by (metis C.hseqI' C.ide_char D.seqE T.tab_simps(1) T.tab_simps(5)
‹trg⇩C w⇩C' = src⇩C ρ› preserves_arr preserves_hcomp w⇩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) cmp_components_are_iso D.comp_cod_arr
‹trg⇩C w⇩C' = src⇩C ρ› w⇩C')
qed
moreover have "(D.inv (Φ (g, w⇩C')) ⋅⇩D Φ (g, w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ') =
F g ⋆⇩D D.inv φ'"
proof -
have "(D.inv (Φ (g, w⇩C')) ⋅⇩D Φ (g, w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ') =
(F g ⋆⇩D F w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ')"
using w⇩C' β⇩C Fβ⇩C_def cmp_components_are_iso D.comp_inv_arr' by simp
also have "... = F g ⋆⇩D D.inv φ'"
using D.comp_cod_arr [of "F g ⋆⇩D D.inv φ'" "F g ⋆⇩D F w⇩C'"]
by (metis D.cod_inv D.null_is_zero(2) D.hseq_char' D.in_homE
D.is_weak_composition T'.leg1_simps(6) φ'
weak_composition.hcomp_simps⇩W⇩C(3))
finally show ?thesis by blast
qed
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D F θ⇩C') ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C')) ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C'] ⋅⇩D (?ρ' ⋆⇩D F w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using w⇩C' D.whisker_right cmp_in_hom cmp_components_are_iso by simp
also have "... = Φ (r, u⇩C) ⋅⇩D
(F r ⋆⇩D ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D
D.inv (Φ (f, w⇩C'))) ⋅⇩D
(F r ⋆⇩D Φ (f, w⇩C')) ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C'] ⋅⇩D (?ρ' ⋆⇩D F w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using θ⇩C' Fθ⇩C'_def by simp
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D (F r ⋆⇩D F f ⋆⇩D φ') ⋅⇩D
(((F r ⋆⇩D D.inv (Φ (f, w⇩C'))) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C'))) ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C']) ⋅⇩D (?ρ' ⋆⇩D F w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "F r ⋆⇩D ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D
D.inv (Φ (f, w⇩C')) =
(F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D (F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D
(F r ⋆⇩D F f ⋆⇩D φ') ⋅⇩D (F r ⋆⇩D D.inv (Φ (f, w⇩C')))"
using D.whisker_left cmp_in_hom cmp_components_are_iso
by (metis C.arrI D.src.preserves_reflects_arr D.src_vcomp D.vseq_implies_hpar(1)
Fθ⇩C'_def T'.ide_base θ⇩C' preserves_arr)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D ((F r ⋆⇩D F f ⋆⇩D φ') ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C']) ⋅⇩D (?ρ' ⋆⇩D F w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "((F r ⋆⇩D D.inv (Φ (f, w⇩C'))) ⋅⇩D (F r ⋆⇩D Φ (f, w⇩C'))) ⋅⇩D
𝖺⇩D[F r, F f, F w⇩C'] =
𝖺⇩D[F r, F f, F w⇩C']"
using cmp_in_hom cmp_components_are_iso D.comp_cod_arr
D.whisker_left [of "F r" "D.inv (Φ (f, w⇩C'))" "Φ (f, w⇩C')"]
by (simp add: D.comp_inv_arr' w⇩C')
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D 𝖺⇩D[F r, F f, w' ⋆⇩D e] ⋅⇩D
(((F r ⋆⇩D F f) ⋆⇩D φ') ⋅⇩D (?ρ' ⋆⇩D F w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "(F r ⋆⇩D F f ⋆⇩D φ') ⋅⇩D 𝖺⇩D[F r, F f, F w⇩C'] =
𝖺⇩D[F r, F f, w' ⋆⇩D e] ⋅⇩D ((F r ⋆⇩D F f) ⋆⇩D φ')"
using w⇩C' φ' D.assoc_naturality [of "F r" "F f" φ']
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)
‹trg⇩C w⇩C' = src⇩C ρ› preserves_src preserves_trg)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D
(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D 𝖺⇩D[F r, F f, w' ⋆⇩D e] ⋅⇩D
(?ρ' ⋆⇩D w' ⋆⇩D e) ⋅⇩D (((F g ⋆⇩D φ') ⋅⇩D (F g ⋆⇩D D.inv φ')) ⋅⇩D
𝖺⇩D[F g, w', e]) ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "((F r ⋆⇩D F f) ⋆⇩D φ') ⋅⇩D (?ρ' ⋆⇩D F w⇩C') = (?ρ' ⋆⇩D w' ⋆⇩D e) ⋅⇩D (F g ⋆⇩D φ')"
using φ' 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 "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D (F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D
((F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D 𝖺⇩D[F r, F f, w' ⋆⇩D e]) ⋅⇩D
(?ρ' ⋆⇩D w' ⋆⇩D e) ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "((F g ⋆⇩D φ') ⋅⇩D (F g ⋆⇩D D.inv φ')) ⋅⇩D 𝖺⇩D[F g, w', e] = 𝖺⇩D[F g, w', e]"
proof -
have "((F g ⋆⇩D φ') ⋅⇩D (F g ⋆⇩D D.inv φ')) ⋅⇩D 𝖺⇩D[F g, w', e] =
(F g ⋆⇩D w' ⋆⇩D e) ⋅⇩D 𝖺⇩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 φ')
also have "... = 𝖺⇩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 "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D ((F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D
𝖺⇩D[F r, F f ⋆⇩D w', e]) ⋅⇩D (𝖺⇩D[F r, F f, w'] ⋆⇩D e) ⋅⇩D
(𝖺⇩D⇧-⇧1[F r ⋆⇩D F f, w', e] ⋅⇩D (?ρ' ⋆⇩D w' ⋆⇩D e)) ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D
(β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "D.inv (F r ⋆⇩D 𝖺⇩D[F f, w', e]) = F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]"
using w' by simp
moreover have "D.seq (F r ⋆⇩D 𝖺⇩D[F f, w', e])
(𝖺⇩D[F r, F f ⋆⇩D w', e] ⋅⇩D (𝖺⇩D[F r, F f, w'] ⋆⇩D e))"
using w' by simp
moreover have "D.iso (F r ⋆⇩D 𝖺⇩D[F f, w', e])"
using w' by simp
moreover have "D.iso 𝖺⇩D[F r ⋆⇩D F f, w', e]"
using w' by simp
moreover have "(F r ⋆⇩D 𝖺⇩D[F f, w', e]) ⋅⇩D 𝖺⇩D[F r, F f ⋆⇩D w', e] ⋅⇩D
(𝖺⇩D[F r, F f, w'] ⋆⇩D e) =
𝖺⇩D[F r, F f, w' ⋆⇩D e] ⋅⇩D 𝖺⇩D[F r ⋆⇩D F f, w', e]"
using w' D.pentagon by simp
ultimately
have "(F r ⋆⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D 𝖺⇩D[F r, F f, w' ⋆⇩D e] =
𝖺⇩D[F r, F f ⋆⇩D w', e] ⋅⇩D (𝖺⇩D[F r, F f, w'] ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F r ⋆⇩D F f, w', e]"
using w' D.comp_assoc
D.invert_opposite_sides_of_square
[of "F r ⋆⇩D 𝖺⇩D[F f, w', e]" "𝖺⇩D[F r, F f ⋆⇩D w', e] ⋅⇩D (𝖺⇩D[F r, F f, w'] ⋆⇩D e)"
"𝖺⇩D[F r, F f, w' ⋆⇩D e]" "𝖺⇩D[F r ⋆⇩D F f, w', e]"]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D (((F r ⋆⇩D θ') ⋆⇩D e) ⋅⇩D
(𝖺⇩D[F r, F f, w'] ⋆⇩D e) ⋅⇩D ((?ρ' ⋆⇩D w') ⋆⇩D e)) ⋅⇩D
((𝖺⇩D⇧-⇧1[F g, w', e] ⋅⇩D 𝖺⇩D[F g, w', e]) ⋅⇩D (β ⋆⇩D e)) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "(F r ⋆⇩D θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D[F r, F f ⋆⇩D w', e] =
𝖺⇩D[F r, u, e] ⋅⇩D ((F r ⋆⇩D θ') ⋆⇩D e)"
using D.assoc_naturality [of "F r" θ' e] θ' by auto
moreover have "𝖺⇩D⇧-⇧1[F r ⋆⇩D F f, w', e] ⋅⇩D (?ρ' ⋆⇩D w' ⋆⇩D e) =
((?ρ' ⋆⇩D w') ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w', e]"
using w' w'e D.assoc'_naturality [of ?ρ' w' e] by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D
(T'.composite_cell w' θ' ⋆⇩D e) ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "((F r ⋆⇩D θ') ⋆⇩D e) ⋅⇩D (𝖺⇩D[F r, F f, w'] ⋆⇩D e) ⋅⇩D ((?ρ' ⋆⇩D w') ⋆⇩D e) =
T'.composite_cell w' θ' ⋆⇩D e"
proof -
have "«T'.composite_cell w' θ' : F g ⋆⇩D w' ⇒⇩D F r ⋆⇩D u»"
using θ' 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 "(𝖺⇩D⇧-⇧1[F g, w', e] ⋅⇩D 𝖺⇩D[F g, w', e]) ⋅⇩D (β ⋆⇩D e) = β ⋆⇩D e"
using w' β e.ide_left ‹src⇩D w' = a› ‹trg⇩D e = a› Fβ⇩C Fβ⇩C_def D.comp_cod_arr
D.comp_arr_inv'
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) ‹trg⇩D w' = map⇩0 (src⇩C ρ)› preserves_src)
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D
(T'.composite_cell w' θ' ⋅⇩D β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
proof -
have "D.arr (T'.composite_cell w' θ' ⋅⇩D β)"
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⇩C' θ⇩C' ⋅⇩C β⇩C) =
Φ (r, u⇩C) ⋅⇩D (F r ⋆⇩D ψ) ⋅⇩D 𝖺⇩D[F r, u, e] ⋅⇩D
(T'.composite_cell w' θ' ⋅⇩D β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
by simp
show "F (T.composite_cell w⇩C θ⇩C) = F (T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C)"
using eq L R by simp
qed
ultimately show ?thesis
using is_faithful [of "T.composite_cell w⇩C θ⇩C" "T.composite_cell w⇩C' θ⇩C' ⋅⇩C β⇩C"]
by simp
qed
have **: "∃!γ. «γ : w⇩C ⇒⇩C w⇩C'» ∧ β⇩C = g ⋆⇩C γ ∧ θ⇩C = θ⇩C' ⋅⇩C (f ⋆⇩C γ)"
using * w⇩C w⇩C' θ⇩C θ⇩C' β⇩C T.T2 [of w⇩C w⇩C' θ⇩C u⇩C θ⇩C' β⇩C] by simp
obtain γ⇩C where
γ⇩C: "«γ⇩C : w⇩C ⇒⇩C w⇩C'» ∧ β⇩C = g ⋆⇩C γ⇩C ∧ θ⇩C = θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C)"
using ** by auto
have γ⇩C_unique: "⋀γ⇩C'. «γ⇩C' : w⇩C ⇒⇩C w⇩C'» ∧ β⇩C = g ⋆⇩C γ⇩C' ∧
θ⇩C = θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C') ⟹ γ⇩C' = γ⇩C"
using γ⇩C ** by blast
text ‹
Now use ‹F› to map everything back to ‹D›, transport the result along the
equivalence map ‹e›, and cancel all of the isomorphisms that got introduced.
›
let ?P = "λγ. «γ : w ⋆⇩D e ⇒⇩D w' ⋆⇩D e» ∧
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] = F g ⋆⇩D γ ∧
ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γ)"
define γe where "γe = φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ"
have Pγe: "?P γe"
proof -
have 1: "«F γ⇩C : F w⇩C ⇒⇩D F w⇩C'» ∧
F β⇩C = Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (g, w⇩C)) ∧
F θ⇩C = F θ⇩C' ⋅⇩D Φ (f, C.cod γ⇩C) ⋅⇩D (F f ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (f, w⇩C))"
using β⇩C θ⇩C γ⇩C preserves_hcomp [of f γ⇩C] preserves_hcomp [of g γ⇩C] by force
have A: "𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] =
F g ⋆⇩D φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ"
proof -
have "F g ⋆⇩D F γ⇩C = D.inv (Φ (g, w⇩C')) ⋅⇩D F β⇩C ⋅⇩D Φ (g, w⇩C)"
proof -
have "F β⇩C = Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (g, w⇩C))"
using 1 by simp
hence "D.inv (Φ (g, w⇩C')) ⋅⇩D F β⇩C = (F g ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (g, w⇩C))"
using w⇩C w⇩C' ‹trg⇩C w⇩C = src⇩C ρ› ‹trg⇩C w⇩C' = src⇩C ρ› cmp_components_are_iso
D.invert_side_of_triangle(1)
by (metis D.arrI Fβ⇩C T.ide_leg1 T.leg1_simps(3) T.tab_simps(2) β⇩C)
hence "(D.inv (Φ (g, w⇩C')) ⋅⇩D F β⇩C) ⋅⇩D Φ (g, w⇩C) = F g ⋆⇩D F γ⇩C"
using cmp_components_are_iso D.invert_side_of_triangle(2)
by (metis "1" D.arrI D.inv_inv D.iso_inv_iso D.seqE Fβ⇩C T.ide_leg1
T.leg1_simps(3) T.tab_simps(2) β⇩C ‹trg⇩C w⇩C = src⇩C ρ› w⇩C)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = ((D.inv (Φ (g, w⇩C')) ⋅⇩D Φ (g, w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ')) ⋅⇩D
𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D
D.inv (Φ (g, w⇩C)) ⋅⇩D Φ (g, w⇩C)"
using β⇩C Fβ⇩C_def D.comp_assoc by simp
also have "... = (F g ⋆⇩D D.inv φ') ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ)"
proof -
have "(D.inv (Φ (g, w⇩C')) ⋅⇩D Φ (g, w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ') = F g ⋆⇩D D.inv φ'"
proof -
have "(D.inv (Φ (g, w⇩C')) ⋅⇩D Φ (g, w⇩C')) ⋅⇩D (F g ⋆⇩D D.inv φ') =
(F g ⋆⇩D F w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ')"
using w⇩C' φ' cmp_components_are_iso D.comp_inv_arr' by simp
also have "... = F g ⋆⇩D D.inv φ'"
using w⇩C' φ' 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 ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C)) ⋅⇩D Φ (g, w⇩C) = F g ⋆⇩D φ"
proof -
have "(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C)) ⋅⇩D Φ (g, w⇩C) =
(F g ⋆⇩D φ) ⋅⇩D (F g ⋆⇩D F w⇩C)"
using w⇩C φ ‹trg⇩C w⇩C = src⇩C ρ› cmp_components_are_iso cmp_in_hom
D.comp_inv_arr'
by simp
also have "... = F g ⋆⇩D φ"
using w⇩C φ 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 ⋆⇩D D.inv φ') ⋅⇩D (𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e]) ⋅⇩D (F g ⋆⇩D φ) =
F g ⋆⇩D F γ⇩C"
using D.comp_assoc by simp
have 3: "(𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e]) ⋅⇩D (F g ⋆⇩D φ) =
(F g ⋆⇩D φ') ⋅⇩D (F g ⋆⇩D F γ⇩C)"
proof -
have "D.hseq (F g) (F γ⇩C)"
using "1" Fβ⇩C β⇩C by auto
moreover have "D.iso (F g ⋆⇩D D.inv φ')"
by (metis "2" D.iso_hcomp D.hseqE D.ide_is_iso D.iso_inv_iso D.seqE
T'.ide_leg1 φ' calculation)
moreover have "D.inv (F g ⋆⇩D D.inv φ') = F g ⋆⇩D φ'"
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 φ' calculation(2))
ultimately show ?thesis
using 2 φ φ'
D.invert_side_of_triangle(1)
[of "F g ⋆⇩D F γ⇩C" "F g ⋆⇩D D.inv φ'"
"(𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e]) ⋅⇩D (F g ⋆⇩D φ)"]
by auto
qed
hence "𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] =
((F g ⋆⇩D φ') ⋅⇩D (F g ⋆⇩D F γ⇩C)) ⋅⇩D (F g ⋆⇩D D.inv φ)"
proof -
have "D.seq (F g ⋆⇩D φ') (F g ⋆⇩D F γ⇩C)"
by (metis "1" "2" "3" D.arrI D.null_is_zero(1) D.null_is_zero(2) D.ext Fβ⇩C β⇩C)
moreover have "D.iso (F g ⋆⇩D φ)"
using D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) φ we by auto
moreover have "D.inv (F g ⋆⇩D φ) = F g ⋆⇩D D.inv φ"
by (metis D.hseqE D.ide_is_iso D.inv_hcomp D.inv_ide D.iso_is_arr
T'.ide_leg1 φ calculation(2))
ultimately show ?thesis
using 3 φ φ'
D.invert_side_of_triangle(2)
[of "(F g ⋆⇩D φ') ⋅⇩D (F g ⋆⇩D F γ⇩C)"
"𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e]" "F g ⋆⇩D φ"]
by auto
qed
also have "... = F g ⋆⇩D φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ"
using φ' 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 φ)
finally show ?thesis by simp
qed
have B: "ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ)"
proof -
have "F θ⇩C' ⋅⇩D Φ (f, w⇩C') ⋅⇩D (F f ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (f, w⇩C)) =
(ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D (D.inv (Φ (f, w⇩C')) ⋅⇩D
Φ (f, w⇩C')) ⋅⇩D (F f ⋆⇩D F γ⇩C)) ⋅⇩D D.inv (Φ (f, w⇩C))"
using γ⇩C θ⇩C' Fθ⇩C'_def D.comp_assoc by auto
also have "... = ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D
(F f ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (f, w⇩C))"
proof -
have "(D.inv (Φ (f, w⇩C')) ⋅⇩D Φ (f, w⇩C')) ⋅⇩D (F f ⋆⇩D F γ⇩C) = F f ⋆⇩D F γ⇩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 cmp_components_are_iso γ⇩C 1 ‹trg⇩C w⇩C' = src⇩C ρ›
θ⇩C preserves_arr w⇩C')
thus ?thesis
using D.comp_assoc by simp
qed
finally have "F θ⇩C' ⋅⇩D Φ (f, w⇩C') ⋅⇩D (F f ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (f, w⇩C)) =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D
(F f ⋆⇩D F γ⇩C) ⋅⇩D D.inv (Φ (f, w⇩C))"
by simp
hence 3: "F θ⇩C' ⋅⇩D Φ (f, w⇩C') ⋅⇩D (F f ⋆⇩D F γ⇩C) =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D (F f ⋆⇩D F γ⇩C)"
using cmp_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 γ⇩C 1
‹trg⇩C w⇩C = src⇩C ρ› θ⇩C preserves_arr w⇩C)
hence "(ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D (F f ⋆⇩D φ)) ⋅⇩D D.inv (Φ (f, w⇩C)) =
(ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D
(F f ⋆⇩D F γ⇩C)) ⋅⇩D D.inv (Φ (f, w⇩C))"
using 1 θ⇩C Fθ⇩C_def D.comp_assoc by (metis C.in_homE γ⇩C)
hence 2: "(ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]) ⋅⇩D (F f ⋆⇩D φ) =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ') ⋅⇩D (F f ⋆⇩D F γ⇩C)"
using γ⇩C cmp_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 ‹trg⇩C w⇩C = src⇩C ρ› θ⇩C preserves_arr w⇩C)
hence "ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] =
(ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e]) ⋅⇩D
(F f ⋆⇩D φ') ⋅⇩D (F f ⋆⇩D F γ⇩C) ⋅⇩D (F f ⋆⇩D D.inv φ)"
proof -
have "D.inv (F f ⋆⇩D φ) = F f ⋆⇩D D.inv φ"
using φ
by (metis C.arrI D.hseq_char D.ide_is_iso D.inv_hcomp D.inv_ide D.seqE Fθ⇩C_def
T'.ide_leg0 preserves_arr θ⇩C)
thus ?thesis
using φ φ' θ θ' γ⇩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θ⇩C_def T'.ide_leg0 θ⇩C preserves_arr)
qed
also have "... = ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D
(F f ⋆⇩D φ') ⋅⇩D (F f ⋆⇩D F γ⇩C) ⋅⇩D (F f ⋆⇩D D.inv φ)"
using D.comp_assoc by simp
also have
"... = ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ)"
proof -
have "D.arr (φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ)"
using "1" φ φ' by blast
thus ?thesis
using D.whisker_left by auto
qed
finally show ?thesis by simp
qed
have C: "«φ' ⋅⇩D F γ⇩C ⋅⇩D D.inv φ : w ⋆⇩D e ⇒⇩D w' ⋆⇩D e»"
using φ φ' γ⇩C 1 by (meson D.comp_in_homI D.inv_in_hom)
show ?thesis
unfolding γe_def
using A B C by simp
qed
have UN: "⋀γ. ?P γ ⟹ γ = γe"
proof -
fix γ
assume γ: "?P γ"
show "γ = γe"
proof -
let ?γ' = "D.inv φ' ⋅⇩D γ ⋅⇩D φ"
have γ': "«?γ' : F w⇩C ⇒⇩D F w⇩C'»"
using γ φ φ' by auto
obtain γ⇩C' where γ⇩C': "«γ⇩C' : w⇩C ⇒⇩C w⇩C'» ∧ F γ⇩C' = ?γ'"
using w⇩C w⇩C' γ γ' locally_full by fastforce
have 1: "β⇩C = g ⋆⇩C γ⇩C'"
proof -
have "F β⇩C = F (g ⋆⇩C γ⇩C')"
proof -
have "F β⇩C =
Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D 𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, e] ⋅⇩D (F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using β⇩C Fβ⇩C_def by simp
have "F (g ⋆⇩C γ⇩C') =
Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ' ⋅⇩D γ ⋅⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using γ⇩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) ‹trg⇩C w⇩C = src⇩C ρ›)
also have "... = Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D (F g ⋆⇩D γ) ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using φ φ' D.whisker_left D.comp_assoc
by (metis D.arrI D.seqE Fβ⇩C_def T'.ide_leg1 γ γ')
also have "... = Φ (g, w⇩C') ⋅⇩D (F g ⋆⇩D D.inv φ') ⋅⇩D
(𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e]) ⋅⇩D
(F g ⋆⇩D φ) ⋅⇩D D.inv (Φ (g, w⇩C))"
using γ D.comp_assoc by simp
also have "... = F β⇩C"
using β⇩C Fβ⇩C_def D.comp_assoc by simp
finally show ?thesis by simp
qed
moreover have "C.par β⇩C (g ⋆⇩C γ⇩C')"
proof (intro conjI)
show "C.arr β⇩C"
using β⇩C by blast
show 2: "C.hseq g γ⇩C'"
using Fβ⇩C β⇩C calculation by fastforce
show "C.dom β⇩C = C.dom (g ⋆⇩C γ⇩C')"
using 2 β⇩C γ⇩C' by fastforce
show "C.cod β⇩C = C.cod (g ⋆⇩C γ⇩C')"
using 2 β⇩C γ⇩C' by fastforce
qed
ultimately show ?thesis using is_faithful by blast
qed
have 2: "θ⇩C = θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C')"
proof -
have "F θ⇩C = F (θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C'))"
proof -
have "F (θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C')) = F θ⇩C' ⋅⇩D F (f ⋆⇩C γ⇩C')"
using θ⇩C' γ⇩C' by force
also have
"... = F θ⇩C' ⋅⇩D Φ (f, w⇩C') ⋅⇩D (F f ⋆⇩D D.inv φ' ⋅⇩D γ ⋅⇩D φ) ⋅⇩D D.inv (Φ (f, w⇩C))"
using w⇩C w⇩C' θ⇩C' γ⇩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) ‹trg⇩C w⇩C = src⇩C ρ›)
also have "... = F θ⇩C' ⋅⇩D Φ (f, w⇩C') ⋅⇩D
((F f ⋆⇩D D.inv φ') ⋅⇩D (F f ⋆⇩D γ) ⋅⇩D (F f ⋆⇩D φ)) ⋅⇩D
D.inv (Φ (f, w⇩C))"
using D.whisker_left
by (metis D.arrI D.seqE T'.ide_leg0 γ')
also have "... = ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (((F f ⋆⇩D φ') ⋅⇩D
(D.inv (Φ (f, w⇩C')) ⋅⇩D Φ (f, w⇩C')) ⋅⇩D (F f ⋆⇩D D.inv φ')) ⋅⇩D
(F f ⋆⇩D γ)) ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w⇩C))"
using θ⇩C' Fθ⇩C'_def D.comp_assoc by simp
also have "... = (ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γ)) ⋅⇩D
(F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w⇩C))"
proof -
have "D.inv (Φ (f, w⇩C')) ⋅⇩D Φ (f, w⇩C') = F f ⋆⇩D F w⇩C'"
using w⇩C' cmp_in_hom cmp_components_are_iso
by (simp add: D.comp_inv_arr')
moreover have "D.hseq (F f) (D.inv φ')"
using φ' 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) γ preserves_src we)
ultimately have "(D.inv (Φ (f, w⇩C')) ⋅⇩D Φ (f, w⇩C')) ⋅⇩D (F f ⋆⇩D D.inv φ') =
F f ⋆⇩D D.inv φ'"
using w⇩C' φ' D.comp_cod_arr [of "F f ⋆⇩D D.inv φ'" "F f ⋆⇩D F w⇩C'"]
by fastforce
hence "((F f ⋆⇩D φ') ⋅⇩D (D.inv (Φ (f, w⇩C')) ⋅⇩D Φ (f, w⇩C')) ⋅⇩D
(F f ⋆⇩D D.inv φ')) ⋅⇩D (F f ⋆⇩D γ) =
((F f ⋆⇩D φ') ⋅⇩D (F f ⋆⇩D D.inv φ')) ⋅⇩D (F f ⋆⇩D γ)"
by simp
also have "... = F f ⋆⇩D γ"
using γ φ' θ⇩C' Fθ⇩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 ⋆⇩D φ') ⋅⇩D (D.inv (Φ (f, w⇩C')) ⋅⇩D Φ (f, w⇩C')) ⋅⇩D
(F f ⋆⇩D D.inv φ')) ⋅⇩D (F f ⋆⇩D γ) =
F f ⋆⇩D γ"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋅⇩D
(F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w⇩C))"
using γ D.comp_assoc by metis
also have "... = F θ⇩C"
using θ⇩C Fθ⇩C_def by simp
finally show ?thesis by simp
qed
moreover have "C.par θ⇩C (θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C'))"
proof (intro conjI)
show "C.arr θ⇩C"
using θ⇩C by auto
show 1: "C.seq θ⇩C' (f ⋆⇩C γ⇩C')"
using θ⇩C' γ⇩C'
by (metis C.arrI θ⇩C calculation preserves_reflects_arr)
show "C.dom θ⇩C = C.dom (θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C'))"
using 1 θ⇩C γ⇩C' by fastforce
show "C.cod θ⇩C = C.cod (θ⇩C' ⋅⇩C (f ⋆⇩C γ⇩C'))"
using 1 θ⇩C γ⇩C' γ⇩C by auto
qed
ultimately show ?thesis
using is_faithful by blast
qed
have "F γ⇩C' = F γ⇩C"
using ** γ⇩C γ⇩C' 1 2 by blast
hence "?γ' = F γ⇩C"
using γ⇩C' by simp
thus "γ = γe"
unfolding γ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 γ' φ φ')
qed
qed
text ‹We are now in a position to exhibit the 2-cell ‹γ› and show that it
is unique with the required properties.›
show ?thesis
proof
let ?γ = "𝗋⇩D[w'] ⋅⇩D (w' ⋆⇩D ε) ⋅⇩D 𝖺⇩D[w', e, d] ⋅⇩D (γe ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D
(w ⋆⇩D D.inv ε) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
have γ: "«?γ : w ⇒⇩D w'»"
using Pγe w w' e.counit_in_hom(2) e.counit_is_iso
apply (intro D.comp_in_homI)
apply auto[2]
apply fastforce
apply auto[3]
apply fastforce
by auto
moreover have "β = F g ⋆⇩D ?γ"
proof -
have "F g ⋆⇩D ?γ =
(F g ⋆⇩D 𝗋⇩D[w']) ⋅⇩D (F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D (F g ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(F g ⋆⇩D γe ⋆⇩D d) ⋅⇩D
(F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D (F g ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using w w' γ Pγe D.whisker_left e.antipar
by (metis D.arrI D.seqE T'.ide_leg1)
also have "... =
(F g ⋆⇩D 𝗋⇩D[w']) ⋅⇩D (F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D (F g ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D ((F g ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d]) ⋅⇩D
(F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D (F g ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D ((F g ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d] =
𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w' ⋆⇩D e, d] ⋅⇩D (F g ⋆⇩D γe ⋆⇩D d)"
using w w' e.antipar Pγe D.assoc'_naturality [of "F g" γ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
"... = (𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w' ⋆⇩D e, d]) ⋅⇩D (F g ⋆⇩D γe ⋆⇩D d)"
using D.comp_assoc by simp
also have "... = F g ⋆⇩D γe ⋆⇩D d"
proof -
have "(𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w' ⋆⇩D e, d]) ⋅⇩D (F g ⋆⇩D γe ⋆⇩D d) =
(F g ⋆⇩D (w' ⋆⇩D e) ⋆⇩D d) ⋅⇩D (F g ⋆⇩D γe ⋆⇩D d)"
using w'e D.isomorphic_implies_ide(2) w⇩C' D.comp_assoc_assoc'(1) by auto
also have "... = F g ⋆⇩D γe ⋆⇩D d"
proof -
have "«F g ⋆⇩D γe ⋆⇩D d : F g ⋆⇩D (w ⋆⇩D e) ⋆⇩D d ⇒⇩D F g ⋆⇩D (w' ⋆⇩D e) ⋆⇩D d»"
using we e.ide_right e.antipar Pγe by fastforce
thus ?thesis
using D.comp_cod_arr by auto
qed
finally show ?thesis by blast
qed
finally have
"𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D ((F g ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d] =
F g ⋆⇩D γe ⋆⇩D d"
by simp
thus ?thesis by simp
qed
also have "... =
(F g ⋆⇩D 𝗋⇩D[w']) ⋅⇩D (F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D (F g ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D
(𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d]) ⋅⇩D
(F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D (F g ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using Pγe by simp
also have
"... =
(F g ⋆⇩D 𝗋⇩D[w']) ⋅⇩D (F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D
(F g ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D (𝖺⇩D[F g, w', e] ⋆⇩D d) ⋅⇩D
((β ⋆⇩D e) ⋆⇩D d) ⋅⇩D
(𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d] ⋅⇩D (F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F g ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d =
(𝖺⇩D[F g, w', e] ⋆⇩D d) ⋅⇩D ((β ⋆⇩D e) ⋆⇩D d) ⋅⇩D (𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d)"
proof -
have "D.arr (𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e])"
using D.arrI D.in_hhom_def D.vconn_implies_hpar(2) Pγ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 ⋆⇩D 𝗋⇩D[w']) ⋅⇩D (F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D
((F g ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D (𝖺⇩D[F g, w', e] ⋆⇩D d) ⋅⇩D
(𝖺⇩D⇧-⇧1[F g ⋆⇩D w', e, d]) ⋅⇩D (β ⋆⇩D e ⋆⇩D d) ⋅⇩D (𝖺⇩D[F g ⋆⇩D w, e, d]) ⋅⇩D
(𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d] ⋅⇩D (F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d])) ⋅⇩D
(F g ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(β ⋆⇩D e) ⋆⇩D d =
𝖺⇩D⇧-⇧1[F g ⋆⇩D w', e, d] ⋅⇩D (β ⋆⇩D e ⋆⇩D d) ⋅⇩D 𝖺⇩D[F g ⋆⇩D w, e, d]"
proof -
have "src⇩D β = trg⇩D e"
using β
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
‹trg⇩D e = a› a_def)
moreover have "src⇩D (F g) = trg⇩D w"
by simp
moreover have "src⇩D (F g) = trg⇩D w'"
by simp
moreover have
"«(β ⋆⇩D e) ⋆⇩D d : ((F g ⋆⇩D w) ⋆⇩D e) ⋆⇩D d ⇒⇩D ((F g ⋆⇩D w') ⋆⇩D e) ⋆⇩D d»"
using β w w' e e.antipar
by (intro D.hcomp_in_vhom, auto)
ultimately have
"𝖺⇩D⇧-⇧1[F g ⋆⇩D w', e, d] ⋅⇩D (β ⋆⇩D e ⋆⇩D d) ⋅⇩D 𝖺⇩D[F g ⋆⇩D w, e, d] =
𝖺⇩D⇧-⇧1[F g ⋆⇩D w', e, d] ⋅⇩D 𝖺⇩D[F g ⋆⇩D w', e, d] ⋅⇩D ((β ⋆⇩D e) ⋆⇩D d)"
using w' e e.ide_left e.ide_right e.antipar β 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
"... = (𝖺⇩D⇧-⇧1[F g ⋆⇩D w', e, d] ⋅⇩D 𝖺⇩D[F g ⋆⇩D w', e, d]) ⋅⇩D ((β ⋆⇩D e) ⋆⇩D d)"
using D.comp_assoc by simp
also have "... = (((F g ⋆⇩D w') ⋆⇩D e) ⋆⇩D d) ⋅⇩D ((β ⋆⇩D e) ⋆⇩D d)"
using w' e e.antipar β D.comp_assoc_assoc' by simp
also have "... = (β ⋆⇩D e) ⋆⇩D d"
proof -
have "«(β ⋆⇩D e) ⋆⇩D d : ((F g ⋆⇩D w) ⋆⇩D e) ⋆⇩D d ⇒⇩D ((F g ⋆⇩D w') ⋆⇩D e) ⋆⇩D d»"
using w e e.antipar β
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 ⋆⇩D 𝗋⇩D[w']) ⋅⇩D ((F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D 𝖺⇩D[F g, w', e ⋆⇩D d]) ⋅⇩D
(β ⋆⇩D e ⋆⇩D d) ⋅⇩D
(𝖺⇩D⇧-⇧1[F g, w, e ⋆⇩D d] ⋅⇩D (F g ⋆⇩D w ⋆⇩D D.inv ε)) ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(F g ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D (𝖺⇩D[F g, w', e] ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F g ⋆⇩D w', e, d] =
𝖺⇩D[F g, w', e ⋆⇩D d]"
proof -
have "D.seq (F g ⋆⇩D 𝖺⇩D[w', e, d])
(𝖺⇩D[F g, w' ⋆⇩D e, d] ⋅⇩D (𝖺⇩D[F g, w', e] ⋆⇩D d))"
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) ‹src⇩D w' = a› ‹trg⇩D e = a› ‹trg⇩D w' = map⇩0 (src⇩C ρ)›
e.ide_left e.ide_right preserves_src
by metis
qed
moreover have
"𝖺⇩D[F g ⋆⇩D w, e, d] ⋅⇩D (𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d] ⋅⇩D
(F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) =
𝖺⇩D⇧-⇧1[F g, w, e ⋆⇩D d]"
proof -
have "D.seq (𝖺⇩D⇧-⇧1[F g, w, e] ⋆⇩D d)
(𝖺⇩D⇧-⇧1[F g, w ⋆⇩D e, d] ⋅⇩D (F g ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]))"
using w w' e e.antipar by simp
moreover have "D.inv 𝖺⇩D⇧-⇧1[F g ⋆⇩D w, e, d] = 𝖺⇩D[F g ⋆⇩D w, e, d]"
using w w' e e.antipar 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.null_is_zero(2) D.ide_hcomp D.ideD(1)
D.iso_assoc' D.not_arr_null D.seq_if_composable D.src_hcomp T'.ide_leg1
‹trg⇩D e = a› a_def e.ide_left e.ide_right)
qed
ultimately show ?thesis
using w w' e e.antipar β D.comp_assoc by metis
qed
also have "... = (F g ⋆⇩D 𝗋⇩D[w']) ⋅⇩D 𝖺⇩D[F g, w', trg⇩D e] ⋅⇩D
(((F g ⋆⇩D w') ⋆⇩D ε) ⋅⇩D (β ⋆⇩D e ⋆⇩D d) ⋅⇩D ((F g ⋆⇩D w) ⋆⇩D D.inv ε)) ⋅⇩D
𝖺⇩D⇧-⇧1[F g, w, trg⇩D e] ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(F g ⋆⇩D w' ⋆⇩D ε) ⋅⇩D 𝖺⇩D[F g, w', e ⋆⇩D d] =
𝖺⇩D[F g, w', trg⇩D e] ⋅⇩D ((F g ⋆⇩D w') ⋆⇩D ε)"
using w' e e.antipar D.assoc_naturality [of "F g" w' ε] by simp
moreover have "𝖺⇩D⇧-⇧1[F g, w, e ⋆⇩D d] ⋅⇩D (F g ⋆⇩D w ⋆⇩D D.inv ε) =
((F g ⋆⇩D w) ⋆⇩D D.inv ε) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, trg⇩D e]"
using w e e.antipar D.assoc'_naturality [of "F g" w "D.inv ε"]
e.counit_is_iso e.counit_in_hom
by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = ((F g ⋆⇩D 𝗋⇩D[w']) ⋅⇩D 𝖺⇩D[F g, w', trg⇩D e]) ⋅⇩D
(β ⋆⇩D trg⇩D e) ⋅⇩D
(𝖺⇩D⇧-⇧1[F g, w, trg⇩D e] ⋅⇩D (F g ⋆⇩D 𝗋⇩D⇧-⇧1[w]))"
proof -
have "((F g ⋆⇩D w') ⋆⇩D ε) ⋅⇩D (β ⋆⇩D e ⋆⇩D d) ⋅⇩D ((F g ⋆⇩D w) ⋆⇩D D.inv ε) =
β ⋆⇩D trg⇩D e"
proof -
have "((F g ⋆⇩D w') ⋆⇩D ε) ⋅⇩D (β ⋆⇩D e ⋆⇩D d) ⋅⇩D ((F g ⋆⇩D w) ⋆⇩D D.inv ε) =
((F g ⋆⇩D w') ⋆⇩D ε) ⋅⇩D (β ⋆⇩D D.inv ε)"
using w w' e e.antipar D.interchange [of β "F g ⋆⇩D w" "e ⋆⇩D d" "D.inv ε"]
D.comp_arr_dom D.comp_cod_arr e.counit_is_iso
by (metis D.in_homE β d.unit_simps(1) d.unit_simps(3))
also have "... = ((F g ⋆⇩D w') ⋆⇩D ε) ⋅⇩D ((F g ⋆⇩D w') ⋆⇩D D.inv ε) ⋅⇩D (β ⋆⇩D trg⇩D e)"
using w w' e e.antipar β D.interchange [of "F g ⋆⇩D w'" β "D.inv ε" "trg⇩D e"]
D.comp_arr_dom D.comp_cod_arr e.counit_is_iso
by auto
also have
"... = (((F g ⋆⇩D w') ⋆⇩D ε) ⋅⇩D ((F g ⋆⇩D w') ⋆⇩D D.inv ε)) ⋅⇩D (β ⋆⇩D trg⇩D e)"
using D.comp_assoc by simp
also have "... = ((F g ⋆⇩D w') ⋆⇩D ε ⋅⇩D D.inv ε) ⋅⇩D (β ⋆⇩D trg⇩D e)"
using w' D.whisker_left [of "F g ⋆⇩D w'"] by simp
also have "... = ((F g ⋆⇩D w') ⋆⇩D trg⇩D e) ⋅⇩D (β ⋆⇩D trg⇩D e)"
by (simp add: D.comp_arr_inv')
also have "... = β ⋆⇩D trg⇩D e"
using β D.comp_cod_arr D.hseqI'
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)
‹src⇩D w' = a› ‹trg⇩D e = a› 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 "... = 𝗋⇩D[F g ⋆⇩D w'] ⋅⇩D (β ⋆⇩D trg⇩D e) ⋅⇩D 𝗋⇩D⇧-⇧1[F g ⋆⇩D w]"
using w w' D.runit_hcomp D.runit_hcomp [of "F g" w] by simp
also have "... = 𝗋⇩D[F g ⋆⇩D w'] ⋅⇩D 𝗋⇩D⇧-⇧1[F g ⋆⇩D w'] ⋅⇩D β"
using β 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 ‹src⇩D w' = a› ‹trg⇩D e = a›)
also have "... = (𝗋⇩D[F g ⋆⇩D w'] ⋅⇩D 𝗋⇩D⇧-⇧1[F g ⋆⇩D w']) ⋅⇩D β"
using D.comp_assoc by simp
also have "... = β"
using w' β D.comp_cod_arr D.comp_arr_inv' D.iso_runit by auto
finally show ?thesis by simp
qed
moreover have "θ = θ' ⋅⇩D (F f ⋆⇩D ?γ)"
proof -
have "θ' ⋅⇩D (F f ⋆⇩D ?γ) =
θ' ⋅⇩D (F f ⋆⇩D 𝗋⇩D[w']) ⋅⇩D (F f ⋆⇩D w' ⋆⇩D ε) ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(F f ⋆⇩D γe ⋆⇩D d) ⋅⇩D
(F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D (F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using w θ γ D.whisker_left
by (metis D.arrI D.seqE T'.ide_leg0)
also have
"... = (θ' ⋅⇩D (F f ⋆⇩D 𝗋⇩D[w'])) ⋅⇩D (F f ⋆⇩D w' ⋆⇩D ε) ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]) ⋅⇩D
(F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D (F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have 1: "𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] =
𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w' ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d)"
using w w' e we w'e e.antipar Pγe D.assoc'_naturality [of "F f" γ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: "... = (𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w' ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d)"
using D.comp_assoc by simp
also have "... = F f ⋆⇩D γe ⋆⇩D d"
proof -
have "(𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w' ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d) =
(F f ⋆⇩D (w' ⋆⇩D e) ⋆⇩D d) ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d)"
using 1 2 e.antipar D.isomorphic_implies_ide(2) w⇩C' w'e D.comp_assoc_assoc'
by auto
also have "... = F f ⋆⇩D γe ⋆⇩D d"
proof -
have "«F f ⋆⇩D γe ⋆⇩D d : F f ⋆⇩D (w ⋆⇩D e) ⋆⇩D d ⇒⇩D F f ⋆⇩D (w' ⋆⇩D e) ⋆⇩D d»"
using we 1 2 e.antipar Pγe by fastforce
thus ?thesis
using D.comp_cod_arr by blast
qed
finally show ?thesis by blast
qed
finally have
"𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]) =
F f ⋆⇩D γe ⋆⇩D d"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = ((θ' ⋅⇩D 𝗋⇩D[F f ⋆⇩D w']) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', src⇩D w']) ⋅⇩D (F f ⋆⇩D w' ⋆⇩D ε) ⋅⇩D
(F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D (𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using w' D.runit_hcomp(3) [of "F f" w'] D.comp_assoc by simp
also have "... = 𝗋⇩D[u] ⋅⇩D (θ' ⋆⇩D src⇩D w') ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w', src⇩D w'] ⋅⇩D
(F f ⋆⇩D w' ⋆⇩D ε)) ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using θ' D.runit_naturality [of θ'] D.comp_assoc by fastforce
also have "... = 𝗋⇩D[u] ⋅⇩D ((θ' ⋆⇩D src⇩D w') ⋅⇩D ((F f ⋆⇩D w') ⋆⇩D ε)) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w', e ⋆⇩D d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using w' D.assoc'_naturality [of "F f" w' ε] D.comp_assoc by simp
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D (θ' ⋆⇩D e ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w', e ⋆⇩D d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d)) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(θ' ⋆⇩D src⇩D w') ⋅⇩D ((F f ⋆⇩D w') ⋆⇩D ε) = θ' ⋆⇩D ε"
using D.interchange D.comp_arr_dom D.comp_cod_arr
by (metis D.in_homE ‹src⇩D w' = a› ‹trg⇩D e = a› θ' e.counit_simps(1)
e.counit_simps(3))
also have "... = (u ⋆⇩D ε) ⋅⇩D (θ' ⋆⇩D e ⋆⇩D d)"
using θ' D.interchange [of u θ' ε "e ⋆⇩D d"] D.comp_arr_dom D.comp_cod_arr
by auto
finally have "(θ' ⋆⇩D src⇩D w') ⋅⇩D ((F f ⋆⇩D w') ⋆⇩D ε) = (u ⋆⇩D ε) ⋅⇩D (θ' ⋆⇩D e ⋆⇩D d)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D (θ' ⋆⇩D e ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w', e ⋆⇩D d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(F f ⋆⇩D γe ⋆⇩D d) ⋅⇩D ((𝖺⇩D[F f, w ⋆⇩D e, d] ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d])) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) =
(F f ⋆⇩D γe ⋆⇩D d) ⋅⇩D 𝖺⇩D[F f, w ⋆⇩D e, d]"
using D.assoc_naturality [of "F f" γe d]
by (metis D.cod_trg D.in_hhomE D.in_homE D.src_cod D.trg.preserves_cod Pγ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 "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D (θ' ⋆⇩D e ⋆⇩D d) ⋅⇩D
(𝖺⇩D⇧-⇧1[F f, w', e ⋆⇩D d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D
(F f ⋆⇩D γe ⋆⇩D d) ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(𝖺⇩D[F f, w ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) =
F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]"
using w D.comp_cod_arr D.comp_assoc_assoc' by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D (θ' ⋆⇩D e ⋆⇩D d) ⋅⇩D
((𝖺⇩D⇧-⇧1[F f, w', e ⋆⇩D d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F f, w' ⋆⇩D e, d]) ⋅⇩D
((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "F f ⋆⇩D γe ⋆⇩D d =
𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d]"
proof -
have "𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] =
𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w' ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d)"
using Pγ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) ‹src⇩D e = map⇩0 a⇩C›
d.triangle_equiv_form(1) d.triangle_in_hom(3) d.triangle_left
preserves_src we)
also have
"... = (𝖺⇩D[F f, w' ⋆⇩D e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w' ⋆⇩D e, d]) ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d)"
using D.comp_assoc by simp
also have "... = (F f ⋆⇩D (w' ⋆⇩D e) ⋆⇩D d) ⋅⇩D (F f ⋆⇩D γe ⋆⇩D d)"
using w'e D.isomorphic_implies_ide(2) w⇩C' D.comp_assoc_assoc' by auto
also have "... = F f ⋆⇩D γe ⋆⇩D d"
using D.comp_cod_arr
by (metis D.comp_cod_arr D.null_is_zero(2) D.hseq_char D.hseq_char'
D.in_homE D.whisker_left D.whisker_right Pγe T'.ide_leg0 e.ide_right)
finally show ?thesis by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D ((θ' ⋆⇩D e ⋆⇩D d) ⋅⇩D
𝖺⇩D[F f ⋆⇩D w', e, d]) ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w', e] ⋆⇩D d) ⋅⇩D
((F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(𝖺⇩D⇧-⇧1[F f, w', e ⋆⇩D d]) ⋅⇩D (F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F f, w' ⋆⇩D e, d] =
𝖺⇩D[F f ⋆⇩D w', e, d] ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w', e] ⋆⇩D d)"
proof -
have "𝖺⇩D[F f, w', e ⋆⇩D d] ⋅⇩D 𝖺⇩D[F f ⋆⇩D w', e, d] =
((F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F f, w' ⋆⇩D e, d]) ⋅⇩D (𝖺⇩D[F f, w', e] ⋆⇩D d)"
using w' D.pentagon D.comp_assoc by simp
moreover have "D.seq 𝖺⇩D[F f, w', e ⋆⇩D d] 𝖺⇩D[F f ⋆⇩D w', e, d]"
using w' by simp
moreover have "D.inv (𝖺⇩D[F f, w', e] ⋆⇩D d) = 𝖺⇩D⇧-⇧1[F f, w', e] ⋆⇩D d"
using w' by simp
ultimately show ?thesis
using w' D.comp_assoc
D.invert_opposite_sides_of_square
[of "𝖺⇩D[F f, w', e ⋆⇩D d]" "𝖺⇩D[F f ⋆⇩D w', e, d]"
"(F f ⋆⇩D 𝖺⇩D[w', e, d]) ⋅⇩D 𝖺⇩D[F f, w' ⋆⇩D e, d]"
"𝖺⇩D[F f, w', e] ⋆⇩D d"]
by simp
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have
"... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D 𝖺⇩D[u, e, d] ⋅⇩D
(((θ' ⋆⇩D e) ⋆⇩D d) ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w', e] ⋆⇩D d) ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d)) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(θ' ⋆⇩D e ⋆⇩D d) ⋅⇩D 𝖺⇩D[F f ⋆⇩D w', e, d] = 𝖺⇩D[u, e, d] ⋅⇩D ((θ' ⋆⇩D e) ⋆⇩D d)"
using w' θ' e.ide_left e.ide_right e.antipar D.assoc_naturality [of θ' e d]
by auto
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D 𝖺⇩D[u, e, d] ⋅⇩D
((θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γe) ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "((θ' ⋆⇩D e) ⋆⇩D d) ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w', e] ⋆⇩D d) ⋅⇩D ((F f ⋆⇩D γe) ⋆⇩D d) =
(θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γe) ⋆⇩D d"
using w' w'e θ' θ⇩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θ⇩C_def Pγe
preserves_arr)
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D 𝖺⇩D[u, e, d] ⋅⇩D
((θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γe) =
ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using Pγe by simp
moreover have "D.arr (ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γe))"
by (metis C.in_homE D.comp_assoc D.null_is_zero(1) D.ext Fθ⇩C_def Pγe θ⇩C
preserves_arr)
moreover have "D.arr (ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e])"
using Pγe calculation(2) by auto
ultimately have "(θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γe) =
(θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using ψ θ⇩C Fθ⇩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 "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D 𝖺⇩D[u, e, d] ⋅⇩D
((θ ⋆⇩D e) ⋆⇩D d) ⋅⇩D ((𝖺⇩D⇧-⇧1[F f, w, e] ⋆⇩D d) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w ⋆⇩D e, d] ⋅⇩D (F f ⋆⇩D 𝖺⇩D⇧-⇧1[w, e, d])) ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] ⋆⇩D d =
((θ ⋆⇩D e) ⋆⇩D d) ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w, e] ⋆⇩D d)"
proof -
have "D.arr ((θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e])"
by (metis C.arrI D.cod_comp D.seqE D.seqI Fθ⇩C_def θ⇩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 "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D 𝖺⇩D[u, e, d] ⋅⇩D
(((θ ⋆⇩D e) ⋆⇩D d) ⋅⇩D 𝖺⇩D⇧-⇧1[F f ⋆⇩D w, e, d]) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e ⋆⇩D d] ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using w D.pentagon' D.comp_assoc by simp
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D ((𝖺⇩D[u, e, d] ⋅⇩D
𝖺⇩D⇧-⇧1[u, e, d]) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d)) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e ⋆⇩D d] ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using θ e.antipar D.assoc'_naturality [of θ e d] D.comp_assoc by fastforce
also have "... = 𝗋⇩D[u] ⋅⇩D (u ⋆⇩D ε) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d) ⋅⇩D (𝖺⇩D⇧-⇧1[F f, w, e ⋆⇩D d] ⋅⇩D
(F f ⋆⇩D w ⋆⇩D D.inv ε)) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(𝖺⇩D[u, e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[u, e, d]) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d) = θ ⋆⇩D e ⋆⇩D d"
proof -
have "(𝖺⇩D[u, e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[u, e, d]) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d) =
(u ⋆⇩D e ⋆⇩D d) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d)"
using θ ue e.ide_left e.ide_right e.antipar D.comp_arr_inv' D.comp_cod_arr
by auto
also have "... = θ ⋆⇩D e ⋆⇩D d"
using ue e.ide_left e.ide_right e.antipar D.hcomp_simps(4) D.hseq_char' θ
D.comp_cod_arr [of "θ ⋆⇩D e ⋆⇩D d" "u ⋆⇩D e ⋆⇩D d"]
by force
finally show ?thesis by blast
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = 𝗋⇩D[u] ⋅⇩D ((u ⋆⇩D ε) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d)) ⋅⇩D ((F f ⋆⇩D w) ⋆⇩D D.inv ε) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w, trg⇩D e] ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
using w e.antipar D.assoc'_naturality [of "F f" w "D.inv ε"] D.comp_assoc by simp
also have
"... = 𝗋⇩D[u] ⋅⇩D (θ ⋆⇩D trg⇩D e) ⋅⇩D (((F f ⋆⇩D w) ⋆⇩D ε) ⋅⇩D ((F f ⋆⇩D w) ⋆⇩D D.inv ε) ⋅⇩D
𝖺⇩D⇧-⇧1[F f, w, trg⇩D e]) ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(u ⋆⇩D ε) ⋅⇩D (θ ⋆⇩D e ⋆⇩D d) = (θ ⋆⇩D trg⇩D e) ⋅⇩D ((F f ⋆⇩D w) ⋆⇩D ε)"
using θ e.antipar D.interchange D.comp_arr_dom D.comp_cod_arr
by (metis D.in_homE ‹trg⇩D e = a› e.counit_simps(1-3,5))
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = 𝗋⇩D[u] ⋅⇩D (θ ⋆⇩D trg⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, trg⇩D e] ⋅⇩D (F f ⋆⇩D 𝗋⇩D⇧-⇧1[w])"
proof -
have "(((F f ⋆⇩D w) ⋆⇩D ε) ⋅⇩D ((F f ⋆⇩D w) ⋆⇩D D.inv ε)) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, trg⇩D e] =
𝖺⇩D⇧-⇧1[F f, w, trg⇩D e]"
proof -
have "(((F f ⋆⇩D w) ⋆⇩D ε) ⋅⇩D ((F f ⋆⇩D w) ⋆⇩D D.inv ε)) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, trg⇩D e] =
((F f ⋆⇩D w) ⋆⇩D trg⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, trg⇩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) ‹trg⇩D w = map⇩0 (src⇩C ρ)›
d.unit_in_vhom e.counit_in_hom(2) e.counit_simps(3) preserves_src)
also have "... = 𝖺⇩D⇧-⇧1[F f, w, trg⇩D e]"
using w D.comp_cod_arr D.assoc'_in_hom(2) [of "F f" w "trg⇩D e"]
‹trg⇩D e = a› ‹trg⇩D w = map⇩0 (src⇩C ρ)›
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 "... = (𝗋⇩D[u] ⋅⇩D (θ ⋆⇩D trg⇩D e)) ⋅⇩D 𝗋⇩D⇧-⇧1[F f ⋆⇩D w]"
using w D.runit_hcomp(2) [of "F f" w] D.comp_assoc by simp
also have 1: "... = (θ ⋅⇩D 𝗋⇩D[F f ⋆⇩D w]) ⋅⇩D 𝗋⇩D⇧-⇧1[F f ⋆⇩D w]"
using θ D.runit_naturality [of θ] by auto
also have "... = θ"
using w θ D.comp_arr_dom D.comp_assoc
by (metis D.hcomp_arr_obj(2) D.in_homE D.obj_src 1 ‹src⇩D θ = a› ‹trg⇩D e = a›)
finally show ?thesis by simp
qed
ultimately show "«?γ : w ⇒⇩D w'» ∧ β = F g ⋆⇩D ?γ ∧ θ = θ' ⋅⇩D (F f ⋆⇩D ?γ)"
by simp
show "⋀γ'. «γ' : w ⇒⇩D w'» ∧ β = F g ⋆⇩D γ' ∧ θ = θ' ⋅⇩D (F f ⋆⇩D γ') ⟹ γ' = ?γ"
proof -
fix γ'
assume γ': "«γ' : w ⇒⇩D w'» ∧ β = F g ⋆⇩D γ' ∧ θ = θ' ⋅⇩D (F f ⋆⇩D γ')"
show "γ' = ?γ"
proof -
have "?γ = 𝗋⇩D[w'] ⋅⇩D (w' ⋆⇩D ε) ⋅⇩D (𝖺⇩D[w', e, d] ⋅⇩D ((γ' ⋆⇩D e) ⋆⇩D d)) ⋅⇩D
𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D (w ⋆⇩D D.inv ε) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
proof -
have "γe = γ' ⋆⇩D e"
proof -
have "«γ' ⋆⇩D e : w ⋆⇩D e ⇒⇩D w' ⋆⇩D e»"
using γ' by (intro D.hcomp_in_vhom, auto)
moreover have
"𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] = F g ⋆⇩D γ' ⋆⇩D e"
proof -
have "𝖺⇩D[F g, w', e] ⋅⇩D (β ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e] =
𝖺⇩D[F g, w', e] ⋅⇩D ((F g ⋆⇩D γ') ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w, e]"
using γ' by simp
also have "... = 𝖺⇩D[F g, w', e] ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w', e] ⋅⇩D (F g ⋆⇩D γ' ⋆⇩D e)"
using γ' 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) β
‹«γ' ⋆⇩D e : w ⋆⇩D e ⇒⇩D w' ⋆⇩D e»› e.ide_left)
also have "... = (𝖺⇩D[F g, w', e] ⋅⇩D 𝖺⇩D⇧-⇧1[F g, w', e]) ⋅⇩D (F g ⋆⇩D γ' ⋆⇩D e)"
using D.comp_assoc by simp
also have "... = F g ⋆⇩D γ' ⋆⇩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) β γ' calculation
‹«γ' ⋆⇩D e : w ⋆⇩D e ⇒⇩D w' ⋆⇩D e»› 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 "ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e] =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γ' ⋆⇩D e)"
proof -
have "ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w', e] ⋅⇩D (F f ⋆⇩D γ' ⋆⇩D e) =
ψ ⋅⇩D (θ' ⋆⇩D e) ⋅⇩D ((F f ⋆⇩D γ') ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using γ' θ 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) β calculation(1))
also have "... = ψ ⋅⇩D ((θ' ⋆⇩D e) ⋅⇩D ((F f ⋆⇩D γ') ⋆⇩D e)) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using D.comp_assoc by simp
also have "... = ψ ⋅⇩D (θ' ⋅⇩D (F f ⋆⇩D γ') ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using D.whisker_right γ' θ by auto
also have "... = ψ ⋅⇩D (θ ⋆⇩D e) ⋅⇩D 𝖺⇩D⇧-⇧1[F f, w, e]"
using γ' 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 "... = 𝗋⇩D[w'] ⋅⇩D ((w' ⋆⇩D ε) ⋅⇩D (γ' ⋆⇩D e ⋆⇩D d)) ⋅⇩D 𝖺⇩D[w, e, d] ⋅⇩D
𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D (w ⋆⇩D D.inv ε) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
using w' γ' D.comp_assoc D.assoc_naturality
by (metis D.in_homE D.src_dom ‹trg⇩D e = a› 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 "... = (𝗋⇩D[w'] ⋅⇩D (γ' ⋆⇩D trg⇩D e)) ⋅⇩D (w ⋆⇩D ε) ⋅⇩D 𝖺⇩D[w, e, d] ⋅⇩D
𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D (w ⋆⇩D D.inv ε) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
proof -
have "(w' ⋆⇩D ε) ⋅⇩D (γ' ⋆⇩D e ⋆⇩D d) = γ' ⋆⇩D ε"
using w' γ' e.antipar D.comp_arr_dom D.comp_cod_arr
D.interchange [of w' γ' ε "e ⋆⇩D d"]
by auto
also have "... = (γ' ⋆⇩D trg⇩D e) ⋅⇩D (w ⋆⇩D ε)"
using w γ' e.antipar D.comp_arr_dom D.comp_cod_arr D.interchange
by (metis D.in_homE ‹trg⇩D e = a› e.counit_simps(1) e.counit_simps(3,5))
finally have "(w' ⋆⇩D ε) ⋅⇩D (γ' ⋆⇩D e ⋆⇩D d) = (γ' ⋆⇩D trg⇩D e) ⋅⇩D (w ⋆⇩D ε)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = γ' ⋅⇩D 𝗋⇩D[w] ⋅⇩D (w ⋆⇩D ε) ⋅⇩D 𝖺⇩D[w, e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D
(w ⋆⇩D D.inv ε) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
using γ' D.runit_naturality D.comp_assoc
by (metis D.in_homE D.src_dom ‹trg⇩D e = a› a_def)
also have "... = γ'"
proof -
have "𝗋⇩D[w] ⋅⇩D (w ⋆⇩D ε) ⋅⇩D 𝖺⇩D[w, e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D (w ⋆⇩D D.inv ε) ⋅⇩D
𝗋⇩D⇧-⇧1[w] =
𝗋⇩D[w] ⋅⇩D ((w ⋆⇩D ε) ⋅⇩D (𝖺⇩D[w, e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[w, e, d]) ⋅⇩D (w ⋆⇩D D.inv ε)) ⋅⇩D
𝗋⇩D⇧-⇧1[w]"
using D.comp_assoc by simp
also have "... = 𝗋⇩D[w] ⋅⇩D ((w ⋆⇩D ε) ⋅⇩D (w ⋆⇩D e ⋆⇩D d) ⋅⇩D (w ⋆⇩D D.inv ε)) ⋅⇩D
𝗋⇩D⇧-⇧1[w]"
using w γ e.ide_left e.ide_right we e.antipar D.comp_assoc_assoc'(1)
‹trg⇩D e = a› a_def
by presburger
also have "... = 𝗋⇩D[w] ⋅⇩D ((w ⋆⇩D ε) ⋅⇩D (w ⋆⇩D D.inv ε)) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
using w γ 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 "... = 𝗋⇩D[w] ⋅⇩D (w ⋆⇩D src⇩D w) ⋅⇩D 𝗋⇩D⇧-⇧1[w]"
using w e.counit_is_iso C.comp_arr_inv'
by (metis D.comp_arr_inv' D.seqI' D.whisker_left ‹trg⇩D e = a› a_def
d.unit_in_vhom e.counit_in_hom(2) e.counit_simps(3))
also have "... = 𝗋⇩D[w] ⋅⇩D 𝗋⇩D⇧-⇧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 "𝗋⇩D[w] ⋅⇩D (w ⋆⇩D ε) ⋅⇩D 𝖺⇩D[w, e, d] ⋅⇩D 𝖺⇩D⇧-⇧1[w, e, d] ⋅⇩D
(w ⋆⇩D D.inv ε) ⋅⇩D 𝗋⇩D⇧-⇧1[w] = w"
by simp
thus ?thesis
using γ' 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 "«ρ : g ⇒⇩C r ⋆⇩C f»"
assumes "tabulation V⇩D H⇩D 𝖺⇩D 𝗂⇩D src⇩D trg⇩D (F r) (D.inv (Φ (r, f)) ⋅⇩D F ρ) (F f) (F g)"
shows "tabulation V⇩C H⇩C 𝖺⇩C 𝗂⇩C src⇩C trg⇩C r ρ f g"
proof -
interpret ρ': tabulation V⇩D H⇩D 𝖺⇩D 𝗂⇩D src⇩D trg⇩D
‹F r› ‹D.inv (Φ (r, f)) ⋅⇩D F ρ› ‹F f› ‹F g›
using assms by auto
interpret ρ: tabulation_data V⇩C H⇩C 𝖺⇩C 𝗂⇩C src⇩C trg⇩C r ρ f g
using assms by (unfold_locales, simp_all)
interpret ρ: tabulation V⇩C H⇩C 𝖺⇩C 𝗂⇩C src⇩C trg⇩C r ρ f g
proof
show "⋀u ω. ⟦ C.ide u; «ω : C.dom ω ⇒⇩C r ⋆⇩C u» ⟧ ⟹
∃w θ ν. C.ide w ∧ «θ : f ⋆⇩C w ⇒⇩C u» ∧ «ν : C.dom ω ⇒⇩C g ⋆⇩C w» ∧
C.iso ν ∧ ρ.composite_cell w θ ⋅⇩C ν = ω"
proof -
fix u ω
assume u: "C.ide u"
assume ω: "«ω : C.dom ω ⇒⇩C r ⋆⇩C u»"
have hseq_ru: "src⇩C r = trg⇩C u"
using ω C.ide_cod C.ideD(1) by fastforce
hence 1: "«D.inv (Φ (r, u)) ⋅⇩D F ω : F (C.dom ω) ⇒⇩D F r ⋆⇩D F u»"
using assms u ω cmp_in_hom cmp_components_are_iso
by (intro D.comp_in_homI, auto)
hence 2: "D.dom (D.inv (Φ (r, u)) ⋅⇩D F ω) = F (C.dom ω)"
by auto
obtain w θ ν
where wθν: "D.ide w ∧ «θ : F f ⋆⇩D w ⇒⇩D F u» ∧
«ν : F (C.dom ω) ⇒⇩D F g ⋆⇩D w» ∧ D.iso ν ∧
ρ'.composite_cell w θ ⋅⇩D ν = D.inv (Φ (r, u)) ⋅⇩D F ω"
using 1 2 u ρ'.T1 [of "F u" "D.inv (Φ (r, u)) ⋅⇩D F ω"] by auto
have hseq_Ff_w: "src⇩D (F f) = trg⇩D w"
using u ω wθν
by (metis "1" D.arrI D.not_arr_null D.seqE D.seq_if_composable ρ'.tab_simps(2))
have hseq_Fg_w: "src⇩D (F g) = trg⇩D w"
using u ω wθν by (simp add: hseq_Ff_w)
have w: "«w : map⇩0 (src⇩C ω) →⇩D map⇩0 (src⇩C f)»"
using u ω wθν hseq_Fg_w
by (metis "1" C.arrI D.arrI D.hseqI' D.ideD(1) D.in_hhom_def D.src_hcomp
D.src_vcomp D.vconn_implies_hpar(1) D.vconn_implies_hpar(3)
D.vseq_implies_hpar(1) ρ'.leg1_simps(2) ρ.leg0_simps(2) hseq_Ff_w
preserves_src)
obtain w' where w': "«w' : src⇩C ω →⇩C src⇩C f» ∧ C.ide w' ∧ D.isomorphic (F w') w"
using assms w ω wθν locally_essentially_surjective by force
obtain φ where φ: "«φ : F w' ⇒⇩D w» ∧ D.iso φ"
using w' D.isomorphic_def by blast
have src_fw': "src⇩C (f ⋆⇩C w') = src⇩C u"
using u w' ω
by (metis C.hseqI' C.ideD(1) C.in_hhomE C.src_hcomp C.vconn_implies_hpar(1)
C.vconn_implies_hpar(3) ρ.base_simps(2) ρ.leg0_in_hom(1) hseq_ru)
have 3: "«θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w')) : F (f ⋆⇩C w') ⇒⇩D F u»"
proof (intro D.comp_in_homI)
show "«D.inv (Φ (f, w')) : F (f ⋆⇩C w') ⇒⇩D F f ⋆⇩D F w'»"
using assms w' cmp_in_hom cmp_components_are_iso by auto
show "«F f ⋆⇩D φ : F f ⋆⇩D F w' ⇒⇩D F f ⋆⇩D w»"
using φ ρ'.leg0_in_hom(2) w' by fastforce
show "«θ : F f ⋆⇩D w ⇒⇩D F u»"
using wθν by simp
qed
have 4: "∃θ'. «θ' : f ⋆⇩C w' ⇒⇩C u» ∧ F θ' = θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w'))"
using w' u hseq_ru src_fw' 3 locally_full by auto
obtain θ' where
θ': "«θ' : f ⋆⇩C w' ⇒⇩C u» ∧ F θ' = θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w'))"
using 4 by auto
have 5: "«Φ (g, w') ⋅⇩D (F g ⋆⇩D D.inv φ) ⋅⇩D ν : F (C.dom ω) ⇒⇩D F (g ⋆⇩C w')»"
proof (intro D.comp_in_homI)
show "«ν : F (C.dom ω) ⇒⇩D F g ⋆⇩D w»"
using wθν by simp
show "«F g ⋆⇩D D.inv φ : F g ⋆⇩D w ⇒⇩D F g ⋆⇩D F w'»"
using assms φ
by (meson D.hcomp_in_vhom D.inv_in_hom ρ'.leg1_in_hom(2) hseq_Fg_w)
show "«Φ (g, w') : F g ⋆⇩D F w' ⇒⇩D F (g ⋆⇩C w')»"
using assms w' cmp_in_hom by auto
qed
have 6: "∃ν'. «ν' : C.dom ω ⇒⇩C g ⋆⇩C w'» ∧
F ν' = Φ(g, w') ⋅⇩D (F g ⋆⇩D D.inv φ) ⋅⇩D ν"
using u w' ω 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)
ρ.base_simps(2) ρ.ide_leg1 ρ.leg1_in_hom(1) locally_full)
obtain ν' where
ν': "«ν' : C.dom ω ⇒⇩C g ⋆⇩C w'» ∧ F ν' = Φ(g, w') ⋅⇩D (F g ⋆⇩D D.inv φ) ⋅⇩D ν"
using 6 by auto
have "C.ide w' ∧ «θ' : f ⋆⇩C w' ⇒⇩C u» ∧ «ν' : C.dom ω ⇒⇩C g ⋆⇩C w'» ∧ C.iso ν' ∧
ρ.composite_cell w' θ' ⋅⇩C ν' = ω"
using w' θ' ν'
apply (intro conjI)
apply auto
proof -
show "C.iso ν'"
proof -
have "D.iso (F ν')"
proof -
have "D.iso (Φ(g, w'))"
using w' cmp_components_are_iso by auto
moreover have "D.iso (F g ⋆⇩D D.inv φ)"
using φ
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 ρ'.ide_leg1)
moreover have "D.iso ν"
using wθν by simp
ultimately show ?thesis
using ν' D.isos_compose
by (metis "5" D.arrI D.seqE)
qed
thus ?thesis using reflects_iso by blast
qed
have 7: "«ρ.composite_cell w' θ' : g ⋆⇩C w' ⇒⇩C r ⋆⇩C u»"
using u w' θ' ρ.composite_cell_in_hom hseq_ru src_fw' C.hseqI'
by (metis C.in_hhomE C.hcomp_simps(1) ρ.leg0_simps(2))
hence 8: "«ρ.composite_cell w' θ' ⋅⇩C ν' : C.dom ω ⇒⇩C r ⋆⇩C u»"
using ν' by blast
show "ρ.composite_cell w' θ' ⋅⇩C ν' = ω"
proof -
have 1: "C.par (ρ.composite_cell w' θ' ⋅⇩C ν') ω"
using ω 8 hseq_ru C.hseqI' C.in_homE by metis
moreover have "F (ρ.composite_cell w' θ' ⋅⇩C ν') = F ω"
proof -
have "F (ρ.composite_cell w' θ' ⋅⇩C ν') =
F (r ⋆⇩C θ') ⋅⇩D F 𝖺⇩C[r, f, w'] ⋅⇩D F (ρ ⋆⇩C w') ⋅⇩D F ν'"
using w' θ' ν' 1 C.comp_assoc
by (metis C.seqE preserves_comp)
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ') ⋅⇩D ((D.inv (Φ (r, f ⋆⇩C w')) ⋅⇩D
Φ (r, f ⋆⇩C w')) ⋅⇩D (F r ⋆⇩D Φ (f, w'))) ⋅⇩D
𝖺⇩D[F r, F f, F w'] ⋅⇩D (D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D
((D.inv (Φ (r ⋆⇩C f, w')) ⋅⇩D
Φ (r ⋆⇩C f, w')) ⋅⇩D (F ρ ⋆⇩D F w')) ⋅⇩D D.inv (Φ (g, w')) ⋅⇩D F ν'"
proof -
have "F 𝖺⇩C[r, f, w'] =
Φ (r, f ⋆⇩C w') ⋅⇩D (F r ⋆⇩D Φ (f, w')) ⋅⇩D 𝖺⇩D[F r, F f, F w'] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D D.inv (Φ (r ⋆⇩C f, w'))"
using assms w'
by (simp add: C.in_hhom_def preserves_assoc(1))
moreover have
"F (r ⋆⇩C θ') = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ') ⋅⇩D D.inv (Φ (r, f ⋆⇩C w'))"
using assms θ' preserves_hcomp [of r θ']
by (metis "1" C.in_homE C.seqE ρ.base_simps(3) ρ.base_simps(4))
moreover have
"F (ρ ⋆⇩C w') = Φ (r ⋆⇩C f, w') ⋅⇩D (F ρ ⋆⇩D F w') ⋅⇩D D.inv (Φ (g, w'))"
using w' preserves_hcomp [of ρ w'] by auto
ultimately show ?thesis
by (simp add: D.comp_assoc)
qed
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ') ⋅⇩D (F r ⋆⇩D Φ (f, w')) ⋅⇩D
𝖺⇩D[F r, F f, F w'] ⋅⇩D (D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D
(F ρ ⋆⇩D F w') ⋅⇩D D.inv (Φ (g, w')) ⋅⇩D F ν'"
proof -
have "(D.inv (Φ (r, f ⋆⇩C w')) ⋅⇩D Φ (r, f ⋆⇩C w')) ⋅⇩D (F r ⋆⇩D Φ (f, w')) =
F r ⋆⇩D Φ (f, w')"
using w' cmp_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
C.in_hhom_def C.trg_hcomp D.comp_inv_arr' C.ide_hcomp
by (metis C.ideD(1) D.hcomp_simps(4) cmp_simps(1,3-5)
ρ'.leg0_simps(3) ρ'.base_simps(2,4) ρ.ide_leg0 ρ.ide_base
ρ.leg0_simps(3))
moreover have "(D.inv (Φ (r ⋆⇩C f, w')) ⋅⇩D Φ (r ⋆⇩C f, w')) ⋅⇩D (F ρ ⋆⇩D F w') =
F ρ ⋆⇩D F w'"
using w' D.comp_inv_arr' hseq_Fg_w D.comp_cod_arr by auto
ultimately show ?thesis by simp
qed
also have "... = Φ (r, u) ⋅⇩D ((F r ⋆⇩D θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w'))) ⋅⇩D
(F r ⋆⇩D Φ (f, w'))) ⋅⇩D 𝖺⇩D[F r, F f, F w'] ⋅⇩D
((D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D (F ρ ⋆⇩D F w')) ⋅⇩D
D.inv (Φ (g, w')) ⋅⇩D Φ (g, w') ⋅⇩D (F g ⋆⇩D D.inv φ) ⋅⇩D ν"
using w' θ' ν' D.comp_assoc by simp
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w')) ⋅⇩D
Φ (f, w')) ⋅⇩D 𝖺⇩D[F r, F f, F w'] ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D
F ρ ⋆⇩D F w') ⋅⇩D ((D.inv (Φ (g, w')) ⋅⇩D Φ (g, w')) ⋅⇩D
(F g ⋆⇩D D.inv φ)) ⋅⇩D ν"
proof -
have "(F r ⋆⇩D θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w'))) ⋅⇩D (F r ⋆⇩D Φ (f, w')) =
F r ⋆⇩D (θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w'))) ⋅⇩D Φ (f, w')"
proof -
have "D.seq (θ ⋅⇩D (F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w'))) (Φ (f, w'))"
using assms 3 ρ.ide_base w' wθν cmp_in_hom [of f w'] cmp_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θν cmp_in_hom cmp_components_are_iso D.whisker_left
by simp
qed
moreover have "(D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D (F ρ ⋆⇩D F w') =
D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w'"
using w' D.whisker_right by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D θ ⋅⇩D (F f ⋆⇩D φ)) ⋅⇩D
𝖺⇩D[F r, F f, F w'] ⋅⇩D ((D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w') ⋅⇩D
(F g ⋆⇩D D.inv φ)) ⋅⇩D ν"
proof -
have "(F f ⋆⇩D φ) ⋅⇩D D.inv (Φ (f, w')) ⋅⇩D Φ (f, w') = F f ⋆⇩D φ"
using assms(2) w' φ 3 cmp_components_are_iso cmp_in_hom D.hseqI' D.comp_inv_arr'
D.comp_arr_dom
by (metis C.in_hhom_def D.arrI D.cod_inv D.seqE)
moreover have "(D.inv (Φ (g, w')) ⋅⇩D Φ (g, w')) ⋅⇩D (F g ⋆⇩D D.inv φ) =
F g ⋆⇩D D.inv φ"
using assms w' φ 3 cmp_components_are_iso cmp_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 ρ.ide_leg1
ρ.leg1_simps(3))
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D θ ⋅⇩D (F f ⋆⇩D φ)) ⋅⇩D
(𝖺⇩D[F r, F f, F w'] ⋅⇩D ((F r ⋆⇩D F f) ⋆⇩D D.inv φ)) ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D w) ⋅⇩D ν"
proof -
have "(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w') ⋅⇩D (F g ⋆⇩D D.inv φ) =
D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D D.inv φ"
using assms w' φ cmp_in_hom cmp_components_are_iso D.comp_arr_dom
D.comp_cod_arr
D.interchange [of "D.inv (Φ (r, f)) ⋅⇩D F ρ" "F g" "F w'" "D.inv φ"]
by auto
also have "... = ((F r ⋆⇩D F f) ⋆⇩D D.inv φ) ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D w)"
using assms w' φ cmp_components_are_iso D.comp_arr_dom D.comp_cod_arr
D.interchange [of "F r ⋆⇩D F f" "D.inv (Φ (r, f)) ⋅⇩D F ρ" "D.inv φ" w]
by auto
finally have "(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w') ⋅⇩D (F g ⋆⇩D D.inv φ) =
((F r ⋆⇩D F f) ⋆⇩D D.inv φ) ⋅⇩D (D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D w)"
by simp
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u) ⋅⇩D ((F r ⋆⇩D θ ⋅⇩D (F f ⋆⇩D φ)) ⋅⇩D
(F r ⋆⇩D F f ⋆⇩D D.inv φ)) ⋅⇩D 𝖺⇩D[F r, F f, w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D w) ⋅⇩D ν"
proof -
have "𝖺⇩D[F r, F f, F w'] ⋅⇩D ((F r ⋆⇩D F f) ⋆⇩D D.inv φ) =
(F r ⋆⇩D F f ⋆⇩D D.inv φ) ⋅⇩D 𝖺⇩D[F r, F f, w]"
proof -
have "src⇩D (F r) = trg⇩D (F f)"
by simp
moreover have "src⇩D (F f) = trg⇩D (D.inv φ)"
using φ
by (metis "5" D.arrI D.hseqE D.seqE ρ'.leg1_simps(3))
ultimately show ?thesis
using assms w' φ D.assoc_naturality [of "F r" "F f" "D.inv φ"] by auto
qed
thus ?thesis
using D.comp_assoc by simp
qed
also have "... = Φ (r, u) ⋅⇩D (F r ⋆⇩D θ) ⋅⇩D 𝖺⇩D[F r, F f, w] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D w) ⋅⇩D ν"
using assms φ wθν 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 ρ'.ide_base tabulation_data.leg0_simps(1)
tabulation_def)
also have "... = (Φ (r, u) ⋅⇩D D.inv (Φ (r, u))) ⋅⇩D F ω"
using wθν D.comp_assoc by simp
also have "... = F ω"
using u ω cmp_in_hom D.comp_arr_inv'
by (metis C.in_homE cmp_components_are_iso cmp_simps(5) ρ.ide_base
as_nat_trans.is_natural_1 as_nat_trans.naturality hseq_ru)
finally show ?thesis by blast
qed
ultimately show ?thesis
using is_faithful [of "ρ.composite_cell w' θ' ⋅⇩C ν'" ω] by simp
qed
qed
thus "∃w θ ν. C.ide w ∧ «θ : f ⋆⇩C w ⇒⇩C u» ∧ «ν : C.dom ω ⇒⇩C g ⋆⇩C w» ∧
C.iso ν ∧ ρ.composite_cell w θ ⋅⇩C ν = ω"
by auto
qed
show "⋀u w w' θ θ' β. ⟦ C.ide w; C.ide w'; «θ : f ⋆⇩C w ⇒⇩C u»; «θ' : f ⋆⇩C w' ⇒⇩C u»;
«β : g ⋆⇩C w ⇒⇩C g ⋆⇩C w'»;
ρ.composite_cell w θ = ρ.composite_cell w' θ' ⋅⇩C β ⟧
⟹ ∃!γ. «γ : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ)"
proof -
fix u w w' θ θ' β
assume w: "C.ide w"
assume w': "C.ide w'"
assume θ: "«θ : f ⋆⇩C w ⇒⇩C u»"
assume θ': "«θ' : f ⋆⇩C w' ⇒⇩C u»"
assume β: "«β : g ⋆⇩C w ⇒⇩C g ⋆⇩C w'»"
assume eq: "ρ.composite_cell w θ = ρ.composite_cell w' θ' ⋅⇩C β"
show "∃!γ. «γ : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ)"
proof -
have hseq_ru: "src⇩C r = trg⇩C u"
using w θ
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) ρ.leg0_simps(3))
have hseq_fw: "src⇩C f = trg⇩C w ∧ src⇩C f = trg⇩C w'"
using w w' ρ.ide_leg0 θ θ'
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⇩C g = trg⇩C w ∧ src⇩C g = trg⇩C w'"
using w w' ρ.ide_leg0 θ θ' ‹src⇩C f = trg⇩C w ∧ src⇩C f = trg⇩C w'› by auto
have *: "∃!γ. «γ : F w ⇒⇩D F w'» ∧
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w) = F g ⋆⇩D γ ∧
F θ ⋅⇩D Φ (f, w) = (F θ' ⋅⇩D Φ (f, w')) ⋅⇩D (F f ⋆⇩D γ)"
proof -
have "D.ide (F w) ∧ D.ide (F w')"
using w w' by simp
moreover have 1: "«F θ ⋅⇩D Φ (f, w) : F f ⋆⇩D F w ⇒⇩D F u»"
using w θ cmp_in_hom ρ.ide_leg0 hseq_fw by blast
moreover have 2: "«F θ' ⋅⇩D Φ (f, w') : F f ⋆⇩D F w' ⇒⇩D F u»"
using w' θ' cmp_in_hom ρ.ide_leg0 hseq_fw by blast
moreover have
"«D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w) : F g ⋆⇩D F w ⇒⇩D F g ⋆⇩D F w'»"
using w w' β ρ.ide_leg1 cmp_in_hom cmp_components_are_iso hseq_gw preserves_hom
by fastforce
moreover have "ρ'.composite_cell (F w) (F θ ⋅⇩D Φ (f, w)) =
ρ'.composite_cell (F w') (F θ' ⋅⇩D Φ (f, w')) ⋅⇩D
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w)"
proof -
have "ρ'.composite_cell (F w') (F θ' ⋅⇩D Φ (f, w')) ⋅⇩D
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w) =
(F r ⋆⇩D F θ' ⋅⇩D Φ (f, w')) ⋅⇩D 𝖺⇩D[F r, F f, F w'] ⋅⇩D
(D.inv (Φ (r, f)) ⋅⇩D F ρ ⋆⇩D F w') ⋅⇩D
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w)"
using D.comp_assoc by simp
also have "... =
(F r ⋆⇩D F θ') ⋅⇩D (F r ⋆⇩D Φ (f, w')) ⋅⇩D 𝖺⇩D[F r, F f, F w'] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D (F ρ ⋆⇩D F w') ⋅⇩D
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w)"
using w' θ' 2 D.whisker_left D.whisker_right D.comp_assoc by auto
also have "... = (F r ⋆⇩D F θ') ⋅⇩D ((D.inv (Φ (r, f ⋆⇩C w')) ⋅⇩D
Φ (r, f ⋆⇩C w')) ⋅⇩D (F r ⋆⇩D Φ (f, w'))) ⋅⇩D
𝖺⇩D[F r, F f, F w'] ⋅⇩D (D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D
((D.inv (Φ (r ⋆⇩C f, w')) ⋅⇩D
Φ (r ⋆⇩C f, w')) ⋅⇩D (F ρ ⋆⇩D F w')) ⋅⇩D
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w)"
proof -
have "(D.inv (Φ (r, f ⋆⇩C w')) ⋅⇩D Φ (r, f ⋆⇩C w')) ⋅⇩D (F r ⋆⇩D Φ (f, w')) =
F r ⋆⇩D Φ (f, w')"
using w' cmp_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
C.in_hhom_def C.trg_hcomp D.comp_inv_arr' C.ide_hcomp
by (metis C.ideD(1) D.hcomp_simps(4) cmp_simps(1) cmp_simps(3-5)
ρ'.leg0_simps(3) ρ'.base_simps(2,4) ρ.ide_leg0 ρ.ide_base
ρ.leg0_simps(3) hseq_fw)
moreover have "(D.inv (Φ (r ⋆⇩C f, w')) ⋅⇩D Φ (r ⋆⇩C f, w')) ⋅⇩D (F ρ ⋆⇩D F w') =
F ρ ⋆⇩D F w'"
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 (Φ (r, u)) ⋅⇩D
(Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ') ⋅⇩D (D.inv (Φ (r, f ⋆⇩C w'))) ⋅⇩D
(Φ (r, f ⋆⇩C w')) ⋅⇩D (F r ⋆⇩D Φ (f, w')) ⋅⇩D
𝖺⇩D[F r, F f, F w'] ⋅⇩D (D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D
(D.inv (Φ (r ⋆⇩C f, w')) ⋅⇩D
(Φ (r ⋆⇩C f, w')) ⋅⇩D (F ρ ⋆⇩D F w')) ⋅⇩D
D.inv (Φ (g, w'))) ⋅⇩D F β ⋅⇩D Φ (g, w)"
proof -
have "(D.inv (Φ (r, u)) ⋅⇩D Φ (r, u)) ⋅⇩D (F r ⋆⇩D F θ') = F r ⋆⇩D F θ'"
using assms(1) θ' 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 (Φ (r, u)) ⋅⇩D
(F (r ⋆⇩C θ') ⋅⇩D F 𝖺⇩C[r, f, w'] ⋅⇩D F (ρ ⋆⇩C w')) ⋅⇩D
F β ⋅⇩D Φ (g, w)"
proof -
have "F (r ⋆⇩C θ') = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ') ⋅⇩D D.inv (Φ (r, f ⋆⇩C w'))"
using w' θ' preserves_hcomp hseq_ru by auto
moreover have "F 𝖺⇩C[r, f, w'] =
Φ (r, f ⋆⇩C w') ⋅⇩D (F r ⋆⇩D Φ (f, w')) ⋅⇩D 𝖺⇩D[F r, F f, F w'] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w') ⋅⇩D D.inv (Φ (r ⋆⇩C f, w'))"
using w' preserves_assoc(1) hseq_fw by force
moreover have
"F (ρ ⋆⇩C w') = Φ (r ⋆⇩C f, w') ⋅⇩D (F ρ ⋆⇩D F w') ⋅⇩D D.inv (Φ (g, w'))"
using w' preserves_hcomp hseq_fw by fastforce
ultimately show ?thesis
using D.comp_assoc by auto
qed
also have "... = D.inv (Φ (r, u)) ⋅⇩D F (ρ.composite_cell w' θ') ⋅⇩D F β ⋅⇩D Φ (g, w)"
using w' θ' C.comp_assoc hseq_ru hseq_fw by auto
also have "... = D.inv (Φ (r, u)) ⋅⇩D (F (ρ.composite_cell w' θ') ⋅⇩D F β) ⋅⇩D Φ (g, w)"
using D.comp_assoc by simp
also have "... = D.inv (Φ (r, u)) ⋅⇩D F (ρ.composite_cell w' θ' ⋅⇩C β) ⋅⇩D Φ (g, w)"
proof -
have "F (ρ.composite_cell w' θ') ⋅⇩D F β = F (ρ.composite_cell w' θ' ⋅⇩C β)"
using w w' θ' β ρ.composite_cell_in_hom
preserves_comp [of "ρ.composite_cell w' θ'" β]
by (metis C.dom_comp C.hcomp_simps(3) C.ide_char C.in_homE C.seqE C.seqI
D.ext D.seqE ρ.tab_simps(4) is_extensional preserves_reflects_arr)
thus ?thesis by simp
qed
also have "... = D.inv (Φ (r, u)) ⋅⇩D F (ρ.composite_cell w θ) ⋅⇩D Φ (g, w)"
using eq by simp
also have "... = D.inv (Φ (r, u)) ⋅⇩D
F (r ⋆⇩C θ) ⋅⇩D F 𝖺⇩C[r, f, w] ⋅⇩D F (ρ ⋆⇩C w) ⋅⇩D Φ (g, w)"
using w θ C.comp_assoc hseq_ru hseq_fw D.comp_assoc by auto
also have "... = ((D.inv (Φ (r, u)) ⋅⇩D
Φ (r, u)) ⋅⇩D (F r ⋆⇩D F θ)) ⋅⇩D ((D.inv (Φ (r, f ⋆⇩C w)) ⋅⇩D
Φ (r, f ⋆⇩C w)) ⋅⇩D (F r ⋆⇩D Φ (f, w))) ⋅⇩D
𝖺⇩D[F r, F f, F w] ⋅⇩D (D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D
((D.inv (Φ (r ⋆⇩C f, w)) ⋅⇩D
Φ (r ⋆⇩C f, w)) ⋅⇩D (F ρ ⋆⇩D F w)) ⋅⇩D D.inv (Φ (g, w)) ⋅⇩D Φ (g, w)"
proof -
have "F (r ⋆⇩C θ) = Φ (r, u) ⋅⇩D (F r ⋆⇩D F θ) ⋅⇩D D.inv (Φ (r, f ⋆⇩C w))"
using w θ preserves_hcomp hseq_ru by auto
moreover have "F 𝖺⇩C[r, f, w] =
Φ (r, f ⋆⇩C w) ⋅⇩D (F r ⋆⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D D.inv (Φ (r ⋆⇩C f, w))"
using w preserves_assoc(1) hseq_fw by force
moreover have
"F (ρ ⋆⇩C w) = Φ (r ⋆⇩C f, w) ⋅⇩D (F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w))"
using w preserves_hcomp hseq_fw by fastforce
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = (F r ⋆⇩D F θ) ⋅⇩D (F r ⋆⇩D Φ (f, w)) ⋅⇩D 𝖺⇩D[F r, F f, F w] ⋅⇩D
(D.inv (Φ (r, f)) ⋆⇩D F w) ⋅⇩D (F ρ ⋆⇩D F w)"
proof -
have "(D.inv (Φ (r, u)) ⋅⇩D Φ (r, u)) ⋅⇩D (F r ⋆⇩D F θ) = F r ⋆⇩D F θ"
using θ D.comp_cod_arr hseq_ru D.comp_inv_arr' by auto
moreover have
"(D.inv (Φ (r, f ⋆⇩C w)) ⋅⇩D Φ (r, f ⋆⇩C w)) ⋅⇩D (F r ⋆⇩D Φ (f, w)) =
F r ⋆⇩D Φ (f, w)"
using w cmp_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
C.in_hhom_def C.trg_hcomp D.comp_inv_arr' C.ide_hcomp
by (metis C.ideD(1) D.hcomp_simps(4) cmp_simps(1) cmp_simps(3-5)
ρ'.leg0_simps(3) ρ'.base_simps(2,4) ρ.ide_leg0 ρ.ide_base
ρ.leg0_simps(3) hseq_fw)
moreover have "(D.inv (Φ (r ⋆⇩C f, w)) ⋅⇩D Φ (r ⋆⇩C f, w)) ⋅⇩D (F ρ ⋆⇩D F w) =
F ρ ⋆⇩D F w"
using w D.comp_inv_arr' D.comp_cod_arr hseq_fw by simp
moreover have "(F ρ ⋆⇩D F w) ⋅⇩D D.inv (Φ (g, w)) ⋅⇩D Φ (g, w) = F ρ ⋆⇩D F w"
using w θ D.comp_arr_dom D.comp_inv_arr' hseq_gw by simp
ultimately show ?thesis
using D.comp_assoc by simp
qed
also have "... = ρ'.composite_cell (F w) (F θ ⋅⇩D Φ (f, w))"
using w θ 1 D.whisker_left D.whisker_right D.comp_assoc by auto
finally show ?thesis by simp
qed
ultimately show ?thesis
using w w' θ θ' β eq
ρ'.T2 [of "F w" "F w'" "F θ ⋅⇩D Φ (f, w)" "F u" "F θ' ⋅⇩D Φ (f, w')"
"D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w)"]
by blast
qed
obtain γ' where γ': "«γ' : F w ⇒⇩D F w'» ∧
D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w) = F g ⋆⇩D γ' ∧
F θ ⋅⇩D Φ (f, w) = (F θ' ⋅⇩D Φ (f, w')) ⋅⇩D (F f ⋆⇩D γ')"
using * by auto
obtain γ where γ: "«γ : w ⇒⇩C w'» ∧ F γ = γ'"
using θ θ w w' γ' locally_full [of w w' γ']
by (metis C.hseqI' C.ideD(1) C.src_hcomp C.vconn_implies_hpar(3)
ρ.leg0_simps(2) θ' hseq_fw)
have "θ = θ' ⋅⇩C (f ⋆⇩C γ)"
proof -
have "F θ = F (θ' ⋅⇩C (f ⋆⇩C γ))"
proof -
have "F θ = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D γ') ⋅⇩D D.inv (Φ (f, w))"
using w' θ' γ' preserves_hcomp hseq_fw D.comp_assoc D.invert_side_of_triangle
by (metis C.in_homE D.comp_arr_inv' cmp_components_are_iso cmp_simps(5)
ρ.ide_leg0 θ as_nat_trans.is_natural_1 w)
also have "... = F θ' ⋅⇩D F (f ⋆⇩C γ)"
using w' D.comp_assoc hseq_fw preserves_hcomp cmp_components_are_iso
D.comp_arr_inv'
by (metis C.hseqI' C.in_homE C.trg_cod γ ρ.leg0_in_hom(2))
also have "... = F (θ' ⋅⇩C (f ⋆⇩C γ))"
using γ θ θ' hseq_fw C.hseqI' preserves_comp by force
finally show ?thesis by simp
qed
moreover have "C.par θ (θ' ⋅⇩C (f ⋆⇩C γ))"
using γ θ θ' hseq_fw by fastforce
ultimately show ?thesis
using is_faithful by blast
qed
moreover have "β = g ⋆⇩C γ"
proof -
have "F β = F (g ⋆⇩C γ)"
proof -
have "F β = Φ (g, w') ⋅⇩D (F g ⋆⇩D γ') ⋅⇩D D.inv (Φ (g, w))"
by (metis (no_types) C.in_homE D.comp_arr_inv' D.comp_assoc
cmp_components_are_iso cmp_simps(5) β γ' ρ.ide_leg1 hseq_gw
as_nat_trans.is_natural_1 as_nat_trans.naturality w w')
also have "... = F (g ⋆⇩C γ)"
using w γ γ' preserves_hcomp hseq_gw
by (metis C.hseqE C.hseqI' C.in_homE C.seqE ‹θ = θ' ⋅⇩C (f ⋆⇩C γ)›
ρ.leg1_simps(2) ρ.leg1_simps(5) ρ.leg1_simps(6) θ hseq_fw)
finally show ?thesis by simp
qed
moreover have "C.par β (g ⋆⇩C γ)"
proof (intro conjI)
show "C.arr β"
using β by blast
show 1: "C.hseq g γ"
using γ hseq_gw by fastforce
show "C.dom β = C.dom (g ⋆⇩C γ)"
using γ β 1 by fastforce
show "C.cod β = C.cod (g ⋆⇩C γ)"
using γ β 1 by fastforce
qed
ultimately show ?thesis
using is_faithful by blast
qed
ultimately have "∃γ. «γ : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ)"
using γ by blast
moreover have "⋀γ⇩1 γ⇩2. «γ⇩1 : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ⇩1 ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ⇩1) ⟹
«γ⇩2 : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ⇩2 ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ⇩2) ⟹ γ⇩1 = γ⇩2"
proof -
fix γ⇩1 γ⇩2
assume γ⇩1: "«γ⇩1 : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ⇩1 ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ⇩1)"
assume γ⇩2: "«γ⇩2 : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ⇩2 ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ⇩2)"
have Fβ⇩1: "F β = Φ (g, w') ⋅⇩D (F g ⋆⇩D F γ⇩1) ⋅⇩D D.inv (Φ (g, w))"
using w w' β hseq_gw γ⇩1 preserves_hcomp [of g γ⇩1] cmp_components_are_iso
by auto
have Fβ⇩2: "F β = Φ (g, w') ⋅⇩D (F g ⋆⇩D F γ⇩2) ⋅⇩D D.inv (Φ (g, w))"
using w w' β hseq_gw γ⇩2 preserves_hcomp [of g γ⇩2] cmp_components_are_iso
by auto
have "D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w) = F g ⋆⇩D F γ⇩1"
proof -
have "F β ⋅⇩D Φ (g, w) = Φ (g, w') ⋅⇩D (F g ⋆⇩D F γ⇩1)"
using w w' β hseq_gw γ⇩1 Fβ⇩1 preserves_hcomp cmp_components_are_iso
D.invert_side_of_triangle D.iso_inv_iso
by (metis C.arrI D.comp_assoc D.inv_inv ρ.ide_leg1 preserves_reflects_arr)
thus ?thesis
using w w' β hseq_gw γ⇩1 preserves_hcomp cmp_components_are_iso
D.invert_side_of_triangle
by (metis C.arrI D.cod_comp D.seqE D.seqI Fβ⇩1 ρ.ide_leg1 preserves_arr)
qed
moreover have "D.inv (Φ (g, w')) ⋅⇩D F β ⋅⇩D Φ (g, w) = F g ⋆⇩D F γ⇩2"
proof -
have "F β ⋅⇩D Φ (g, w) = Φ (g, w') ⋅⇩D (F g ⋆⇩D F γ⇩2)"
using w w' β hseq_gw γ⇩2 Fβ⇩2 preserves_hcomp cmp_components_are_iso
D.invert_side_of_triangle D.iso_inv_iso
by (metis C.arrI D.comp_assoc D.inv_inv ρ.ide_leg1 preserves_reflects_arr)
thus ?thesis
using w w' β hseq_gw γ⇩2 preserves_hcomp cmp_components_are_iso
D.invert_side_of_triangle
by (metis C.arrI D.cod_comp D.seqE D.seqI Fβ⇩2 ρ.ide_leg1 preserves_arr)
qed
moreover have "F θ ⋅⇩D Φ (f, w) = (F θ' ⋅⇩D Φ (f, w')) ⋅⇩D (F f ⋆⇩D F γ⇩1)"
proof -
have "F θ ⋅⇩D Φ (f, w) = F (θ' ⋅⇩C (f ⋆⇩C γ⇩1)) ⋅⇩D Φ (f, w)"
using γ⇩1 by blast
also have "... = (F θ' ⋅⇩D F (f ⋆⇩C γ⇩1)) ⋅⇩D Φ (f, w)"
using γ⇩1 θ by auto
also have
"... = (F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩1) ⋅⇩D D.inv (Φ (f, w))) ⋅⇩D Φ (f, w)"
using γ⇩1 hseq_fw preserves_hcomp by auto
also have
"... = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩1) ⋅⇩D D.inv (Φ (f, w)) ⋅⇩D Φ (f, w)"
using D.comp_assoc by simp
also have "... = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩1) ⋅⇩D (F f ⋆⇩D F w)"
by (simp add: D.comp_inv_arr' hseq_fw w)
also have "... = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩1)"
using w γ⇩1 D.whisker_left [of "F f" "F γ⇩1" "F w"] D.comp_arr_dom by auto
finally show ?thesis
using D.comp_assoc by simp
qed
moreover have "F θ ⋅⇩D Φ (f, w) = (F θ' ⋅⇩D Φ (f, w')) ⋅⇩D (F f ⋆⇩D F γ⇩2)"
proof -
have "F θ ⋅⇩D Φ (f, w) = F (θ' ⋅⇩C (f ⋆⇩C γ⇩2)) ⋅⇩D Φ (f, w)"
using γ⇩2 by blast
also have "... = (F θ' ⋅⇩D F (f ⋆⇩C γ⇩2)) ⋅⇩D Φ (f, w)"
using γ⇩2 θ by auto
also have
"... = (F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩2) ⋅⇩D D.inv (Φ (f, w))) ⋅⇩D Φ (f, w)"
using γ⇩2 hseq_fw preserves_hcomp by auto
also have
"... = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩2) ⋅⇩D D.inv (Φ (f, w)) ⋅⇩D Φ (f, w)"
using D.comp_assoc by simp
also have "... = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩2) ⋅⇩D (F f ⋆⇩D F w)"
by (simp add: D.comp_inv_arr' hseq_fw w)
also have "... = F θ' ⋅⇩D Φ (f, w') ⋅⇩D (F f ⋆⇩D F γ⇩2)"
using w γ⇩2 D.whisker_left [of "F f" "F γ⇩2" "F w"] D.comp_arr_dom by auto
finally show ?thesis
using D.comp_assoc by simp
qed
ultimately have "F γ⇩1 = F γ⇩2"
using γ⇩1 γ⇩2 * by blast
thus "γ⇩1 = γ⇩2"
using γ⇩1 γ⇩2 is_faithful [of γ⇩1 γ⇩2] by auto
qed
ultimately show "∃!γ. «γ : w ⇒⇩C w'» ∧ β = g ⋆⇩C γ ∧ θ = θ' ⋅⇩C (f ⋆⇩C γ)"
by blast
qed
qed
qed
show ?thesis ..
qed
end
end