diff --git a/thys/Bicategory/BicategoryOfSpans.thy b/thys/Bicategory/BicategoryOfSpans.thy
--- a/thys/Bicategory/BicategoryOfSpans.thy
+++ b/thys/Bicategory/BicategoryOfSpans.thy
@@ -1,14655 +1,14655 @@
 (*  Title:       BicategoryOfSpans
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Bicategories of Spans"
 
 theory BicategoryOfSpans
 imports Category3.ConcreteCategory IsomorphismClass CanonicalIsos EquivalenceOfBicategories
         SpanBicategory Tabulation
 begin
 
 text \<open>
   In this section, we prove CKS Theorem 4, which characterizes up to equivalence the
   bicategories of spans in a category with pullbacks.
   The characterization consists of three conditions:
   BS1: ``Every 1-cell is isomorphic to a composition \<open>g \<star> f\<^sup>*\<close>, where f and g are maps'';
   BS2: ``For every span of maps \<open>(f, g)\<close> there is a 2-cell \<open>\<rho>\<close> such that \<open>(f, \<rho>, g)\<close>
   is a tabulation''; and
   BS3: ``Any two 2-cells between the same pair of maps are equal and invertible.''
   One direction of the proof, which is the easier direction once it is established that
   BS1 and BS3 are respected by equivalence of bicategories, shows that if a bicategory \<open>B\<close>
   is biequivalent to the bicategory of spans in some category \<open>C\<close> with pullbacks,
   then it satisfies BS1 -- BS3.
   The other direction, which is harder, shows that a bicategory \<open>B\<close> satisfying BS1 -- BS3 is
   biequivalent to the bicategory of spans in a certain category with pullbacks that
   is constructed from the sub-bicategory of maps of \<open>B\<close>.
 \<close>
 
   subsection "Definition"
 
   text \<open>
     We define a \emph{bicategory of spans} to be a bicategory that satisfies the conditions
     \<open>BS1\<close> -- \<open>BS3\<close> stated informally above.
   \<close>
 
   locale bicategory_of_spans =
     bicategory + chosen_right_adjoints +
   assumes BS1: "ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> isomorphic r (g \<star> f\<^sup>*)"
   and BS2: "\<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk>
                       \<Longrightarrow> \<exists>r \<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
   and BS3: "\<lbrakk> is_left_adjoint f; is_left_adjoint f'; \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright> \<rbrakk>
                              \<Longrightarrow> iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
 
   text \<open>
     Using the already-established fact \<open>equivalence_pseudofunctor.reflects_tabulation\<close>
     that tabulations are reflected by equivalence pseudofunctors, it is not difficult to prove
     that the notion `bicategory of spans' respects equivalence of bicategories.
   \<close>
   
   lemma bicategory_of_spans_respects_equivalence:
   assumes "equivalent_bicategories V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
   and "bicategory_of_spans V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C"
   shows "bicategory_of_spans V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
   proof -
     interpret C: bicategory_of_spans V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
       using assms by simp
     interpret C: chosen_right_adjoints V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C ..
     interpret D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
       using assms equivalent_bicategories_def equivalence_pseudofunctor.axioms(1)
             pseudofunctor.axioms(2)
       by fast
     interpret D: chosen_right_adjoints V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
     obtain F \<Phi> where F: "equivalence_pseudofunctor
                            V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>"
       using assms equivalent_bicategories_def by blast
     interpret F: equivalence_pseudofunctor
                    V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>
       using F by simp
     interpret E: equivalence_of_bicategories
                    V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C  (* 17 sec *)
                 F \<Phi> F.right_map F.right_cmp F.unit\<^sub>0 F.unit\<^sub>1 F.counit\<^sub>0 F.counit\<^sub>1
       using F.extends_to_equivalence_of_bicategories by simp
     interpret E': converse_equivalence_of_bicategories
                     V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
                     F \<Phi> F.right_map F.right_cmp F.unit\<^sub>0 F.unit\<^sub>1 F.counit\<^sub>0 F.counit\<^sub>1
       ..
     interpret G: equivalence_pseudofunctor
                    V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
                    F.right_map F.right_cmp
       using E'.equivalence_pseudofunctor_left by simp
 
     write V\<^sub>C          (infixr "\<cdot>\<^sub>C" 55)
     write V\<^sub>D          (infixr "\<cdot>\<^sub>D" 55)
     write H\<^sub>C          (infixr "\<star>\<^sub>C" 53)
     write H\<^sub>D          (infixr "\<star>\<^sub>D" 53)
     write \<a>\<^sub>C          ("\<a>\<^sub>C[_, _, _]")
     write \<a>\<^sub>D          ("\<a>\<^sub>D[_, _, _]")
     write C.in_hhom   ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     write C.in_hom    ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>C _\<guillemotright>")
     write D.in_hhom   ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
     write D.in_hom    ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>D _\<guillemotright>")
     write C.isomorphic (infix "\<cong>\<^sub>C" 50)
     write D.isomorphic (infix "\<cong>\<^sub>D" 50)
     write C.some_right_adjoint ("_\<^sup>*\<^sup>C" [1000] 1000)
     write D.some_right_adjoint ("_\<^sup>*\<^sup>D" [1000] 1000)
 
     show "bicategory_of_spans V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
     proof
       show "\<And>r'. D.ide r' \<Longrightarrow>
                  \<exists>f' g'. D.is_left_adjoint f' \<and> D.is_left_adjoint g' \<and> r' \<cong>\<^sub>D g' \<star>\<^sub>D (f')\<^sup>*\<^sup>D"
       proof -
         fix r'
         assume r': "D.ide r'"
         obtain f g
           where fg: "C.is_left_adjoint f \<and> C.is_left_adjoint g \<and> F.right_map r' \<cong>\<^sub>C g \<star>\<^sub>C f\<^sup>*\<^sup>C"
           using r' C.BS1 [of "F.right_map r'"] by auto
         have trg_g: "trg\<^sub>C g = E.G.map\<^sub>0 (trg\<^sub>D r')"
           using fg r' C.isomorphic_implies_ide C.isomorphic_implies_hpar
           by (metis C.ideD(1) C.trg_hcomp D.ideD(1) E.G.preserves_trg)
         have trg_f: "trg\<^sub>C f = E.G.map\<^sub>0 (src\<^sub>D r')"
           using fg r' C.isomorphic_implies_ide C.isomorphic_implies_hpar
           by (metis C.ideD(1) C.right_adjoint_simps(2) C.src_hcomp D.ideD(1) E.G.preserves_src)
 
         define d_src where "d_src \<equiv> F.counit\<^sub>0 (src\<^sub>D r')"
         define e_src where "e_src \<equiv> (F.counit\<^sub>0 (src\<^sub>D r'))\<^sup>~\<^sup>D"
         have d_src: "\<guillemotleft>d_src : F.map\<^sub>0 (E.G.map\<^sub>0 (src\<^sub>D r')) \<rightarrow>\<^sub>D src\<^sub>D r'\<guillemotright> \<and>
                      D.equivalence_map d_src"
           using d_src_def r' E.\<epsilon>.map\<^sub>0_in_hhom E.\<epsilon>.components_are_equivalences by simp
         have e_src: "\<guillemotleft>e_src : src\<^sub>D r' \<rightarrow>\<^sub>D F.map\<^sub>0 (E.G.map\<^sub>0 (src\<^sub>D r'))\<guillemotright> \<and>
                      D.equivalence_map e_src"
           using e_src_def r' E.\<epsilon>.map\<^sub>0_in_hhom E.\<epsilon>.components_are_equivalences by simp
         obtain \<eta>_src \<epsilon>_src
         where eq_src: "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D d_src e_src \<eta>_src \<epsilon>_src"
           using d_src_def e_src_def d_src e_src D.quasi_inverses_some_quasi_inverse
                 D.quasi_inverses_def
           by blast
         interpret eq_src: equivalence_in_bicategory
                             V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D d_src e_src \<eta>_src \<epsilon>_src
           using eq_src by simp
 
         define d_trg where "d_trg \<equiv> F.counit\<^sub>0 (trg\<^sub>D r')"
         define e_trg where "e_trg \<equiv> (F.counit\<^sub>0 (trg\<^sub>D r'))\<^sup>~\<^sup>D"
         have d_trg: "\<guillemotleft>d_trg : F.map\<^sub>0 (E.G.map\<^sub>0 (trg\<^sub>D r')) \<rightarrow>\<^sub>D trg\<^sub>D r'\<guillemotright> \<and>
                      D.equivalence_map d_trg"
           using d_trg_def r' E.\<epsilon>.map\<^sub>0_in_hhom E.\<epsilon>.components_are_equivalences by simp
         have e_trg: "\<guillemotleft>e_trg : trg\<^sub>D r' \<rightarrow>\<^sub>D F.map\<^sub>0 (E.G.map\<^sub>0 (trg\<^sub>D r'))\<guillemotright> \<and>
                      D.equivalence_map e_trg"
           using e_trg_def r' E.\<epsilon>.map\<^sub>0_in_hhom E.\<epsilon>.components_are_equivalences by simp
         obtain \<eta>_trg \<epsilon>_trg
         where eq_trg: "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D d_trg e_trg \<eta>_trg \<epsilon>_trg"
           using d_trg_def e_trg_def d_trg e_trg D.quasi_inverses_some_quasi_inverse
                 D.quasi_inverses_def
           by blast
         interpret eq_trg: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D d_trg e_trg \<eta>_trg \<epsilon>_trg
           using eq_trg by simp
 
         interpret eqs: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
                             d_src e_src \<eta>_src \<epsilon>_src d_trg e_trg \<eta>_trg \<epsilon>_trg
           ..
          
         interpret hom: subcategory V\<^sub>D \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : trg\<^sub>D d_src \<rightarrow>\<^sub>D trg\<^sub>D d_trg\<guillemotright>\<close>
           using D.hhom_is_subcategory by simp
         interpret hom': subcategory V\<^sub>D \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : src\<^sub>D d_src \<rightarrow>\<^sub>D src\<^sub>D d_trg\<guillemotright>\<close>
           using D.hhom_is_subcategory by simp
         interpret e: equivalence_of_categories hom.comp hom'.comp eqs.F eqs.G eqs.\<phi> eqs.\<psi>
           using eqs.induces_equivalence_of_hom_categories by simp
 
         have r'_in_hhom: "D.in_hhom r' (src\<^sub>D e_src) (src\<^sub>D e_trg)"
           using r' e_src e_trg by (simp add: D.in_hhom_def)
 
         define g'
         where "g' = d_trg \<star>\<^sub>D F g"
         have g': "D.is_left_adjoint g'"
           unfolding g'_def
           using fg r' d_trg trg_g C.left_adjoint_is_ide D.equivalence_is_adjoint
                 D.left_adjoints_compose F.preserves_left_adjoint C.ideD(1) D.in_hhom_def
                 F.preserves_trg
           by metis
         have 1: "D.is_right_adjoint (F f\<^sup>*\<^sup>C \<star>\<^sub>D e_src)"
         proof -
           have "D.is_right_adjoint e_src"
             using r' e_src D.equivalence_is_adjoint by simp
           moreover have "D.is_right_adjoint (F f\<^sup>*\<^sup>C)"
             using fg C.left_adjoint_extends_to_adjoint_pair F.preserves_adjoint_pair by blast
           moreover have "src\<^sub>D (F f\<^sup>*\<^sup>C) = trg\<^sub>D e_src"
             using fg r' trg_f C.right_adjoint_is_ide e_src by auto
           ultimately show ?thesis
             using fg r' D.right_adjoints_compose F.preserves_right_adjoint by blast
         qed
         obtain f' where f': "D.adjoint_pair f' (F f\<^sup>*\<^sup>C \<star>\<^sub>D e_src)"
           using 1 by auto
         have f': "D.is_left_adjoint f' \<and> F f\<^sup>*\<^sup>C \<star>\<^sub>D e_src \<cong>\<^sub>D (f')\<^sup>*\<^sup>D"
           using f' D.left_adjoint_determines_right_up_to_iso D.left_adjoint_extends_to_adjoint_pair
           by blast
 
         have "r' \<cong>\<^sub>D d_trg \<star>\<^sub>D (e_trg \<star>\<^sub>D r' \<star>\<^sub>D d_src) \<star>\<^sub>D e_src"
           using r' r'_in_hhom D.isomorphic_def eqs.\<psi>_in_hom eqs.\<psi>_components_are_iso
                 D.isomorphic_symmetric D.ide_char eq_src.antipar(2) eq_trg.antipar(2)
           by metis
         also have 1: "... \<cong>\<^sub>D d_trg \<star>\<^sub>D F (F.right_map r') \<star>\<^sub>D e_src"
         proof -
           have "e_trg \<star>\<^sub>D r' \<star>\<^sub>D d_src \<cong>\<^sub>D F (F.right_map r')"
           proof -
             have "D.in_hom (F.counit\<^sub>1 r')
                     (r' \<star>\<^sub>D d_src) (F.counit\<^sub>0 (trg\<^sub>D r') \<star>\<^sub>D F (F.right_map r'))"
               unfolding d_src_def
               using r' E.\<epsilon>.map\<^sub>1_in_hom(2) [of r'] by simp
             hence "r' \<star>\<^sub>D d_src \<cong>\<^sub>D F.counit\<^sub>0 (trg\<^sub>D r') \<star>\<^sub>D F (F.right_map r')"
               using r' D.isomorphic_def E.\<epsilon>.iso_map\<^sub>1_ide by auto
             thus ?thesis
               using r' e_trg_def E.\<epsilon>.components_are_equivalences D.isomorphic_symmetric
                     D.quasi_inverse_transpose(2)
               by (metis D.isomorphic_implies_hpar(1) F.preserves_isomorphic d_trg d_trg_def
                   eq_trg.ide_left fg)
           qed
           thus ?thesis
             using D.hcomp_ide_isomorphic D.hcomp_isomorphic_ide D.in_hhom_def
                   D.isomorphic_implies_hpar(4) d_trg e_src eq_src.antipar(1-2)
                   eq_trg.antipar(2) r'
             by force
         qed
         also have 2: "... \<cong>\<^sub>D d_trg \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D e_src"
         proof -
           have "F (F.right_map r') \<cong>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C"
             by (meson C.hseq_char C.ideD(1) C.isomorphic_implies_ide(2) C.left_adjoint_is_ide
                 C.right_adjoint_simps(1) D.isomorphic_symmetric D.isomorphic_transitive
                 F.preserves_isomorphic F.weakly_preserves_hcomp fg)
           thus ?thesis
             using D.hcomp_ide_isomorphic D.hcomp_isomorphic_ide
             by (metis 1 D.hseqE D.ideD(1) D.isomorphic_implies_hpar(2)
                 eq_src.ide_right eq_trg.ide_left)
         qed
         also have 3: "... \<cong>\<^sub>D (d_trg \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D e_src"
         proof -
           have "... \<cong>\<^sub>D d_trg \<star>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D e_src"
             by (metis C.left_adjoint_is_ide C.right_adjoint_simps(1) D.hcomp_assoc_isomorphic
                 D.hcomp_ide_isomorphic D.hcomp_simps(1) D.hseq_char D.ideD(1)
                 D.isomorphic_implies_hpar(2) F.preserves_ide calculation eq_src.ide_right
                 eq_trg.ide_left fg)
           also have "... \<cong>\<^sub>D (d_trg \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D e_src"
             by (metis C.left_adjoint_is_ide D.hcomp_assoc_isomorphic D.hcomp_simps(2)
                 D.hseq_char D.ideD(1) D.isomorphic_implies_ide(1) D.isomorphic_symmetric
                 F.preserves_ide calculation eq_trg.ide_left f' fg)
           finally show ?thesis by blast
         qed
         also have "... \<cong>\<^sub>D g' \<star>\<^sub>D f'\<^sup>*\<^sup>D"
           using g'_def f'
           by (metis 3 D.adjoint_pair_antipar(1) D.hcomp_ide_isomorphic D.hseq_char D.ideD(1)
               D.isomorphic_implies_ide(2) g')
         finally have "D.isomorphic r' (g' \<star>\<^sub>D f'\<^sup>*\<^sup>D)"
           by simp
         thus "\<exists>f' g'. D.is_left_adjoint f' \<and> D.is_left_adjoint g' \<and> r' \<cong>\<^sub>D g' \<star>\<^sub>D f'\<^sup>*\<^sup>D"
           using f' g' by auto
       qed
       show "\<And>f f' \<mu> \<mu>'. \<lbrakk> D.is_left_adjoint f; D.is_left_adjoint f';
                            \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>D f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>D f'\<guillemotright> \<rbrakk> \<Longrightarrow> D.iso \<mu> \<and> D.iso \<mu>' \<and> \<mu> = \<mu>'"
       proof -
         fix f f' \<mu> \<mu>'
         assume f: "D.is_left_adjoint f"
         and f': "D.is_left_adjoint f'"
         and \<mu>: "\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>D f'\<guillemotright>"
         and \<mu>': "\<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>D f'\<guillemotright>"
         have "C.is_left_adjoint (F.right_map f) \<and> C.is_left_adjoint (F.right_map f')"
           using f f' E.G.preserves_left_adjoint by blast
         moreover have "\<guillemotleft>F.right_map \<mu> : F.right_map f \<Rightarrow>\<^sub>C F.right_map f'\<guillemotright> \<and>
                        \<guillemotleft>F.right_map \<mu>' : F.right_map f \<Rightarrow>\<^sub>C F.right_map f'\<guillemotright>"
           using \<mu> \<mu>' E.G.preserves_hom by simp
         ultimately have "C.iso (F.right_map \<mu>) \<and> C.iso (F.right_map \<mu>') \<and>
                          F.right_map \<mu> = F.right_map \<mu>'"
           using C.BS3 by blast
         thus "D.iso \<mu> \<and> D.iso \<mu>' \<and> \<mu> = \<mu>'"
           using \<mu> \<mu>' G.reflects_iso G.is_faithful by blast
       qed
       show "\<And>f g. \<lbrakk> D.is_left_adjoint f; D.is_left_adjoint g; src\<^sub>D f = src\<^sub>D g \<rbrakk>
                      \<Longrightarrow> \<exists>r \<rho>. tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r \<rho> f g"
       proof -
         fix f g
         assume f: "D.is_left_adjoint f"
         assume g: "D.is_left_adjoint g"
         assume fg: "src\<^sub>D f = src\<^sub>D g"
         have "C.is_left_adjoint (F.right_map f)"
           using f E.G.preserves_left_adjoint by blast
         moreover have "C.is_left_adjoint (F.right_map g)"
           using g E.G.preserves_left_adjoint by blast
         moreover have "src\<^sub>C (F.right_map f) = src\<^sub>C (F.right_map g)"
           using f g D.left_adjoint_is_ide fg by simp
         ultimately have
             1: "\<exists>r \<rho>. tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> (F.right_map f) (F.right_map g)"
           using C.BS2 by simp
         obtain r \<rho> where
             \<rho>: "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> (F.right_map f) (F.right_map g)"
           using 1 by auto
         interpret \<rho>: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> \<open>F.right_map f\<close> \<open>F.right_map g\<close>
           using \<rho> by simp
         obtain r' where
           r': "D.ide r' \<and> D.in_hhom r' (trg\<^sub>D f) (trg\<^sub>D g) \<and> C.isomorphic (F.right_map r') r"
           using f g \<rho>.ide_base \<rho>.tab_in_hom G.locally_essentially_surjective
           by (metis D.obj_trg E.G.preserves_reflects_arr E.G.preserves_trg \<rho>.leg0_simps(2-3)
               \<rho>.leg1_simps(2,4) \<rho>.base_in_hom(1))
         obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : r \<Rightarrow>\<^sub>C F.right_map r'\<guillemotright> \<and> C.iso \<phi>"
           using r' C.isomorphic_symmetric by blast
         have \<sigma>: "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
                    (F.right_map r') ((\<phi> \<star>\<^sub>C F.right_map f) \<cdot>\<^sub>C \<rho>) (F.right_map f) (F.right_map g)"
           using \<phi> \<rho>.is_preserved_by_base_iso by simp
         have 1: "\<exists>\<rho>'. \<guillemotleft>\<rho>' : g \<Rightarrow>\<^sub>D H\<^sub>D r' f\<guillemotright> \<and>
                       F.right_map \<rho>' = F.right_cmp (r', f) \<cdot>\<^sub>C (\<phi> \<star>\<^sub>C F.right_map f) \<cdot>\<^sub>C \<rho>"
         proof -
           have "D.ide g"
             by (simp add: D.left_adjoint_is_ide g)
           moreover have "D.ide (H\<^sub>D r' f)"
             using f r' D.left_adjoint_is_ide by auto
           moreover have "src\<^sub>D g = src\<^sub>D (H\<^sub>D r' f)"
             using fg by (simp add: calculation(2))
           moreover have "trg\<^sub>D g = trg\<^sub>D (H\<^sub>D r' f)"
             using calculation(2) r' by auto
           moreover have "\<guillemotleft>F.right_cmp (r', f) \<cdot>\<^sub>C (\<phi> \<star>\<^sub>C F.right_map f) \<cdot>\<^sub>C \<rho> :
                             F.right_map g \<Rightarrow>\<^sub>C F.right_map (r' \<star>\<^sub>D f)\<guillemotright>"
             using f g r' \<phi> D.left_adjoint_is_ide \<rho>.ide_base
             by (intro C.comp_in_homI, auto)
           ultimately show ?thesis
             using G.locally_full by simp
         qed
         obtain \<rho>' where \<rho>': "\<guillemotleft>\<rho>' : g \<Rightarrow>\<^sub>D H\<^sub>D r' f\<guillemotright> \<and>
                              F.right_map \<rho>' = F.right_cmp (r', f) \<cdot>\<^sub>C (\<phi> \<star>\<^sub>C F.right_map f) \<cdot>\<^sub>C \<rho>"
           using 1 by auto
         have "tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r' \<rho>' f g"
         proof -
           have "C.inv (F.right_cmp (r', f)) \<cdot>\<^sub>C F.right_map \<rho>' = (\<phi> \<star>\<^sub>C F.right_map f) \<cdot>\<^sub>C \<rho>"
             using r' f \<rho>' C.comp_assoc C.comp_cod_arr C.invert_side_of_triangle(1)
             by (metis D.adjoint_pair_antipar(1) D.arrI D.in_hhomE E.G.cmp_components_are_iso
                 E.G.preserves_arr)
           thus ?thesis
             using \<sigma> \<rho>' G.reflects_tabulation
             by (simp add: D.left_adjoint_is_ide f r')
         qed
         thus "\<exists>r' \<rho>'. tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r' \<rho>' f g"
           by auto
       qed
     qed
   qed
 
   subsection "Span(C) is a Bicategory of Spans"
 
   text \<open>
     We first consider an arbitrary 1-cell \<open>r\<close> in \<open>Span(C)\<close>, and show that it has a tabulation
     as a span of maps.  This is CKS Proposition 3 (stated more strongly to assert that
     the ``output leg'' can also be taken to be a map, which the proof shows already).
   \<close>
 
   locale identity_arrow_in_span_bicategory =  (* 20 sec *)
     span_bicategory C prj0 prj1 +
     r: identity_arrow_of_spans C r
     for C :: "'a comp"   (infixr "\<cdot>" 55)
     and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<p>\<^sub>0[_, _]")
     and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<p>\<^sub>1[_, _]")
     and r :: "'a arrow_of_spans_data"
   begin
     text \<open>
       CKS say: ``Suppose \<open>r = (r\<^sub>0, R, r\<^sub>1): A \<rightarrow> B\<close> and put \<open>f = (1, R, r\<^sub>0)\<close>, \<open>g = (1, R, r\<^sub>1)\<close>.
       Let \<open>k\<^sub>0, k\<^sub>1\<close> form a kernel pair for \<open>r\<^sub>0\<close> and define \<open>\<rho>\<close> by \<open>k\<^sub>0\<rho> = k\<^sub>1\<rho> = 1\<^sub>R\<close>.''
     \<close>
     abbreviation ra where "ra \<equiv> r.dom.apex"
     abbreviation r0 where "r0 \<equiv> r.dom.leg0"
     abbreviation r1 where "r1 \<equiv> r.dom.leg1"
     abbreviation f where "f \<equiv> mkIde ra r0"
     abbreviation g where "g \<equiv> mkIde ra r1"
     abbreviation k0 where "k0 \<equiv> \<p>\<^sub>0[r0, r0]"
     abbreviation k1 where "k1 \<equiv> \<p>\<^sub>1[r0, r0]"
     text \<open>
       Here \<open>ra\<close> is the apex \<open>R\<close> of the span \<open>(r\<^sub>0, R, r\<^sub>1)\<close>, and the spans \<open>f\<close> and \<open>g\<close> also have
       that same 0-cell as their apex.  The tabulation 2-cell \<open>\<rho>\<close> has to be an arrow of spans
       from \<open>g = (1, R, r\<^sub>1)\<close> to \<open>r \<star> f\<close>, which is the span \<open>(k\<^sub>0, r\<^sub>1 \<cdot> k\<^sub>1)\<close>.
     \<close>
     abbreviation \<rho> where "\<rho> \<equiv> \<lparr>Chn = \<langle>ra \<lbrakk>r0, r0\<rbrakk> ra\<rangle>,
                                Dom = \<lparr>Leg0 = ra, Leg1 = r1\<rparr>,
                                Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>"
 
     lemma has_tabulation:
     shows "tabulation vcomp hcomp assoc unit src trg r \<rho> f g"
     and "is_left_adjoint f" and "is_left_adjoint g"
     proof -
       have ide_f: "ide f"
         using ide_mkIde r.dom.leg_in_hom(1) C.arr_dom C.dom_dom r.dom.apex_def r.dom.leg_simps(1)
         by presburger
       interpret f: identity_arrow_of_spans C f
         using ide_f ide_char' by auto
       have ide_g: "ide g"
         using ide_mkIde r.dom.leg_in_hom
         by (metis C.arr_dom C.dom_dom r.dom.leg_simps(3) r.dom.leg_simps(4))
       interpret g: identity_arrow_of_spans C g
         using ide_g ide_char' by auto
 
       show "is_left_adjoint f"
         using is_left_adjoint_char [of f] ide_f by simp
       show "is_left_adjoint g"
         using is_left_adjoint_char [of g] ide_g by simp
       
       have ide_r: "ide r"
         using ide_char' r.identity_arrow_of_spans_axioms by auto
       have src_r: "src r = mkObj (C.cod r0)"
         by (simp add: ide_r src_def)
       have trg_r: "trg r = mkObj (C.cod r1)"
         by (simp add: ide_r trg_def)
       have src_f: "src f = mkObj ra"
         using ide_f src_def by auto
       have trg_f: "trg f = mkObj (C.cod r0)"
         using ide_f trg_def by auto
       have src_g: "src g = mkObj ra"
         using ide_g src_def by auto
       have trg_g: "trg g = mkObj (C.cod r1)"
         using ide_g trg_def by auto
 
       have hseq_rf: "hseq r f"
         using ide_r ide_f src_r trg_f by simp
       interpret rf: two_composable_arrows_of_spans C prj0 prj1 r f
         using hseq_rf hseq_char by unfold_locales auto
       interpret rf: two_composable_identity_arrows_of_spans C prj0 prj1 r f ..
       interpret rf: identity_arrow_of_spans C \<open>r \<star> f\<close> 
         using rf.ide_composite ide_char' by auto
       let ?rf = "r \<star> f"
       (* TODO: Put this expansion into two_composable_identity_arrows_of_spans. *)
       have rf: "?rf = \<lparr>Chn = r0 \<down>\<down> r0,
                        Dom = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>,
                        Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>"
         unfolding hcomp_def chine_hcomp_def
         using hseq_rf C.comp_cod_arr by auto
 
       interpret Cod_rf: span_in_category C \<open>\<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<close>
         using ide_r ide_f rf C.comp_cod_arr
         by unfold_locales auto
 
       have Dom_g: "Dom g = \<lparr>Leg0 = ra, Leg1 = r1\<rparr>" by simp
       interpret Dom_g: span_in_category C \<open>\<lparr>Leg0 = ra, Leg1 = r1\<rparr>\<close>
         using Dom_g g.dom.span_in_category_axioms by simp
       interpret Dom_\<rho>: span_in_category C \<open>Dom \<rho>\<close>
         using Dom_g g.dom.span_in_category_axioms by simp
       interpret Cod_\<rho>: span_in_category C \<open>Cod \<rho>\<close>
         using rf Cod_rf.span_in_category_axioms by simp
       interpret \<rho>: arrow_of_spans C \<rho>
         using Dom_\<rho>.apex_def Cod_\<rho>.apex_def C.comp_assoc C.comp_arr_dom
         by unfold_locales auto
       have \<rho>: "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
         using rf ide_g arr_char dom_char cod_char \<rho>.arrow_of_spans_axioms ideD(2)
               Cod_rf.apex_def g.dom.leg_simps(4)
         by auto
 
       show "tabulation vcomp hcomp assoc unit src trg r \<rho> f g"
       proof -
         interpret T: tabulation_data vcomp hcomp assoc unit src trg r \<rho> f g
           using ide_f \<rho> by unfold_locales auto
         show ?thesis
         proof
           show T1: "\<And>u \<omega>.
                        \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
                        \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                                T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
           proof -
             fix u \<omega>
             assume u: "ide u"
             assume \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
             show "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                           T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
             proof -
               interpret u: identity_arrow_of_spans C u
                 using u ide_char' by auto
               have v: "ide (dom \<omega>)"
                 using \<omega> by auto
               interpret v: identity_arrow_of_spans C \<open>dom \<omega>\<close>
                 using v ide_char' by auto
               interpret \<omega>: arrow_of_spans C \<omega>
                 using \<omega> arr_char by auto
               have hseq_ru: "hseq r u"
                 using u \<omega> ide_cod by fastforce
               interpret ru: two_composable_arrows_of_spans C prj0 prj1 r u
                 using hseq_ru hseq_char by unfold_locales auto
               interpret ru: two_composable_identity_arrows_of_spans C prj0 prj1 r u ..
               text \<open>
                 CKS say:
                 ``We must show that \<open>(f, \<rho>, g)\<close> is a wide tabulation of \<open>r\<close>.
                 Take \<open>u = (u\<^sub>0, U, u\<^sub>1): X \<rightarrow> A\<close>, \<open>v = (v\<^sub>0, V, v\<^sub>1): X \<rightarrow> B\<close>,
                 \<open>\<omega>: v \<Rightarrow> ru\<close> as in \<open>T1\<close>.  Let \<open>P\<close> be the pullback of \<open>u\<^sub>1, r\<^sub>0\<close>.
                 Let \<open>w = (v\<^sub>0, V, p\<^sub>1\<omega>): X \<rightarrow> R\<close>, \<open>\<theta> = p\<^sub>0\<omega>: fw \<Rightarrow> u\<close>,
                 \<open>\<nu> = 1: v \<Rightarrow> gw\<close>; so \<open>\<omega> = (r\<theta>)(\<rho>w)\<nu>\<close> as required.''
               \<close>
               let ?R = "r.apex"
               let ?A = "C.cod r0"
               let ?B = "C.cod r1"
               let ?U = "u.apex"
               let ?u0 = "u.leg0"
               let ?u1 = "u.leg1"
               let ?X = "C.cod ?u0"
               let ?V = "v.apex"
               let ?v0 = "v.leg0"
               let ?v1 = "v.leg1"
               let ?\<omega> = "\<omega>.chine"
               let ?P = "r0 \<down>\<down> ?u1"
               let ?p0 = "\<p>\<^sub>0[r0, ?u1]"
               let ?p1 = "\<p>\<^sub>1[r0, ?u1]"
               let ?w1 = "?p1 \<cdot> ?\<omega>"
               define w where "w = mkIde ?v0 ?w1"
               let ?Q = "?R \<down>\<down> ?w1"
               let ?q1 = "\<p>\<^sub>1[?R, ?w1]"
               let ?\<rho> = "\<langle>?R \<lbrakk>r0, r0\<rbrakk> ?R\<rangle>"
 
               have P: "?P = ru.apex"
                 using ru.apex_composite by auto
 
               have Chn_\<omega>: "\<guillemotleft>?\<omega> : ?V \<rightarrow>\<^sub>C ?P\<guillemotright>"
                 using P Chn_in_hom \<omega> by force
               have p0\<omega>: "\<guillemotleft>?p0 \<cdot> ?\<omega> : ?V \<rightarrow>\<^sub>C ?U\<guillemotright>"
                 using Chn_\<omega> ru.legs_form_cospan by auto
               have w1: "\<guillemotleft>?w1 : ?V \<rightarrow>\<^sub>C ?R\<guillemotright>"
                  using Chn_\<omega> ru.legs_form_cospan r.dom.apex_def by blast
               have r1w1: "r1 \<cdot> ?w1 = ?v1"
                 by (metis C.comp_assoc T.base_simps(3) \<omega> \<omega>.leg1_commutes
                     arrow_of_spans_data.select_convs(3) cod_char dom_char ideD(1) ideD(2)
                     in_homE ru.composite_in_hom ru.leg1_composite u v)
 
               have w: "ide w"
                 unfolding w_def
                 using P \<omega> w1 by (intro ide_mkIde, auto) 
               interpret w: identity_arrow_of_spans C w
                 using w_def w ide_char' by auto
 
               have hseq_fw: "hseq f w"
                 using w_def ide_f w src_def trg_def w1 by auto
               interpret fw: two_composable_arrows_of_spans C prj0 prj1 f w
                 using w_def hseq_fw hseq_char by unfold_locales auto
               interpret fw: two_composable_identity_arrows_of_spans C prj0 prj1 f w ..
 
               have hseq_gw: "hseq g w"
                 using w_def ide_g w src_def trg_def w1 by auto
               interpret gw: two_composable_arrows_of_spans C prj0 prj1 g w
                 using hseq_gw hseq_char by unfold_locales auto
               interpret gw: two_composable_identity_arrows_of_spans C prj0 prj1 g w ..
 
               interpret rfw: three_composable_arrows_of_spans C prj0 prj1 r f w ..
               interpret rfw: three_composable_identity_arrows_of_spans C prj0 prj1 r f w ..
               have arfw: "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
                 using fw.composable ide_f ide_r w rf.composable by auto
 
               have fw_apex_eq: "fw.apex = ?R \<down>\<down> ?w1"
                 using w_def fw.dom.apex_def hcomp_def hseq_fw hseq_char \<omega> C.arr_dom_iff_arr
                       C.pbdom_def fw.chine_eq_apex fw.chine_simps(1)
                 by auto
               have gw_apex_eq: "gw.apex = ?R \<down>\<down> ?w1"
                 using w_def \<omega> w1 gw.dom.apex_def hcomp_def hseq_gw hseq_char by auto
               text \<open>
                 Well, CKS say take \<open>\<theta> = p\<^sub>0\<omega>\<close>, but taking this literally and trying to define
                 \<open>\<theta>\<close> so that \<open>Chn \<theta> = ?p\<^sub>0 \<cdot> ?\<omega>\<close>, does not yield the required \<open>dom \<theta> = ?R \<down>\<down> ?w1\<close>.
                 We need \<open>\<guillemotleft>Chn \<theta> : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?U\<guillemotright>\<close>, so we have to compose with a
                 projection, which leads to:  \<open>Chn \<theta> = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]\<close>.
                 What CKS say is only correct if the projection \<open>\<p>\<^sub>0[?R, ?w1]\<close> is an identity,
                 which can't be guaranteed for an arbitrary choice of pullbacks.
               \<close>
               define \<theta>
                 where
                   "\<theta> = \<lparr>Chn = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1], Dom = Dom (f \<star> w), Cod = Cod u\<rparr>"
 
               interpret Dom_\<theta>: span_in_category C \<open>Dom \<theta>\<close>
                 using \<theta>_def fw.dom.span_in_category_axioms by simp
               interpret Cod_\<theta>: span_in_category C \<open>Cod \<theta>\<close>
                 using \<theta>_def u.cod.span_in_category_axioms by simp
 
               have Dom_\<theta>_leg0_eq: "Dom_\<theta>.leg0 = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
                 using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
               have Dom_\<theta>_leg1_eq: "Dom_\<theta>.leg1 = r0 \<cdot> ?q1"
                 using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
               have Cod_\<theta>_leg0_eq: "Cod_\<theta>.leg0 = ?u0"
                 using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
               have Cod_\<theta>_leg1_eq: "Cod_\<theta>.leg1 = ?u1"
                 using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
               have Chn_\<theta>_eq: "Chn \<theta> = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
                 using \<theta>_def by simp
 
               interpret \<theta>: arrow_of_spans C \<theta>
               proof
                 show 1: "\<guillemotleft>Chn \<theta> : Dom_\<theta>.apex \<rightarrow>\<^sub>C Cod_\<theta>.apex\<guillemotright>"
                   using \<theta>_def Chn_\<omega> ru.legs_form_cospan fw_apex_eq
                   by (intro C.in_homI, auto)
                 show "Cod_\<theta>.leg0 \<cdot> Chn \<theta> = Dom_\<theta>.leg0"
                 proof -
                   have "Cod_\<theta>.leg0 \<cdot> Chn \<theta> = ?u0 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
                     using Cod_\<theta>_leg0_eq Chn_\<theta>_eq by simp
                   also have "... = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
                   proof -
                     have "?u0 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1] = (?u0 \<cdot> ?p0 \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
                       using C.comp_assoc by simp
                     also have "... = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
                     proof -
                       have "?u0 \<cdot> ?p0 \<cdot> ?\<omega> = (?u0 \<cdot> ?p0) \<cdot> ?\<omega>"
                         using C.comp_assoc by simp
                       also have "... = \<omega>.cod.leg0 \<cdot> ?\<omega>"
                         by (metis \<omega> arrow_of_spans_data.select_convs(2) cod_char in_homE
                             ru.leg0_composite)
                       also have "... = \<omega>.dom.leg0"
                         using \<omega>.leg0_commutes by simp
                       also have "... = ?v0"
                         using \<omega> dom_char by auto
                       finally show ?thesis by simp
                     qed
                     finally show ?thesis by simp
                   qed
                   also have "... = Dom_\<theta>.leg0"
                     using Dom_\<theta>_leg0_eq by simp
                   finally show ?thesis by blast
                 qed
                 show "Cod_\<theta>.leg1 \<cdot> Chn \<theta> = Dom_\<theta>.leg1"
                 proof -
                   have "Cod_\<theta>.leg1 \<cdot> Chn \<theta> = ?u1 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
                     using Cod_\<theta>_leg1_eq Chn_\<theta>_eq by simp
                   also have "... = r0 \<cdot> ?q1"
                   proof -
                     have "?u1 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1] = ((?u1 \<cdot> ?p0) \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
                       using C.comp_assoc by fastforce
                     also have "... = ((r0 \<cdot> ?p1) \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
                       using C.pullback_commutes' ru.legs_form_cospan by simp
                     also have "... = r0 \<cdot> ?w1 \<cdot> \<p>\<^sub>0[?R, ?w1]"
                       using C.comp_assoc by fastforce
                     also have "... = r0 \<cdot> ?R \<cdot> ?q1"
                       using \<omega> C.in_homE C.pullback_commutes' w1 by auto
                     also have "... = r0 \<cdot> ?q1"
                       using \<omega> w1 C.comp_cod_arr by auto
                     finally show ?thesis by simp
                   qed
                   also have "... = Dom_\<theta>.leg1"
                     using Dom_\<theta>_leg1_eq by simp
                   finally show ?thesis by blast
                 qed
               qed
               text \<open>
                 Similarly, CKS say to take \<open>\<nu> = 1: v \<Rightarrow> gw\<close>, but obviously this can't be
                 interpreted literally, either, because \<open>v.apex\<close> and \<open>gw.apex\<close> are not equal.
                 Instead, we have to define \<open>\<nu>\<close> so that \<open>Chn \<nu> = C.inv \<p>\<^sub>0[?R, ?w1]\<close>,
                 noting that \<open>\<p>\<^sub>0[?R, ?w1]\<close> is the pullback of an identity,
                 hence is an isomorphism. Then \<open>?v0 \<cdot> \<p>\<^sub>0[?R, ?w1] \<cdot> Chn \<nu> = ?v0\<close> and
                 \<open>?v1 \<cdot> \<p>\<^sub>1[?R, ?w1] \<cdot> Chn \<nu> = ?v1 \<cdot> ?w1\<close>, showing that \<open>\<nu>\<close> is an arrow
                 of spans.
               \<close>
               let ?\<nu>' = "\<p>\<^sub>0[?R, ?w1]"
               define \<nu>
                 where
                   "\<nu> = \<lparr>Chn = C.inv ?\<nu>', Dom = Dom (dom \<omega>), Cod = Cod (g \<star> w)\<rparr>"
               have iso_\<nu>: "C.inverse_arrows ?\<nu>' (Chn \<nu>)"
                 using \<nu>_def \<omega> w1 C.iso_pullback_ide
                 by (metis C.inv_is_inverse C.seqE arrow_of_spans_data.select_convs(1)
                     r.chine_eq_apex r.chine_simps(1) r.chine_simps(3) r.cod_simps(1)
                     r.dom.apex_def r.dom.ide_apex r.dom.is_span r1w1 v.dom.leg_simps(3))
               text \<open>
 $$
 \xymatrix{
   && X \\
   && V \ar[u]_{v_0} \ar[d]_{\omega}  \ar@/ul50pt/[ddddll]_{v_1} \ar@/l30pt/[dd]_<>(0.7){w_1}\\
   & R\downarrow\downarrow w_1 \ar[ur]^{\nu'} \ar[dd]_{q_1}
   & r_0\downarrow\downarrow u_1 \ar[d]_{p_1} \ar@/dl10pt/[drr]_<>(0.4){p_0}
   & R\downarrow\downarrow w_1 \ar[ul]_{\nu'} \ar[dd]^<>(0.7){q_1} \ar@ {.>}[dr]_{\theta}\\
   && R && U \ar@/ur20pt/[uuull]_{u_0} \ar[dd]^{u_1} \\
   & R \ar[dl]_{r_1} \ar@ {<->}[ur]_{R} \ar@ {.>}[dr]^{\rho} \ar@/dl5pt/[ddr]_<>(0.4){R}
   && R \ar@ {<->}[ul]^{R} \ar[dr]^{r_0} \ar[ur]_{r_1}\\
   B && r_0\downarrow\downarrow r_0 \ar[uu]_{k_0} \ar[d]^{k_1} \ar[uu] \ar[ur]_{k_0} && A \\
   & & R \ar[ull]^{r_1} \ar[urr]_{r_0} \\
 }
 $$
               \<close>
               have w1_eq: "?w1 = ?q1 \<cdot> C.inv ?\<nu>'"
               proof -
                 have "?R \<cdot> ?q1 = ?w1 \<cdot> ?\<nu>'"
                   using iso_\<nu> \<omega> w1 C.pullback_commutes [of ?R ?w1] by blast
                 hence "?q1 = ?w1 \<cdot> ?\<nu>'"
                   using \<omega> w1 C.comp_cod_arr by auto
                 thus ?thesis
                   using iso_\<nu> C.invert_side_of_triangle(2)
                   by (metis C.isoI C.prj1_simps(1) arrow_of_spans_data.select_convs(3)
                       fw.legs_form_cospan(2) span_data.simps(1-2) w_def)
               qed
 
               interpret Dom_\<nu>: span_in_category C \<open>Dom \<nu>\<close>
                 using \<nu>_def v.dom.span_in_category_axioms by simp
               interpret Cod_\<nu>: span_in_category C \<open>Cod \<nu>\<close>
                 using \<nu>_def gw.cod.span_in_category_axioms by simp
               interpret \<nu>: arrow_of_spans C \<nu>
               proof
                 show 1: "\<guillemotleft>Chn \<nu> : Dom_\<nu>.apex \<rightarrow>\<^sub>C Cod_\<nu>.apex\<guillemotright>"
                 proof
                   show "C.arr (Chn \<nu>)"
                     using iso_\<nu> by auto
                   show "C.dom (Chn \<nu>) = Dom_\<nu>.apex"
                     using \<nu>_def iso_\<nu> w1 gw_apex_eq by fastforce
                   show "C.cod (Chn \<nu>) = Cod_\<nu>.apex"
                     using \<nu>_def iso_\<nu> gw_apex_eq C.comp_inv_arr C.pbdom_def
                     by (metis C.cod_comp arrow_of_spans_data.select_convs(3)
                         gw.apex_composite gw.chine_composite gw.chine_simps(1,3))
                 qed
                 show "Cod_\<nu>.leg0 \<cdot> Chn \<nu> = Dom_\<nu>.leg0"
                   using w_def \<nu>_def 1 iso_\<nu> hcomp_def hseq_gw C.comp_arr_inv
                         C.comp_assoc v.leg0_commutes
                   by auto
                 show "Cod_\<nu>.leg1 \<cdot> Chn \<nu> = Dom_\<nu>.leg1"
                   using w_def \<nu>_def hcomp_def hseq_gw C.comp_assoc w1_eq r1w1
                   by auto
               qed
               text \<open>
                 Now we can proceed to establishing the conclusions of \<open>T1\<close>.
               \<close>
               have "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> dom \<rho> \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                     T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
               proof (intro conjI)
                 show ide_w: "ide w"
                   using w by blast
                 show \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
                   using \<theta>_def \<theta>.arrow_of_spans_axioms arr_char dom_char cod_char hseq_fw hseq_char
                         hcomp_def fw.chine_eq_apex
                   by auto
                 show \<nu>: "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> dom \<rho> \<star> w\<guillemotright>"
                 proof -
                   have "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
                     using \<nu>_def \<omega> \<nu>.arrow_of_spans_axioms arr_char dom_char cod_char hseq_gw
                           hseq_char hcomp_def gw.chine_eq_apex
                     by auto
                   thus ?thesis
                     using T.tab_in_hom by simp
                 qed
                 show "iso \<nu>"
                   using iso_\<nu> iso_char arr_char \<nu>.arrow_of_spans_axioms by auto
                 show "T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
                 proof (intro arr_eqI)
                   have \<rho>w: "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
                     using w_def \<rho> ide_w hseq_rf hseq_fw hseq_gw by auto
                   have r\<theta>: "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
                     using arfw ide_r \<theta> fw.composite_simps(2) rf.composable by auto 
                   have 1: "\<guillemotleft>T.composite_cell w \<theta> \<bullet> \<nu> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
                     using \<nu> \<rho>w arfw r\<theta> by auto
                   show 3: "par (T.composite_cell w \<theta> \<bullet> \<nu>) \<omega>"
                     using 1 \<omega> by (elim in_homE, auto)
                   show "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) = ?\<omega>"
                   proof -
                     have 2: "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) =
                              Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                       using 1 3 Chn_vcomp C.comp_assoc
                       by (metis (full_types) seqE)
                     also have "... = ?\<omega>"
                     proof -
                       let ?LHS = "Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                       have Chn_r\<theta>: "Chn (r \<star> \<theta>) = \<langle>r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?q1]
                                                      \<lbrakk>r0, ?u1\<rbrakk>
                                                    \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]\<rangle>"
                         using r\<theta> hcomp_def \<theta>_def chine_hcomp_def Dom_\<theta>_leg1_eq
                         by (metis arrI arrow_of_spans_data.select_convs(1,3)
                             hseq_char r.cod_simps(2) u.cod_simps(3))
                       have Chn_arfw: "Chn \<a>[r, f, w] = rfw.chine_assoc"
                         using \<alpha>_ide ide_f rf.composable fw.composable w by auto
                       have Chn_\<rho>w: "Chn (\<rho> \<star> w) = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
                       proof -
                         have "Chn (\<rho> \<star> w) =
                               chine_hcomp
                                 \<lparr>Chn = ?\<rho>,
                                  Dom = \<lparr>Leg0 = ?R, Leg1 = r1\<rparr>,
                                  Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>
                                 \<lparr>Chn = v.apex,
                                  Dom = \<lparr>Leg0 = ?v0, Leg1 = ?w1\<rparr>,
                                  Cod = \<lparr>Leg0 = ?v0, Leg1 = ?w1\<rparr>\<rparr>"
                           using \<rho> ide_w hseq_rf hseq_char hcomp_def src_def trg_def
                           by (metis (no_types, lifting) \<rho>w arrI arrow_of_spans_data.select_convs(1)
                               v.dom.apex_def w_def)
                         also have "... = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?V \<cdot> ?\<nu>'\<rangle>"
                           unfolding chine_hcomp_def by simp
                         also have "... = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
                         proof -
                           have "?V \<cdot> ?\<nu>' = ?\<nu>'"
                             using C.comp_ide_arr v.dom.ide_apex \<rho> w1 by auto
                           thus ?thesis by simp
                         qed
                         finally show ?thesis by blast
                       qed
 
                       have 3: "C.seq ?p1 ?\<omega>"
                         using w1 by blast
                       moreover have 4: "C.seq ?p1 ?LHS"
                       proof
                         show "\<guillemotleft>?LHS : v.apex \<rightarrow>\<^sub>C ru.apex\<guillemotright>"
                           by (metis (no_types, lifting) 1 2 Chn_in_hom ru.chine_eq_apex
                               v.chine_eq_apex)
                         show "\<guillemotleft>?p1 : ru.apex \<rightarrow>\<^sub>C ?R\<guillemotright>"
                           using P C.prj1_in_hom ru.legs_form_cospan by fastforce
                       qed
                       moreover have "?p0 \<cdot> ?LHS = ?p0 \<cdot> ?\<omega>"
                       proof -
                         have "?p0 \<cdot> ?LHS =
                               (?p0 \<cdot> Chn (r \<star> \<theta>)) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                           using C.comp_assoc by simp
                         also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]) \<cdot>
                                            Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                         proof -
                           have "?p0 \<cdot> Chn (r \<star> \<theta>) = \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]"
                             by (metis C.prj_tuple(1) Chn_r\<theta> \<theta>_def arrI Dom_\<theta>_leg1_eq
                                 arrow_of_spans_data.select_convs(3) chine_hcomp_props(2)
                                 hseq_char r.cod_simps(2) r\<theta> u.cod_simps(3))
                           thus ?thesis by argo
                         qed
                         also have
                           "... = ?p0 \<cdot> ?\<omega> \<cdot> (rfw.Prj\<^sub>0\<^sub>0 \<cdot> Chn \<a>[r, f, w]) \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                           using w_def \<theta>_def C.comp_assoc by simp
                         also have "... = ?p0 \<cdot> ?\<omega> \<cdot> (rfw.Prj\<^sub>0  \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
                           using Chn_arfw rfw.prj_chine_assoc C.comp_assoc by simp
                         also have "... = ?p0 \<cdot> ?\<omega> \<cdot> ?\<nu>' \<cdot> Chn \<nu>"
                         proof -
                           have "rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w) = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
                             using w_def Chn_\<rho>w C.comp_cod_arr by simp
                           also have "... = ?\<nu>'"
                             by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(1) C.seqE
                                 C.tuple_is_extensional Chn_\<rho>w 4)
                           finally have "rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w) = ?\<nu>'"
                             by blast
                           thus ?thesis by simp
                         qed
                         also have "... = ?p0 \<cdot> ?\<omega>"
                           using iso_\<nu> C.comp_arr_dom
                           by (metis (no_types, lifting) C.comp_arr_inv C.dom_comp \<nu>_def
                               \<omega>.chine_simps(1) 3 arrow_of_spans_data.simps(1) w1_eq)
                         finally show ?thesis by blast
                       qed
                       moreover have "?p1 \<cdot> ?LHS = ?w1"
                       proof -
                         have "?p1 \<cdot> ?LHS =
                               (?p1 \<cdot> Chn (r \<star> \<theta>)) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                           using C.comp_assoc by simp
                         also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?q1]) \<cdot> Chn \<a>[r, f, w] \<cdot>
                                            Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                           by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(2) C.seqE
                               C.tuple_is_extensional Chn_r\<theta> 4)
                         also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
                           using w_def Dom_\<theta>_leg1_eq C.comp_assoc by simp
                         also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
                           using Chn_arfw rfw.prj_chine_assoc(1) C.comp_assoc by simp
                         also have "... = r.chine \<cdot> ?q1 \<cdot> Chn \<nu>"
                         proof -
                           have "rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w) =
                                  (k1 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
                             using w_def Chn_\<rho>w C.comp_cod_arr by simp
                           also have "... = k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
                             using C.comp_assoc by simp
                           also have "... = k1 \<cdot> ?\<rho> \<cdot> ?q1"
                             by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(2)
                                 C.seqE C.tuple_is_extensional Chn_\<rho>w 4)
                           also have "... = (k1 \<cdot> ?\<rho>) \<cdot> ?q1"
                             using C.comp_assoc by presburger
                           also have "... = ?R \<cdot> ?q1"
                             by simp
                           also have "... = ?q1"
                             by (metis Dom_\<theta>_leg1_eq C.comp_ide_arr C.prj1_simps(3)
                                 C.prj1_simps_arr C.seqE C.seqI Dom_\<theta>.leg_simps(3)
                                 r.dom.ide_apex)
                           finally have "rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w) = ?q1"
                             by blast
                           thus ?thesis by simp
                         qed
                         also have "... = (r.chine \<cdot> ?p1) \<cdot> ?\<omega>"
                           using \<nu>_def w1_eq C.comp_assoc by simp
                         also have "... = ?w1"
                           using C.comp_cod_arr r.chine_eq_apex ru.prj_simps(1) by auto
                         finally show ?thesis by blast
                       qed
                       ultimately show ?thesis
                         using ru.legs_form_cospan C.prj_joint_monic by blast
                     qed
                     finally show ?thesis by argo
                   qed
                 qed
               qed
               thus ?thesis
                 using w_def by auto
             qed
           qed
 
           show T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
                        \<lbrakk> ide w; ide w';
                          \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
                          T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<bullet> \<beta> \<rbrakk> \<Longrightarrow>
                        \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)"
           proof -
             fix u w w' \<theta> \<theta>' \<beta>
             assume ide_w: "ide w"
             assume ide_w': "ide w'"
             assume \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
             assume \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
             assume \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
             assume E: "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<bullet> \<beta>"
             interpret T: uw\<theta>w'\<theta>'\<beta> vcomp hcomp assoc unit src trg r \<rho> f g u w \<theta> w' \<theta>' \<beta>
               using ide_w ide_w' \<theta> \<theta>' \<beta> E comp_assoc
               by unfold_locales auto
 
             show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)"
             proof
               interpret u: identity_arrow_of_spans C u
                 using T.uw\<theta>.u_simps(1) ide_char' by auto
               interpret w: identity_arrow_of_spans C w
                 using ide_w ide_char' by auto
               interpret w': identity_arrow_of_spans C w'
                 using ide_w' ide_char' by auto
               let ?u0 = u.leg0
               let ?u1 = u.leg1
               let ?w0 = w.leg0
               let ?w1 = w.leg1
               let ?wa = "w.apex"
               let ?w0' = w'.leg0
               let ?w1' = w'.leg1
               let ?wa' = "w'.apex"
               let ?R = ra
               let ?p0 = "\<p>\<^sub>0[?R, ?w1]"
               let ?p0' = "\<p>\<^sub>0[?R, ?w1']"
               let ?p1 = "\<p>\<^sub>1[?R, ?w1]"
               let ?p1' = "\<p>\<^sub>1[?R, ?w1']"
 
               interpret fw: two_composable_identity_arrows_of_spans C prj0 prj1 f w
                 using hseq_char by unfold_locales auto
               interpret fw': two_composable_identity_arrows_of_spans C prj0 prj1 f w'
                 using hseq_char by unfold_locales auto
 
               have hseq_gw: "hseq g w"
                 using T.leg1_in_hom by auto
               interpret gw: two_composable_identity_arrows_of_spans C prj0 prj1 g w
                 using hseq_gw hseq_char by unfold_locales auto
 
               have hseq_gw': "hseq g w'"
                 using T.leg1_in_hom by auto
               interpret gw': two_composable_identity_arrows_of_spans C prj0 prj1 g w'
                 using hseq_gw' hseq_char by unfold_locales auto
 
               interpret rfw: three_composable_identity_arrows_of_spans C prj0 prj1 r f w ..
               interpret rfw: identity_arrow_of_spans C \<open>r \<star> f \<star> w\<close>
                 using rfw.composites_are_identities ide_char' by auto
               interpret rfw': three_composable_arrows_of_spans C prj0 prj1 r f w' ..
               interpret rfw': three_composable_identity_arrows_of_spans C prj0 prj1 r f w' ..
               interpret rfw': identity_arrow_of_spans C \<open>r \<star> f \<star> w'\<close>
                 using rfw'.composites_are_identities ide_char' by auto
 
               have \<rho>w: "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
                 using \<rho> hseq_gw by blast
               interpret \<rho>w: two_composable_arrows_of_spans C prj0 prj1 \<rho> w
                 using \<rho>w by unfold_locales auto
               have \<rho>w': "\<guillemotleft>\<rho> \<star> w' : g \<star> w' \<Rightarrow> (r \<star> f) \<star> w'\<guillemotright>"
                 using \<rho> hseq_gw' by blast
               interpret \<rho>w': two_composable_arrows_of_spans C prj0 prj1 \<rho> w'
                 using \<rho>w' by unfold_locales auto
 
               have arfw: "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
                 using fw.composable ide_f ide_r ide_w rf.composable by auto
               have arfw': "\<guillemotleft>\<a>[r, f, w'] : (r \<star> f) \<star> w' \<Rightarrow> r \<star> f \<star> w'\<guillemotright>"
                 using fw'.composable ide_f ide_r ide_w' rf.composable by auto
 
               have r\<theta>: "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
                 by fastforce
               interpret Dom_\<theta>: span_in_category C \<open>Dom \<theta>\<close>
                 using fw.dom.span_in_category_axioms
                 by (metis \<theta> arrow_of_spans_data.select_convs(2) in_homE dom_char)
               interpret Cod_\<theta>: span_in_category C \<open>Cod \<theta>\<close>
                 using \<theta> u.cod.span_in_category_axioms cod_char by auto
               interpret \<theta>: arrow_of_spans C \<theta>
                 using arr_char T.uw\<theta>.\<theta>_simps(1) by auto
               interpret r\<theta>: two_composable_arrows_of_spans C prj0 prj1 r \<theta>
                 using r\<theta> by unfold_locales auto
 
               have r\<theta>': "\<guillemotleft>r \<star> \<theta>' : r \<star> f \<star> w' \<Rightarrow> r \<star> u\<guillemotright>"
                 by fastforce
               interpret Dom_\<theta>': span_in_category C \<open>Dom \<theta>'\<close>
                 using fw'.dom.span_in_category_axioms
                 by (metis \<theta>' arrow_of_spans_data.select_convs(2) in_homE dom_char)
               interpret Cod_\<theta>': span_in_category C \<open>Cod \<theta>'\<close>
                 using \<theta>' u.cod.span_in_category_axioms cod_char by auto
               interpret \<theta>': arrow_of_spans C \<theta>'
                 using arr_char T.uw'\<theta>'.\<theta>_simps(1) by auto
               interpret r\<theta>': two_composable_arrows_of_spans C prj0 prj1 r \<theta>'
                 using r\<theta>' by unfold_locales auto
 
               have 7: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
                 using \<beta> \<rho>w' arfw' r\<theta>' by auto
               have 8: "\<guillemotleft>T.composite_cell w \<theta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
                 using \<rho>w arfw r\<theta> by auto
 
               interpret ru: two_composable_identity_arrows_of_spans C prj0 prj1 r u
                 using hseq_char by unfold_locales auto
 
               interpret Dom_\<beta>: span_in_category C \<open>Dom \<beta>\<close>
                 using \<beta> fw.dom.span_in_category_axioms arr_char
                 by (metis comp_arr_dom in_homE gw.cod.span_in_category_axioms seq_char)
               interpret Cod_\<beta>: span_in_category C \<open>Cod \<beta>\<close>
                 using \<beta> fw.cod.span_in_category_axioms arr_char
                 by (metis (no_types, lifting) comp_arr_dom ideD(2) in_homI
                     gw'.cod.span_in_category_axioms gw'.chine_is_identity hseq_gw' seqI'
                     seq_char ide_char)
               interpret \<beta>: arrow_of_spans C \<beta>
                 using \<beta> arr_char by auto
               text \<open>
                 CKS say: ``Take \<open>u\<close>, \<open>w\<close>, \<open>w'\<close>, \<open>\<theta>\<close>, \<open>\<theta>'\<close> as in \<open>T2\<close> and note that
                 \<open>fw = (w\<^sub>0, W, r\<^sub>0 w\<^sub>1)\<close>, \<open>gw = (w\<^sub>0, W, r\<^sub>1 w\<^sub>1)\<close>, \emph{etc}.
                 So \<open>\<beta>: W \<rightarrow> W'\<close> satisfies \<open>w\<^sub>0 = w\<^sub>0' \<beta>\<close>, \<open>r\<^sub>1 w\<^sub>1 = r\<^sub>1 w\<^sub>1' \<beta>\<close>.
                 But the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>.
                 So \<open>\<gamma> = \<beta> : w \<Rightarrow> w'\<close> is unique with \<open>\<beta> = g \<gamma>, \<theta> = \<theta>' (f \<gamma>).\<close>''
 
                 Once again, there is substantial punning in the proof sketch given by CKS.
                 We can express \<open>fw\<close> and \<open>gw\<close> almost in the form they indicate, but projections
                 are required.
               \<close>
               have cospan: "C.cospan ?R ?w1"
                 using hseq_char [of \<rho> w] src_def trg_def by auto
               have cospan': "C.cospan ?R ?w1'"
                 using hseq_char [of \<rho> w'] src_def trg_def by auto
               have fw: "f \<star> w = \<lparr>Chn = ?R \<down>\<down> ?w1,
                                  Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r0 \<cdot> ?p1\<rparr>,
                                  Cod = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r0 \<cdot> ?p1\<rparr>\<rparr>"
                 using ide_f hseq_char hcomp_def chine_hcomp_def fw.dom.apex_def cospan
                       fw.chine_eq_apex
                 by auto
               have gw: "g \<star> w = \<lparr>Chn = ?R \<down>\<down> ?w1,
                                  Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>,
                                  Cod = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>\<rparr>"
                 using hseq_gw hseq_char hcomp_def chine_hcomp_def gw.dom.apex_def cospan
                       gw.chine_eq_apex
                 by auto
               have fw': "f \<star> w' = \<lparr>Chn = ?R \<down>\<down> ?w1',
                                    Dom = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r0 \<cdot> ?p1'\<rparr>,
                                    Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r0 \<cdot> ?p1'\<rparr>\<rparr>"
                 using ide_f hseq_char hcomp_def chine_hcomp_def fw'.dom.apex_def cospan'
                       fw'.chine_eq_apex
                 by auto
               have gw': "g \<star> w' = \<lparr>Chn = ?R \<down>\<down> ?w1',
                                    Dom = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>,
                                    Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>\<rparr>"
                 using hseq_gw' hseq_char hcomp_def chine_hcomp_def gw'.dom.apex_def cospan'
                       gw'.chine_eq_apex
                 by auto
               text \<open>
                 Note that \<open>?p0\<close> and \<open>?p0'\<close> are only isomorphisms, not identities,
                 and we have \<open>?p1\<close> (which equals \<open>?w1 \<cdot> ?p0\<close>) and \<open>?p1'\<close> (which equals \<open>?w1' \<cdot> ?p0'\<close>)
                 in place of \<open>?w1\<close> and \<open>?w1'\<close>.
               \<close>
               text \<open>
                 The following diagram summarizes the
                 various given and defined arrows involved in the proof.
                 We have deviated slightly here from the nomenclature used in in CKS.
                 We prefer to use \<open>W\<close> and \<open>W'\<close> to denote the apexes of
                 \<open>w\<close> and \<open>w'\<close>, respectively.
                 We already have the expressions \<open>?R \<down>\<down> ?w1\<close> and \<open>?R \<down>\<down> ?w1'\<close> for the
                 apexes of \<open>fw\<close> and \<open>fw'\<close> (which are the same as the apexes of
                 \<open>gw\<close> and \<open>gw'\<close>, respectively) and we will not use any abbreviation for them.
               \<close>
               text \<open>
 $$
 \xymatrix{
   &&& X \\
   && W \ar[ur]^{w_0} \ar[dr]_{w_1} \ar@ {.>}[rr]^{\gamma}
   && W' \ar[ul]_{w_0'} \ar[dl]^{w_1'} && U \ar@/r10pt/[dddl]^{u_1} \ar@/u7pt/[ulll]_{u_0}\\
   & R\downarrow\downarrow w_1 \ar[ur]_{p_0} \ar[dr]^{p_1} \ar@/d15pt/[rrrr]_{\beta}
     \ar@/u100pt/[urrrrr]^{\theta}
   && R && R \downarrow\downarrow w_1' \ar[ul]^{p_0'} \ar[dl]^{p_1'} \ar[ur]_{\theta'} \\
   && R \ar@ {.>}[dr]_{\rho} \ar@/dl7pt/[ddr]_{R} \ar[ur]_{R} \ar[dl]_{r_1} \ar@ {<->}[rr]_{R}
   && R \ar[ul]^{R} \ar[dr]_{r_0} \\
   & B && r_0 \downarrow\downarrow r_0 \ar[d]^{k_1} \ar[ur]_{k_0} && A \\
   &&& R \ar@/dr10pt/[urr]_{r_0} \ar@/dl5pt/[ull]^{r_1}
 }
 $$
               \<close>
               have Chn_\<beta>: "\<guillemotleft>\<beta>.chine: ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
                 using gw gw' Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
               have \<beta>_eq: "\<beta> = \<lparr>Chn = \<beta>.chine,
                                Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>,
                                Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>\<rparr>"
                 using \<beta> gw gw' dom_char cod_char by auto
               have Dom_\<beta>_eq: "Dom \<beta> = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>"
                 using \<beta> gw gw' dom_char cod_char by auto
               have Cod_\<beta>_eq: "Cod \<beta> = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>"
                 using \<beta> gw gw' dom_char cod_char by auto
 
               have \<beta>0: "?w0 \<cdot> ?p0 = ?w0' \<cdot> ?p0' \<cdot> \<beta>.chine"
                 using Dom_\<beta>_eq Cod_\<beta>_eq \<beta>.leg0_commutes C.comp_assoc by simp
               have \<beta>1: "r1 \<cdot> ?p1 = r1 \<cdot> ?p1' \<cdot> \<beta>.chine"
                 using Dom_\<beta>_eq Cod_\<beta>_eq \<beta>.leg1_commutes C.comp_assoc by simp
 
               have Dom_\<theta>_0: "Dom_\<theta>.leg0 = ?w0 \<cdot> ?p0"
                 using arrI dom_char fw T.uw\<theta>.\<theta>_simps(4) by auto
               have Cod_\<theta>_0: "Cod_\<theta>.leg0 = ?u0"
                 using \<theta> cod_char by auto
               have Dom_\<theta>_1: "Dom_\<theta>.leg1 = r0 \<cdot> ?p1"
                 using arrI dom_char fw T.uw\<theta>.\<theta>_simps(4) by auto
               have Cod_\<theta>_1: "Cod_\<theta>.leg1 = ?u1"
                 using T.uw\<theta>.\<theta>_simps(5) cod_char by auto
               have Dom_\<theta>'_0: "Dom_\<theta>'.leg0 = ?w0' \<cdot> ?p0'"
                 using dom_char fw' T.uw'\<theta>'.\<theta>_simps(4) by auto
               have Cod_\<theta>'_0: "Cod_\<theta>'.leg0 = ?u0"
                 using T.uw'\<theta>'.\<theta>_simps(5) cod_char by auto
               have Dom_\<theta>'_1: "Dom_\<theta>'.leg1 = r0 \<cdot> ?p1'"
                 using dom_char fw' T.uw'\<theta>'.\<theta>_simps(4) by auto
               have Cod_\<theta>'_1: "Cod_\<theta>'.leg1 = ?u1"
                 using T.uw'\<theta>'.\<theta>_simps(5) cod_char by auto
               have Dom_\<rho>_0: "Dom_\<rho>.leg0 = ?R"
                 by simp
               have Dom_\<rho>_1: "Dom_\<rho>.leg1 = r1"
                 by simp
               have Cod_\<rho>_0: "Cod_\<rho>.leg0 = k0"
                 by simp
               have Cod_\<rho>_1: "Cod_\<rho>.leg1 = r1 \<cdot> k1"
                 by simp
 
               have Chn_r\<theta>: "\<guillemotleft>r\<theta>.chine : rfw.chine \<rightarrow>\<^sub>C ru.chine\<guillemotright>"
                 using r\<theta>.chine_composite_in_hom ru.chine_composite rfw.chine_composite
                       Cod_\<theta>_1 Dom_\<theta>_1 fw.leg1_composite
                 by auto
               have Chn_r\<theta>_eq: "r\<theta>.chine = \<langle>\<p>\<^sub>1[r0, r0 \<cdot> ?p1] \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1]\<rangle>"
                 using r\<theta>.chine_composite Cod_\<theta>_1 Dom_\<theta>_1 fw.leg1_composite C.comp_cod_arr
                 by (metis arrow_of_spans_data.simps(2) fw r.chine_eq_apex r.cod_simps(2)
                     rfw.prj_simps(10) rfw.prj_simps(16) span_data.simps(2))
 
               have r\<theta>_cod_apex_eq: "r\<theta>.cod.apex = r0 \<down>\<down> ?u1"
                 using Cod_\<theta>_1 r\<theta>.chine_composite_in_hom by auto
               hence r\<theta>'_cod_apex_eq: "r\<theta>'.cod.apex = r0 \<down>\<down> ?u1"
                 using Cod_\<theta>'_1 r\<theta>'.chine_composite_in_hom by auto
  
               have Chn_r\<theta>': "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C ru.chine\<guillemotright>"
                 using r\<theta>'.chine_composite_in_hom ru.chine_composite rfw'.chine_composite
                       Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite
                 by auto
               have Chn_r\<theta>'_eq: "r\<theta>'.chine =
                                 \<langle>\<p>\<^sub>1[r0, r0 \<cdot> ?p1'] \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']\<rangle>"
                 using r\<theta>'.chine_composite Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite C.comp_cod_arr
                 by (metis arrow_of_spans_data.simps(2) fw' r.chine_eq_apex r.cod_simps(2)
                     rfw'.prj_simps(10) rfw'.prj_simps(16) span_data.simps(2))
 
               have Chn_\<rho>w: "\<guillemotleft>\<rho>w.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C k0 \<down>\<down> ?w1\<guillemotright>"
                 using \<rho>w.chine_composite_in_hom by simp
               have Chn_\<rho>w_eq: "\<rho>w.chine = \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                 using \<rho>w.chine_composite C.comp_cod_arr ide_w
                 by (simp add: chine_hcomp_arr_ide hcomp_def)
               have Chn_\<rho>w': "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C k0 \<down>\<down> ?w1'\<guillemotright>"
                 using \<rho>w'.chine_composite_in_hom by simp
               have Chn_\<rho>w'_eq: "\<rho>w'.chine = \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> ?p0'\<rangle>"
                 using \<rho>w'.chine_composite C.comp_cod_arr ide_w' Dom_\<rho>_0 Cod_\<rho>_0
                 by (metis \<rho>w'.composite_is_arrow chine_hcomp_arr_ide chine_hcomp_def hseq_char
                     w'.cod_simps(3))
 
               text \<open>
                 The following are some collected commutativity properties that are used
                 subsequently.
               \<close>
               have "C.commutative_square r0 ?u1 ?p1 \<theta>.chine"
                 using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1 Cod_\<theta>_1 \<theta>.leg1_commutes
                 by (intro C.commutative_squareI) auto
               have "C.commutative_square r0 ?u1 (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
                 by (metis (mono_tags, lifting) C.commutative_square_comp_arr C.dom_comp
                     C.seqE Cod_\<theta>'_1 Dom_\<beta>.leg_simps(3) Dom_\<beta>_eq Dom_\<theta>'.leg_simps(3)
                     Dom_\<theta>'_1 \<beta>1 \<theta>'.leg1_commutes C.commutative_squareI
                     ru.legs_form_cospan(1) span_data.simps(2))
               have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
                 using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1
                       C.comp_assoc C.pullback_commutes' r\<theta>.legs_form_cospan(1)
                 apply (intro C.commutative_squareI)
                    apply auto
                 by (metis C.comp_assoc Cod_\<theta>_1 \<theta>.leg1_commutes)
               hence "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
                 using fw.leg1_composite by auto
               have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1'] (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])"
                 using C.tuple_is_extensional Chn_r\<theta>'_eq r\<theta>'.chine_simps(1) fw' by force
               have "C.commutative_square ra ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0"
                 using C.pullback_commutes' gw.legs_form_cospan(1) rfw.prj_simps(2) C.comp_assoc
                       C.comp_cod_arr
                 by (intro C.commutative_squareI) auto
               have "C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0"
                 by (metis (no_types, lifting) C.commutative_square_comp_arr C.comp_assoc
                     C.pullback_commutes select_convs(2) rfw'.cospan_\<nu>\<pi>
                     rfw'.prj_chine_assoc(2) rfw'.prj_chine_assoc(3) rfw'.prj_simps(2)
                     span_data.select_convs(1))
               have "C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1 \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
               proof -
                 have "C.arr rfw.chine_assoc"
                   by (metis C.seqE rfw.prj_chine_assoc(1) rfw.prj_simps(1))
                 thus ?thesis
                   using C.tuple_is_extensional rfw.chine_assoc_def by fastforce
               qed
               have "C.commutative_square r0 (r0 \<cdot> ?p1') rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>"
                 by (metis (no_types, lifting) C.not_arr_null C.seqE C.tuple_is_extensional
                     arrow_of_spans_data.select_convs(2) rfw'.chine_assoc_def
                     rfw'.prj_chine_assoc(1) rfw'.prj_simps(1) span_data.select_convs(1-2))
               have "C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0"
                 using C.tuple_is_extensional Chn_\<rho>w_eq \<rho>w.chine_simps(1) by fastforce
               have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')"
                 using C.tuple_is_extensional \<rho>w'.chine_composite \<rho>w'.chine_simps(1) by force
               have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'"
                 using C.tuple_is_extensional Chn_\<rho>w'_eq \<rho>w'.chine_simps(1) by force
               text \<open>
                 Now, derive the consequences of the equation:
                 \[
                   \<open>(r \<star> \<theta>) \<bullet> \<a>[r, ?f, w] \<bullet> (?\<rho> \<star> w) = (r \<star> \<theta>') \<bullet> \<a>[r, ?f, w'] \<bullet> (?\<rho> \<star> w') \<bullet> \<beta>\<close>
                 \]
                 The strategy is to expand and simplify the left and right hand side to tuple form,
                 then compose with projections and equate corresponding components.
 
                 We first work on the right-hand side.
               \<close>
               have R: "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
                        \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
               proof -
                 have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
                       r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                 proof -
                   have 1: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
                     using \<beta> \<rho>w' arfw' r\<theta>' by auto
                   have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) = Chn (T.composite_cell w' \<theta>') \<cdot> \<beta>.chine"
                     using 1 Chn_vcomp by blast
                   also have "... = (r\<theta>'.chine \<cdot> Chn (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))) \<cdot> \<beta>.chine"
                   proof -
                     have "seq (r \<star> \<theta>') (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))"
                       using 1 by blast
                     thus ?thesis
                       using 1 Chn_vcomp by presburger
                   qed
                   also have "... = (r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                   proof -
                     have "seq \<a>[r, f, w'] (\<rho> \<star> w')"
                       using 1 by blast
                     thus ?thesis
                       using 1 Chn_vcomp by presburger
                   qed
                   finally show ?thesis
                     using C.comp_assoc by auto
                 qed
                 also have "... = \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
                 proof -
                   let ?LHS = "r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                   let ?RHS = "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
          
                   have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
                   proof (intro C.comp_in_homI)
                     show "\<guillemotleft>\<beta>.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
                       using Chn_\<beta> by simp
                     show "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
                       using Chn_\<rho>w' by simp
                     show "\<guillemotleft>Chn \<a>[r, f, w'] : Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C rfw'.chine\<guillemotright>"
                       using arfw'
                       by (metis (no_types, lifting) Chn_in_hom Cod_\<rho>_0
                           arrow_of_spans_data.simps(2) rf rf.leg0_composite rfw'.chine_composite(1)
                           span_data.select_convs(1) w'.cod_simps(3))
                     show "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
                       using Chn_r\<theta>' by auto
                   qed
                   have 2: "C.commutative_square r0 ?u1
                              (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
                     by fact
                   have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
                     using 2 Chn_\<beta> r\<theta>'_cod_apex_eq
                           C.tuple_in_hom [of r0 ?u1 "?p1' \<cdot> \<beta>.chine" "\<theta>'.chine \<cdot> \<beta>.chine"]
                     by fastforce
 
                   show ?thesis
                   proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
                     show "C.cospan r0 ?u1"
                       using ru.legs_form_cospan(1) by blast
                     show "C.seq ru.prj\<^sub>1 ?LHS"
                       using LHS r\<theta>'_cod_apex_eq by auto
                     show "C.seq ru.prj\<^sub>1 ?RHS"
                       using RHS r\<theta>'_cod_apex_eq by auto
                     show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>0 \<cdot> ?LHS =
                             (ru.prj\<^sub>0 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = ((\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']) \<cdot> Chn \<a>[r, f, w']) \<cdot>
                                          \<rho>w'.chine \<cdot> \<beta>.chine"
                         using Chn_r\<theta>'_eq C.comp_assoc fw'
                               \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
                                   (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
                         by simp
                       also have "... = \<theta>'.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1'] \<cdot> Chn \<a>[r, f, w']) \<cdot>
                                          \<rho>w'.chine \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = \<theta>'.chine \<cdot> (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine) \<cdot>
                                          \<beta>.chine"
                         using ide_f hseq_rf hseq_char \<alpha>_ide C.comp_assoc
                               rfw'.chine_assoc_def fw'.leg1_composite C.prj_tuple(1)
                               \<open>C.commutative_square r0 (r0 \<cdot> ?p1')
                                  rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>\<close>
                         by simp
                       also have "... = \<theta>'.chine \<cdot> \<beta>.chine"
                       proof -
                         have "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine = gw'.apex"
                         proof (intro C.prj_joint_monic
                                        [of ?R ?w1' "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine"
                                            gw'.apex])
                           show "C.cospan ?R ?w1'"
                             using fw'.legs_form_cospan(1) by simp
                           show "C.seq ?p1' (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine)"
                           proof (intro C.seqI' C.comp_in_homI)
                             show "\<guillemotleft>\<rho>w'.chine : Dom_\<rho>.leg0 \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
                               using \<rho>w'.chine_composite_in_hom by simp
                             show "\<guillemotleft>\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, w'.leg1\<rbrakk> rfw'.Prj\<^sub>0\<rangle> :
                                       Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C ?R \<down>\<down> w'.leg1\<guillemotright>"
                               using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close>
                                     C.tuple_in_hom [of ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0]
                                     rf rf.leg0_composite
                               by auto
                             show "\<guillemotleft>?p1' : ?R \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C f.apex\<guillemotright>"
                               using fw'.prj_in_hom(1) by auto
                           qed
                           show "C.seq ?p1' gw'.apex"
                             using gw'.dom.apex_def gw'.leg0_composite fw'.prj_in_hom by auto
                           show "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                          ?p0' \<cdot> gw'.apex"
                           proof -
                             have "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                   (?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw'.Prj\<^sub>0 \<cdot> \<rho>w'.chine"
                               using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by auto
                             also have
                               "... = \<p>\<^sub>0[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
                               using \<rho>w'.chine_composite Dom_\<rho>_0 Cod_\<rho>_0 C.comp_cod_arr by simp
                             also have "... = w'.chine \<cdot> ?p0'"
                               using \<open>C.commutative_square k0 ?w1'
                                       (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
                               by simp
                             also have "... = ?p0' \<cdot> gw'.apex"
                               using cospan C.comp_cod_arr C.comp_arr_dom gw'.chine_is_identity
                                     gw'.chine_eq_apex gw'.chine_composite fw'.prj_in_hom
                               by auto
                             finally show ?thesis by simp
                           qed
                           show "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                          ?p1' \<cdot> gw'.apex"
                           proof -
                             have "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                   (?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw'.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w'.chine"
                               using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by simp
                             also have
                               "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
                               using \<rho>w'.chine_composite Cod_\<rho>_0 C.comp_assoc C.comp_cod_arr
                               by simp
                             also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1'"
                               using \<open>C.commutative_square k0 ?w1'
                                       (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
                               by simp
                             also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1'"
                               using C.comp_assoc by metis
                             also have "... = ?p1'"
                               using \<rho>.leg0_commutes C.comp_cod_arr cospan' by simp
                             also have "... = ?p1' \<cdot> gw'.apex"
                               using C.comp_arr_dom cospan' gw'.chine_eq_apex gw'.chine_composite
                               by simp
                             finally show ?thesis by simp
                           qed
                         qed
                         thus ?thesis
                           using Chn_\<beta> C.comp_cod_arr gw'.apex_composite by auto
                       qed
                       also have "... = \<p>\<^sub>0[r0, ?u1] \<cdot> ?RHS"
                         using RHS 2 C.prj_tuple [of r0 ?u1] by simp
                       finally show ?thesis by simp
                     qed
                     show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>1 \<cdot> ?LHS =
                             (ru.prj\<^sub>1 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = \<p>\<^sub>1[r0, fw'.leg1] \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using Chn_r\<theta>' Chn_r\<theta>'_eq fw'
                               \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
                                  (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
                         by simp
                       also have "... = (rfw'.Prj\<^sub>1 \<cdot> rfw'.chine_assoc) \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using ide_f ide_w' hseq_rf hseq_char \<alpha>_ide fw'.leg1_composite C.comp_assoc
                         by auto
                       also have "... = (rfw'.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                         using rfw'.prj_chine_assoc C.comp_assoc by simp
                       also have "... = ((k1 \<cdot> \<p>\<^sub>1[k0, ?w1']) \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                         using C.comp_cod_arr by simp
                       also have "... = (k1 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = (k1 \<cdot> \<rho>.chine \<cdot> ?p1') \<cdot> \<beta>.chine"
                         using Chn_\<rho>w'_eq Dom_\<rho>_0 Cod_\<rho>_0
                               \<open>C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'\<close>
                         by simp
                       also have "... = (k1 \<cdot> \<rho>.chine) \<cdot> ?p1' \<cdot> \<beta>.chine"
                         using C.comp_assoc by metis
                       also have "... = (?R \<cdot> ?p1') \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = ?p1' \<cdot> \<beta>.chine"
                         using C.comp_cod_arr C.prj1_in_hom [of ?R ?w1'] cospan' by simp
                      also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
                         using RHS 2 by simp
                       finally show ?thesis by simp
                     qed
                   qed
                 qed
                 finally show ?thesis by simp
               qed
 
               text \<open>
                 Now we work on the left-hand side.
               \<close>
               have L: "Chn (T.composite_cell w \<theta>) = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
               proof -
                 have "Chn (T.composite_cell w \<theta>) = r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                   using Chn_vcomp arfw C.comp_assoc by auto
                 moreover have "... = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
                 proof -
                   let ?LHS = "r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                   let ?RHS = "\<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
                   have 2: "C.commutative_square r0 ?u1 ?p1 \<theta>.chine" by fact
                   have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
                     using Chn_r\<theta> Chn_\<rho>w rfw.chine_assoc_in_hom
                     by (metis (no_types, lifting) "8" Chn_in_hom Dom_\<rho>_0
                         arrow_of_spans_data.simps(2) calculation gw.chine_composite
                         r\<theta>_cod_apex_eq ru.chine_composite)
                   have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
                     using 2 C.tuple_in_hom [of r0 ?u1 "?p1" \<theta>.chine] cospan r\<theta>_cod_apex_eq
                     by simp
                   show ?thesis
                   proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
                     show "C.cospan r0 ?u1"
                       using ru.legs_form_cospan(1) by blast
                     show "C.seq ru.prj\<^sub>1 ?LHS"
                       using LHS r\<theta>_cod_apex_eq by auto
                     show "C.seq ru.prj\<^sub>1 ?RHS"
                       using RHS r\<theta>_cod_apex_eq by auto
                     show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>0 \<cdot> ?LHS = (ru.prj\<^sub>0 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                         using C.comp_assoc by simp
                       also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, f.leg1 \<cdot> fw.prj\<^sub>1]) \<cdot>
                                          Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                         using Chn_r\<theta>_eq Dom_\<theta>_1 Cod_\<theta>_1 fw.leg1_composite
                               \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1]
                                  (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])\<close>
                         by simp
                       also have "... = \<theta>.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
                         using C.comp_assoc by simp
                       also have "... = \<theta>.chine \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
                       proof -
                         have "Chn \<a>[r, f, w] = rfw.chine_assoc"
                           using ide_f ide_w hseq_rf hseq_char \<alpha>_ide by auto
                         moreover have "\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> rfw.chine_assoc =
                                        \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
                           using rfw.chine_assoc_def
                                 \<open>C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1
                                    \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>\<close>
                           by simp
                         ultimately show ?thesis by simp
                       qed
                       also have "... = \<theta>.chine \<cdot> (?R \<down>\<down> ?w1)"
                       proof -
                         have "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine = ?R \<down>\<down> ?w1"
                         proof (intro C.prj_joint_monic
                                        [of ?R ?w1 "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
                                            "?R \<down>\<down> ?w1"])
                           show "C.cospan ?R ?w1" by fact
                           show "C.seq ?p1 (\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine)"
                           proof -
                             have "C.seq rfw.Prj\<^sub>0\<^sub>1 \<rho>w.chine"
                               by (meson C.seqI' Chn_in_hom \<rho>w rfw.prj_in_hom(2)
                                   \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>)
                             thus ?thesis
                               using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>
                               by (metis (no_types) C.comp_assoc C.prj_tuple(2))
                           qed
                           show "C.seq ?p1 (?R \<down>\<down> ?w1)"
                             using gw.dom.apex_def gw.leg0_composite gw.prj_in_hom by auto
                           show "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                 ?p0 \<cdot> (?R \<down>\<down> ?w1)"
                           proof -
                             have "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                   (?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw.Prj\<^sub>0 \<cdot> \<rho>w.chine"
                               using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
                             also have "... = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                               using Chn_\<rho>w_eq C.comp_cod_arr by simp
                             also have "... = ?p0"
                               using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close>
                                     C.prj_tuple(1)
                               by blast
                             also have "... = ?p0 \<cdot> (?R \<down>\<down> ?w1)"
                               using C.comp_arr_dom gw.chine_eq_apex gw.chine_is_identity
                               by (metis C.arr_dom_iff_arr C.pbdom_def Dom_g gw.chine_composite
                                   gw.chine_simps(1) span_data.select_convs(1))
                             finally show ?thesis by simp
                           qed
                           show "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                 ?p1 \<cdot> (?R \<down>\<down> ?w1)"
                           proof -
                             have "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                   (?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w.chine"
                               using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
                             also have "... = (k0 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                               using Chn_\<rho>w_eq C.comp_cod_arr by simp
                             also have "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                               using C.comp_assoc by simp
                             also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1"
                               using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close> by simp
                             also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1"
                               using C.comp_assoc by metis
                             also have "... = ?p1 \<cdot> (?R \<down>\<down> ?w1)"
                               using C.comp_arr_dom C.comp_cod_arr cospan by simp
                             finally show ?thesis by blast
                           qed
                         qed
                         thus ?thesis by simp
                       qed
                       also have "... = \<theta>.chine"
                         using C.comp_arr_dom \<theta>.chine_in_hom gw.chine_eq_apex gw.chine_is_identity
                               Dom_\<theta>_0 Cod_\<theta>_0 Dom_\<theta>.apex_def Cod_\<theta>.apex_def
                         by (metis Dom_g \<theta>.chine_simps(1) \<theta>.chine_simps(2) gw.chine_composite
                             gw.dom.apex_def gw.leg0_composite span_data.select_convs(1))
                       also have "... = ru.prj\<^sub>0 \<cdot> ?RHS"
                         using 2 by simp
                       finally show ?thesis by blast
                     qed
                     show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>1 \<cdot> ?LHS = (ru.prj\<^sub>1 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                         using C.comp_assoc by simp
                       also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?p1]) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                       proof -
                         have "r\<theta>.chine \<noteq> C.null \<Longrightarrow>
                                 \<p>\<^sub>1[r.cod.leg0, Cod_\<theta>.leg1] \<cdot> r\<theta>.chine =
                                 r.chine \<cdot> \<p>\<^sub>1[r0, Dom_\<theta>.leg1]"
                           by (metis (lifting) C.prj_tuple(2) C.tuple_is_extensional r.cod_simps(2)
                               r\<theta>.chine_composite)
                         thus ?thesis
                           using Cod_\<theta>_1 Dom_\<theta>_1 r\<theta>.chine_simps(1) fw by fastforce
                       qed
                       also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
                         using C.comp_assoc fw.leg1_composite by simp
                       also have "... = r.chine \<cdot> rfw.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w.chine"
                         using ide_f ide_w hseq_rf hseq_char \<alpha>_ide
                               rfw.prj_chine_assoc(1)
                         by auto
                       also have "... = r.chine \<cdot> k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<rho>w.chine"
                         using C.comp_cod_arr C.comp_assoc by simp
                       also have "... = r.chine \<cdot> k1 \<cdot> \<rho>.chine \<cdot> \<p>\<^sub>1[Dom_\<rho>.leg0, ?w1]"
                         using Chn_\<rho>w_eq
                               \<open>C.commutative_square k0 ?w1
                                 (\<rho>.chine \<cdot> \<p>\<^sub>1[ra, w.leg1]) \<p>\<^sub>0[ra, w.leg1]\<close>
                         by auto
                       also have "... = r.chine \<cdot> (k1 \<cdot> \<rho>.chine) \<cdot> ?p1"
                         using C.comp_assoc Dom_\<rho>_0 by metis
                       also have "... = r.chine \<cdot> ra \<cdot> ?p1"
                         by simp
                       also have "... = r.chine \<cdot> ?p1"
                         using C.comp_cod_arr
                         by (metis C.comp_assoc r.cod_simps(1) r.chine_eq_apex r.chine_simps(1)
                             r.chine_simps(3))
                       also have "... = ?p1"
                         using C.comp_cod_arr r.chine_eq_apex r.chine_is_identity
                         by (metis 2 C.commutative_squareE r.dom.apex_def)
                       also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
                         using 2 by simp
                       finally show ?thesis by simp
                     qed
                   qed
                 qed
                 ultimately show ?thesis
                   by simp
               qed
               text \<open>
                 This is the main point: the equation E boils down to the following:
                 \[
                    \<open>?p1' \<cdot> \<beta>.chine = ?p1 \<and> \<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine\<close>
                 \]
                 The first equation gets us close to what we need, but we still need
                 \<open>?p1 \<cdot> C.inv ?p0 = ?w1\<close>, which follows from the fact that ?p0 is the
                 pullback of ?R.
               \<close>
               have *: "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle> = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
                 using L R E by simp
               have **: "?p1' \<cdot> \<beta>.chine = ?p1"
                 by (metis "*" C.in_homE C.not_arr_null C.prj_tuple(2) C.tuple_in_hom
                     C.tuple_is_extensional
                     \<open>C.commutative_square r0 u.leg1
                        (\<p>\<^sub>1[ra, w'.leg1] \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>)
               have ***: "\<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine"
                 by (metis "*" C.prj_tuple(1) \<open>C.commutative_square r0 ?u1
                     (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
                     \<open>C.commutative_square r0 ?u1 ?p1 \<theta>.chine\<close>)
               text \<open>
                 CKS say to take \<open>\<gamma> = \<beta>\<close>, but obviously this cannot work as
                 literally described, because \<open>\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>\<close>, whereas we must have
                 \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>.  Instead, we have to define \<open>\<gamma>\<close> by transporting \<open>\<beta>\<close> along the
                 projections from \<open>?R \<down>\<down> ?w1\<close> to \<open>?W\<close> and \<open>?R \<down>\<down> ?w1'\<close> to \<open>?W'\<close>.
                 These are isomorphisms by virtue of their being pullbacks of identities,
                 but they are not themselves necessarily identities.
                 Specifically, we take \<open>Chn \<gamma> = ?p0' \<cdot> Chn \<beta> \<cdot> C.inv ?p0\<close>.
               \<close>
               let ?\<gamma> = "\<lparr>Chn = ?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0, Dom = Dom w, Cod = Cod w'\<rparr>"
               interpret Dom_\<gamma>: span_in_category C \<open>Dom ?\<gamma>\<close>
                 using w.dom.span_in_category_axioms by simp
               interpret Cod_\<gamma>: span_in_category C \<open>Cod ?\<gamma>\<close>
                 using w'.cod.span_in_category_axioms by simp
               text \<open>
                 It has to be shown that \<open>\<gamma>\<close> is an arrow of spans.
               \<close>
               interpret \<gamma>: arrow_of_spans C ?\<gamma>
               proof
                 show "\<guillemotleft>Chn ?\<gamma> : Dom_\<gamma>.apex \<rightarrow>\<^sub>C Cod_\<gamma>.apex\<guillemotright>"
                 proof -
                   have "\<guillemotleft>Chn \<beta>: gw.apex \<rightarrow>\<^sub>C gw'.apex\<guillemotright>"
                     using Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
                   moreover have "\<guillemotleft>?p0' : gw'.apex \<rightarrow>\<^sub>C w'.apex\<guillemotright>"
                     using cospan' hseq_gw' hseq_char hcomp_def gw'.dom.apex_def w'.dom.apex_def
                     by auto
                   moreover have "\<guillemotleft>C.inv ?p0 : w.apex \<rightarrow>\<^sub>C gw.apex\<guillemotright>"
                     using cospan hseq_gw hseq_char hcomp_def gw.dom.apex_def w.dom.apex_def
                           C.iso_pullback_ide
                     by auto
                   ultimately show ?thesis
                     using Dom_\<gamma>.apex_def Cod_\<gamma>.apex_def by auto
                 qed
                 text \<open>
                   The commutativity property for the ``input leg'' follows directly from that
                   for \<open>\<beta>\<close>.
                 \<close>
                 show "Cod_\<gamma>.leg0 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg0"
                   using C.comp_assoc C.comp_arr_dom cospan C.iso_pullback_ide C.comp_arr_inv'
                   by (metis C.invert_side_of_triangle(2) Dom_\<beta>.leg_simps(1) Dom_\<beta>_eq \<beta>0
                       arrow_of_spans_data.select_convs(1,3) arrow_of_spans_data.simps(2)
                       r.dom.ide_apex span_data.select_convs(1) w'.cod_simps(2))
                 text \<open>
                   The commutativity property for the ``output leg'' is a bit more subtle.
                 \<close>
                 show "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg1"
                 proof -
                   have "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = ((?w1' \<cdot> ?p0') \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
                     using C.comp_assoc by simp
                   also have "... = ((?R \<cdot> ?p1') \<cdot> Chn \<beta>) \<cdot> C.inv ?p0"
                     using cospan' C.pullback_commutes [of ?R ?w1'] by auto
                   also have "... = (?p1' \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
                     using cospan' C.comp_cod_arr by simp
                   also have "... = ?p1 \<cdot> C.inv ?p0"
                     using ** by simp
                   also have "... = ?w1"
                   text \<open>
                      Sledgehammer found this at a time when I was still struggling to
                      understand what was going on.
                   \<close>
                     by (metis C.comp_cod_arr C.invert_side_of_triangle(2) C.iso_pullback_ide
                         C.prj1_simps(1,3) C.pullback_commutes' cospan r.dom.ide_apex
                         r.chine_eq_apex r.chine_simps(2))
                   also have "... = Dom_\<gamma>.leg1" by auto
                   finally show ?thesis by simp
                 qed
               qed
               text \<open>
                 What remains to be shown is that \<open>\<gamma>\<close> is unique with the properties asserted
                 by \<open>T2\<close>; \emph{i.e.} \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)\<close>.
                 CKS' assertion that the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>
                 does not really seem to be true.  The reason \<open>\<gamma>\<close> is unique is because it is
                 obtained by transporting \<open>\<beta>\<close> along isomorphisms.
               \<close>
               have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright>"
                 using \<gamma>.arrow_of_spans_axioms arr_char dom_char cod_char by auto
               have hseq_f\<gamma>: "hseq f ?\<gamma>"
                 using \<gamma> src_def trg_def arrI fw.composable rf.are_arrows(2) by auto
               have hseq_g\<gamma>: "hseq g ?\<gamma>"
                 using \<gamma> src_def trg_def fw.composable gw.are_arrows(1) src_f by auto
               interpret f\<gamma>: two_composable_arrows_of_spans C prj0 prj1 f ?\<gamma>
                 using hseq_f\<gamma> hseq_char by (unfold_locales, simp)
               interpret f\<gamma>: arrow_of_spans C \<open>f \<star> ?\<gamma>\<close>
                 using f\<gamma>.composite_is_arrow arr_char by simp
               interpret g\<gamma>: two_composable_arrows_of_spans C prj0 prj1 g ?\<gamma>
                 using hseq_g\<gamma> hseq_char by (unfold_locales, simp)
               interpret g\<gamma>: arrow_of_spans C \<open>g \<star> ?\<gamma>\<close>
                 using g\<gamma>.composite_is_arrow arr_char by simp
               have Chn_g\<gamma>: "Chn (g \<star> ?\<gamma>) = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> \<beta>.chine\<rangle>"
               proof -
                 have "Chn (g \<star> ?\<gamma>) = \<langle>?R \<cdot> ?p1 \<lbrakk>?R, ?w1'\<rbrakk> (?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0\<rangle>"
                     using g\<gamma>.chine_composite by simp
                 also have "... = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> (?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0\<rangle>"
                   using C.comp_cod_arr cospan by simp
                 also have "... = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> \<beta>.chine\<rangle>"
                 proof -
                   have "(?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0 = ?p0' \<cdot> \<beta>.chine"
                     using C.comp_assoc C.iso_pullback_ide [of ?R ?w1] C.comp_inv_arr
                           C.comp_arr_dom Chn_\<beta>
                     by (metis C.comp_inv_arr' C.in_homE C.pbdom_def cospan r.dom.ide_apex)
                   thus ?thesis by simp
                 qed
                 ultimately show ?thesis by simp
               qed
               have Chn_\<beta>_eq: "\<beta>.chine = Chn (g \<star> ?\<gamma>)"
                 by (metis "**" C.span_prj C.tuple_prj Chn_g\<gamma> cospan cospan')
               have \<beta>_eq_g\<gamma>: "\<beta> = g \<star> ?\<gamma>"
               proof (intro arr_eqI)
                 show "par \<beta> (g \<star> ?\<gamma>)"
                 proof -
                   have "\<guillemotleft>g \<star> ?\<gamma> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
                     using ide_g \<gamma> T.leg1_simps(3)
                     by (intro hcomp_in_vhom, auto)
                   thus ?thesis
                     using \<beta> by (elim in_homE, auto)
                 qed
                 show "\<beta>.chine = Chn (g \<star> ?\<gamma>)"
                   using Chn_\<beta>_eq by simp
               qed
               moreover have "\<theta> = \<theta>' \<bullet> (f \<star> ?\<gamma>)"
               proof (intro arr_eqI)
                 have f\<gamma>: "\<guillemotleft>f \<star> ?\<gamma> : f \<star> w \<Rightarrow> f \<star> w'\<guillemotright>"
                   using \<gamma> ide_f by auto
                 show par: "par \<theta> (\<theta>' \<bullet> (f \<star> ?\<gamma>))"
                   using \<theta> \<theta>' f\<gamma> by (elim in_homE, auto)
                 show "\<theta>.chine = Chn (\<theta>' \<bullet> (f \<star> ?\<gamma>))"
                   using par "***" Chn_vcomp calculation f\<gamma>.chine_composite g\<gamma>.chine_composite
                   by auto
               qed
               ultimately show 2: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> ?\<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> ?\<gamma>)"
                 using \<gamma> by simp
               show "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>') \<Longrightarrow> \<gamma>' = ?\<gamma>"
               proof -
                 fix \<gamma>'
                 assume 1: "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>')"
                 interpret \<gamma>': arrow_of_spans C \<gamma>'
                   using 1 arr_char by auto
                 have hseq_g\<gamma>': \<open>hseq g \<gamma>'\<close>
                   using 1 \<beta> by auto
                 interpret g\<gamma>': two_composable_arrows_of_spans C prj0 prj1 g \<gamma>'
                   using hseq_g\<gamma>' hseq_char by unfold_locales auto
                 interpret g\<gamma>': arrow_of_spans C \<open>g \<star> \<gamma>'\<close>
                   using g\<gamma>'.composite_is_arrow arr_char by simp
                 show "\<gamma>' = ?\<gamma>"
                 proof (intro arr_eqI)
                   show par: "par \<gamma>' ?\<gamma>"
                     using 1 \<gamma> by fastforce
                   show "\<gamma>'.chine = \<gamma>.chine"
                   proof -
                     have "C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)"
                     proof
                       show "C.cospan ?R ?w1'" by fact
                       show 3: "C.span (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)"
                       proof (intro conjI)
                         show "C.seq g.chine ?p1"
                           using cospan by auto
                         show "C.seq \<gamma>'.chine ?p0"
                           using cospan 2 par arrow_of_spans_data.simps(1)
                                 dom_char in_homE w.chine_eq_apex
                           by auto
                         thus "C.dom (g.chine \<cdot> ?p1) = C.dom (\<gamma>'.chine \<cdot> ?p0)"
                           using g.chine_eq_apex cospan by simp
                       qed
                       show "C.dom ra = C.cod (g.chine \<cdot> ?p1)"
                         using cospan by auto
                       show "?R \<cdot> g.chine \<cdot> ?p1 = ?w1' \<cdot> \<gamma>'.chine \<cdot> ?p0"
                       proof -
                         have "?w1' \<cdot> \<gamma>'.chine \<cdot> ?p0 = (?w1' \<cdot> \<gamma>'.chine) \<cdot> ?p0"
                           using C.comp_assoc by simp
                         moreover have "... = ?w1 \<cdot> ?p0"
                           using 1 \<gamma>'.leg1_commutes dom_char cod_char by auto
                         also have "... = ?R \<cdot> ?p1"
                           using cospan C.pullback_commutes [of ra ?w1] by auto
                         also have "... = ?R \<cdot> g.chine \<cdot> ?p1"
                           using 3 C.comp_cod_arr g.chine_is_identity g.chine_eq_apex g.dom.apex_def
                           by auto
                         finally show ?thesis by auto
                       qed
                     qed
                     have "C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)"
                     proof
                       show "C.cospan ?R ?w1'" by fact
                       show 3: "C.span (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)"
                         using cospan \<gamma>.chine_in_hom by auto
                       show "C.dom ?R = C.cod (g.chine \<cdot> ?p1)"
                         using cospan by auto
                       show "?R \<cdot> g.chine \<cdot> ?p1 = ?w1' \<cdot> \<gamma>.chine \<cdot> ?p0"
                       proof -
                         have "?w1' \<cdot> \<gamma>.chine \<cdot> ?p0 = (?w1' \<cdot> \<gamma>.chine) \<cdot> ?p0"
                           using C.comp_assoc by simp
                         moreover have "... = ?w1 \<cdot> ?p0"
                           using 1 \<gamma>.leg1_commutes dom_char cod_char by auto
                         also have "... = ?R \<cdot> ?p1"
                           using cospan C.pullback_commutes [of ra ?w1] by auto
                         also have "... = ?R \<cdot> g.chine \<cdot> ?p1"
                           using 3 C.comp_cod_arr g.chine_is_identity g.chine_eq_apex g.dom.apex_def
                           by auto
                         finally show ?thesis by auto
                       qed
                     qed
                     have "\<gamma>'.chine \<cdot> ?p0 = \<gamma>.chine \<cdot> ?p0"
                     proof -
                       have "\<gamma>'.chine \<cdot> ?p0 = ?p0' \<cdot> g\<gamma>'.chine"
                         using 1 dom_char cod_char g\<gamma>'.chine_composite
                               \<open>C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)\<close>
                         by auto
                       also have "... = ?p0' \<cdot> \<beta>.chine"
                         using 1 by simp
                       also have "... = ?p0' \<cdot> g\<gamma>.chine"
                         using Chn_\<beta>_eq by simp
                       also have "... = \<gamma>.chine \<cdot> ?p0"
                         using g\<gamma>.chine_composite
                               \<open>C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)\<close>
                         by simp
                       finally show ?thesis by simp
                     qed
                     thus ?thesis
                       using C.iso_pullback_ide C.iso_is_retraction C.retraction_is_epi
                             C.epiE [of "?p0" \<gamma>'.chine \<gamma>.chine] cospan \<gamma>.chine_in_hom
                             \<gamma>'.chine_in_hom
                       by auto
                   qed
                 qed
               qed
             qed
           qed
         qed
       qed
     qed
 
   end
 
   context span_bicategory
   begin
 
     interpretation chosen_right_adjoints vcomp hcomp assoc unit src trg ..
     notation some_right_adjoint  ("_\<^sup>*" [1000] 1000)  (* TODO: Why is this needed? *)
     notation isomorphic  (infix "\<cong>" 50)
 
     text \<open>
       \<open>Span(C)\<close> is a bicategory of spans.
     \<close>
 
     lemma is_bicategory_of_spans:
     shows "bicategory_of_spans vcomp hcomp assoc unit src trg"
     proof
       text \<open>
         Every 1-cell \<open>r\<close> is isomorphic to the composition of a map and the right adjoint
         of a map.  The proof is to obtain a tabulation of \<open>r\<close> as a span of maps \<open>(f, g)\<close>
         and then observe that \<open>r\<close> is isomorphic to \<open>g \<star> f\<^sup>*\<close>.
       \<close>
       show "\<And>r. ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> r \<cong> g \<star> f\<^sup>*"
       proof -
         fix r
         assume r: "ide r"
         interpret r: identity_arrow_of_spans C r
           using r ide_char' by auto
         interpret r: identity_arrow_in_span_bicategory C prj0 prj1 r ..
         have \<rho>: "tabulation (\<bullet>) (\<star>) assoc unit src trg r r.\<rho> r.f r.g \<and>
                  is_left_adjoint r.f \<and> is_left_adjoint r.g"
           using r r.has_tabulation by blast
         interpret \<rho>: tabulation vcomp hcomp assoc unit src trg r r.\<rho> r.f r.g
           using \<rho> by fast
         have 1: "r \<cong> r.g \<star> r.f\<^sup>*"
           using \<rho> \<rho>.yields_isomorphic_representation' \<rho>.T0.is_map
                 left_adjoint_extends_to_adjoint_pair
                 isomorphic_def [of "r.g \<star> r.f\<^sup>*" r] isomorphic_symmetric
           by auto
         thus "\<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> r \<cong> g \<star> f\<^sup>*"
           using \<rho> by blast
       qed
       text \<open>
         Every span of maps extends to a tabulation.
       \<close>
       show "\<And>f g. \<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk> \<Longrightarrow>
                    \<exists>r \<rho>. tabulation (\<bullet>) (\<star>) assoc unit src trg r \<rho> f g"
       proof -
         text \<open>
           The proof idea is as follows:  Let maps \<open>f = (f\<^sub>1, f\<^sub>0)\<close> and \<open>g = (g\<^sub>1, g\<^sub>0)\<close> be given.
           Let \<open>f' = (f\<^sub>1 \<cdot> C.inv f\<^sub>0, C.cod f\<^sub>0)\<close> and \<open>g' = (g\<^sub>1 \<cdot> C.inv g\<^sub>0, C.cod g\<^sub>0)\<close>;
           then \<open>f'\<close> and \<open>g'\<close> are maps isomorphic to \<open>f\<close> and \<open>g\<close>, respectively.
           By a previous result, \<open>f'\<close> and \<open>g'\<close> extend to a tabulation \<open>(f', \<tau>, g')\<close> of
           \<open>r = (f\<^sub>1 \<cdot> C.inv f\<^sub>0, g\<^sub>1 \<cdot> C.inv g\<^sub>0)\<close>.
           Compose with isomorphisms \<open>\<guillemotleft>\<phi> : f' \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>\<close> to obtain
           \<open>(f, (r \<star> \<phi>) \<cdot> \<tau> \<cdot> \<psi>, g)\<close> and show it must also be a tabulation.
         \<close>
         fix f g
         assume f: "is_left_adjoint f"
         assume g: "is_left_adjoint g"
         assume fg: "src f = src g"
         show "\<exists>r \<rho>. tabulation (\<bullet>) (\<star>) assoc unit src trg r \<rho> f g"
         proof -
           text \<open>We have to unpack the hypotheses to get information about f and g.\<close>
           obtain f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f
             where ff\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f"
             using f adjoint_pair_def by auto
           interpret ff\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f
             using ff\<^sub>a by simp
           interpret f: arrow_of_spans C f
             using ide_char [of f] by simp
           interpret f: identity_arrow_of_spans C f
             using ide_char [of f] by unfold_locales auto
           obtain g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g
             where G: "adjunction_in_bicategory vcomp hcomp assoc unit src trg g g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g"
             using g adjoint_pair_def by auto
           interpret gg\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg g g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g
             using G by simp
           interpret g: arrow_of_spans C g
             using ide_char [of g] by simp
           interpret g: identity_arrow_of_spans C g
             using ide_char [of g] by unfold_locales auto
 
           let ?f' = "mkIde (C.cod f.leg0) (f.dom.leg1 \<cdot> C.inv f.leg0)"
           have f': "ide ?f'"
           proof -
             have "C.span (C.cod f.leg0) (f.leg1 \<cdot> C.inv f.leg0)"
               using f is_left_adjoint_char by auto
             thus ?thesis
               using ide_mkIde by blast
           qed
           interpret f': arrow_of_spans C ?f'
             using f' ide_char by blast
           interpret f': identity_arrow_of_spans C ?f'
             using f' ide_char by unfold_locales auto
 
           let ?g' = "mkIde (C.cod g.leg0) (g.dom.leg1 \<cdot> C.inv g.leg0)"
           have g': "ide ?g'"
           proof -
             have "C.span (C.cod g.leg0) (g.leg1 \<cdot> C.inv g.leg0)"
               using g is_left_adjoint_char by auto
             thus ?thesis
               using ide_mkIde by blast
           qed
           interpret g': arrow_of_spans C ?g'
             using g' ide_char by blast
           interpret g': identity_arrow_of_spans C ?g'
             using g' ide_char by unfold_locales auto
         
           let ?r = "mkIde (f'.leg1) (g'.leg1)"
           have r: "ide ?r"
           proof -
             have "C.span (f'.leg1) (g'.leg1)"
               using f g fg src_def is_left_adjoint_char by simp
             thus ?thesis
               using ide_mkIde by blast
           qed
           interpret r: arrow_of_spans C ?r
             using r ide_char by blast
           interpret r: identity_arrow_of_spans C ?r
             using r ide_char by unfold_locales auto
           interpret r: identity_arrow_in_span_bicategory C prj0 prj1 ?r ..
 
           have "r.f = ?f'"
             using f r.chine_eq_apex is_left_adjoint_char by auto
           have "r.g = ?g'"
             using f r.chine_eq_apex fg src_def is_left_adjoint_char by simp
 
           interpret \<rho>: tabulation \<open>(\<bullet>)\<close> \<open>(\<star>)\<close> assoc unit src trg ?r r.\<rho> r.f r.g
             using r.has_tabulation by simp
           have \<rho>_eq: "r.\<rho> = \<lparr>Chn = \<langle>C.cod f.leg0 \<lbrakk>f'.leg1, f'.leg1\<rbrakk> C.cod f.leg0\<rangle>,
                              Dom = \<lparr>Leg0 = C.cod f.leg0, Leg1 = g'.leg1\<rparr>,
                              Cod = \<lparr>Leg0 = \<p>\<^sub>0[f'.leg1, f'.leg1],
                                     Leg1 = g'.leg1 \<cdot> \<p>\<^sub>1[f'.leg1, f'.leg1]\<rparr>\<rparr>"
             using \<open>r.f = ?f'\<close> by auto
 
           text \<open>Obtain the isomorphism from \<open>f'\<close> to \<open>f\<close>.\<close>
           let ?\<phi> = "\<lparr>Chn = C.inv f.leg0, Dom = Dom ?f', Cod = Dom f\<rparr>"
           interpret Dom_\<phi>: span_in_category C
                               \<open>Dom \<lparr>Chn = C.inv f.leg0,
                                     Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
                                     Cod = Dom f\<rparr>\<close>
             using f'.dom.span_in_category_axioms by simp
           interpret Cod_\<phi>: span_in_category C
                               \<open>Cod \<lparr>Chn = C.inv f.leg0,
                                     Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
                                     Cod = Dom f\<rparr>\<close>
             using f.dom.span_in_category_axioms by simp
           interpret \<phi>: arrow_of_spans C ?\<phi>
           proof
             show "\<guillemotleft>Chn \<lparr>Chn = C.inv f.leg0,
                         Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
                         Cod = Dom f\<rparr> : Dom_\<phi>.apex \<rightarrow>\<^sub>C Cod_\<phi>.apex\<guillemotright>"
               using f f.dom.apex_def f'.dom.apex_def is_left_adjoint_char by auto
             show "Cod_\<phi>.leg0 \<cdot> Chn \<lparr>Chn = C.inv f.leg0,
                                     Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
                                     Cod = Dom f\<rparr> =
                   Dom_\<phi>.leg0"
               using f f.dom.apex_def is_left_adjoint_char C.comp_arr_inv C.inv_is_inverse
               by simp
             show "Cod_\<phi>.leg1 \<cdot> Chn \<lparr>Chn = C.inv f.leg0,
                                     Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
                                     Cod = Dom f\<rparr> =
                   Dom_\<phi>.leg1"
               by simp
           qed
           have \<phi>: "\<guillemotleft>?\<phi> : ?f' \<Rightarrow> f\<guillemotright> \<and> iso ?\<phi>"
             using f is_left_adjoint_char iso_char arr_char dom_char cod_char
                   \<phi>.arrow_of_spans_axioms f'.dom.apex_def f.dom.apex_def
             by auto
 
           text \<open>
             Obtain the isomorphism from \<open>g\<close> to \<open>g'\<close>.
             Recall: \<open>g' = mkIde (C.cod g.leg0) (g.dom.leg1 \<cdot> C.inv g.leg0)\<close>.
             The isomorphism is given by \<open>g.leg0\<close>.
           \<close>
           let ?\<psi> = "\<lparr>Chn = g.leg0, Dom = Dom g, Cod = Dom ?g'\<rparr>"
           interpret Dom_\<psi>: span_in_category C
                               \<open>Dom \<lparr>Chn = g.leg0,
                                     Dom = Dom g,
                                     Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr>\<close>
             using g.dom.span_in_category_axioms by simp
           interpret Cod_\<psi>: span_in_category C
                               \<open>Cod \<lparr>Chn = g.leg0,
                                     Dom = Dom g,
                                     Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr>\<close>
             using g'.dom.span_in_category_axioms by simp
           interpret \<psi>: arrow_of_spans C ?\<psi>
           proof
             show "\<guillemotleft>Chn \<lparr>Chn = g.leg0,
                         Dom = Dom g,
                         Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> :
                           Dom_\<psi>.apex \<rightarrow>\<^sub>C Cod_\<psi>.apex\<guillemotright>"
               using g g.dom.apex_def g'.dom.apex_def is_left_adjoint_char by auto
             show "Cod_\<psi>.leg0 \<cdot> Chn \<lparr>Chn = g.leg0,
                                     Dom = Dom g,
                                     Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> =
                   Dom_\<psi>.leg0"
               using C.comp_cod_arr by simp
             show "Cod_\<psi>.leg1 \<cdot> Chn \<lparr>Chn = g.leg0,
                                     Dom = Dom g,
                                     Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> =
                   Dom_\<psi>.leg1"
               using g g.dom.apex_def is_left_adjoint_char C.comp_inv_arr C.inv_is_inverse
                     C.comp_assoc C.comp_arr_dom
               by simp
           qed
           have \<psi>: "\<guillemotleft>?\<psi> : g \<Rightarrow> ?g'\<guillemotright> \<and> iso ?\<psi>"
             using g is_left_adjoint_char iso_char arr_char dom_char cod_char
                   \<psi>.arrow_of_spans_axioms g.dom.apex_def g'.dom.apex_def
             by auto
           have \<rho>\<psi>: "tabulation (\<bullet>) (\<star>) assoc unit src trg ?r (r.\<rho> \<bullet> ?\<psi>) r.f g"
             using \<psi> \<open>r.g = ?g'\<close> r.has_tabulation \<rho>.preserved_by_output_iso by simp
           interpret \<tau>\<psi>: tabulation vcomp hcomp assoc unit src trg ?r \<open>r.\<rho> \<bullet> ?\<psi>\<close> r.f g
             using \<rho>\<psi> by auto
           have "tabulation (\<bullet>) (\<star>) assoc unit src trg ?r ((?r \<star> ?\<phi>) \<bullet> r.\<rho> \<bullet> ?\<psi>) f g"
             using \<phi> \<open>r.f = ?f'\<close> \<tau>\<psi>.preserved_by_input_iso [of ?\<phi> f] by argo
           thus ?thesis by auto
         qed
       qed
 
       text \<open>The sub-bicategory of maps is locally essentially discrete.\<close>
       show "\<And>f f' \<mu> \<mu>'. \<lbrakk> is_left_adjoint f; is_left_adjoint f'; \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright> \<rbrakk>
                             \<Longrightarrow> iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
       proof -
         fix f f' \<mu> \<mu>'
         assume f: "is_left_adjoint f" and f': "is_left_adjoint f'"
         assume \<mu>: "\<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>" and \<mu>': "\<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright>"
         obtain f\<^sub>a \<eta> \<epsilon>
           where f\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta> \<epsilon>"
           using f adjoint_pair_def by auto
         obtain f'\<^sub>a \<eta>' \<epsilon>'
           where f'\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f' f'\<^sub>a \<eta>' \<epsilon>'"
           using f' adjoint_pair_def adjunction_def by auto
         interpret f\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta> \<epsilon>
           using f\<^sub>a by simp
         interpret f'\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f' f'\<^sub>a \<eta>' \<epsilon>'
           using f'\<^sub>a by simp
         interpret f: identity_arrow_of_spans C f
           using ide_char' [of f] by simp
         interpret f': identity_arrow_of_spans C f'
           using ide_char' [of f'] by simp
         interpret \<mu>: arrow_of_spans C \<mu> using \<mu> arr_char by auto
         interpret \<mu>': arrow_of_spans C \<mu>' using \<mu>' arr_char by auto
         have 1: "C.iso f.leg0 \<and> C.iso f'.leg0"
           using f f' is_left_adjoint_char by simp
         have 2: "\<mu>.chine = C.inv f'.leg0 \<cdot> f.leg0"
           using \<mu> 1 dom_char cod_char \<mu>.leg0_commutes C.invert_side_of_triangle by auto
         moreover have "\<mu>'.chine = C.inv f'.leg0 \<cdot> f.leg0"
           using \<mu>' 1 dom_char cod_char \<mu>'.leg0_commutes C.invert_side_of_triangle by auto
         ultimately have 3: "\<mu>.chine = \<mu>'.chine" by simp
         have "iso \<mu>"
           using 1 2 \<mu> C.isos_compose dom_char cod_char iso_char arr_char by auto
         hence "iso \<mu>'"
           using 3 iso_char arr_char \<mu>'.arrow_of_spans_axioms by simp
         moreover have "\<mu> = \<mu>'"
           using 3 \<mu> \<mu>' dom_char cod_char by fastforce
         ultimately show "iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
           by simp
       qed
     qed
 
     text \<open>
       We can now prove the easier half of the main result (CKS Theorem 4):
       If \<open>B\<close> is biequivalent to \<open>Span(C)\<close>, where \<open>C\<close> is a category with pullbacks,
       then \<open>B\<close> is a bicategory of spans.
       (Well, it is easier given that we have already done the work to show that the notion
       ``bicategory of spans'' is respected by equivalence of bicategories.)
     \<close>
 
     theorem equivalent_implies_bicategory_of_spans:
     assumes "equivalent_bicategories vcomp hcomp assoc unit src trg V\<^sub>1 H\<^sub>1 \<a>\<^sub>1 \<i>\<^sub>1 src\<^sub>1 trg\<^sub>1"
     shows "bicategory_of_spans V\<^sub>1 H\<^sub>1 \<a>\<^sub>1 \<i>\<^sub>1 src\<^sub>1 trg\<^sub>1"
       using assms is_bicategory_of_spans bicategory_of_spans_respects_equivalence by blast
 
   end
 
   subsection "Properties of Bicategories of Spans"
 
   text \<open>
     We now develop consequences of the axioms for a bicategory of spans, in preparation for
     proving the other half of the main result.
   \<close>
 
   context bicategory_of_spans
   begin
 
     notation isomorphic  (infix "\<cong>" 50)
 
     text \<open>
       The following is a convenience version of \<open>BS2\<close> that gives us what we generally want:
       given specified \<open>f, g\<close> obtain \<open>\<rho>\<close> that makes \<open>(f, \<rho>, g)\<close> a tabulation of \<open>g \<star> f\<^sup>*\<close>,
       not a tabulation of some \<open>r\<close> isomorphic to \<open>g \<star> f\<^sup>*\<close>.
     \<close>
 
     lemma BS2':
     assumes "is_left_adjoint f" and "is_left_adjoint g" and "src f = src g"
     and "isomorphic (g \<star> f\<^sup>*) r"
     shows "\<exists>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
     proof -
       have 1: "is_left_adjoint f \<and> is_left_adjoint g \<and> g \<star> f\<^sup>* \<cong> r"
         using assms BS1 by simp
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
         using 1 isomorphic_def by blast
       obtain r' \<rho>' where \<rho>': "tabulation V H \<a> \<i> src trg r' \<rho>' f g"
         using assms 1 BS2 by blast
       interpret \<rho>': tabulation V H \<a> \<i> src trg r' \<rho>' f g
         using \<rho>' by simp
       let ?\<psi> = "\<rho>'.T0.trnr\<^sub>\<epsilon> r' \<rho>'"
       have \<psi>: "\<guillemotleft>?\<psi> : g \<star> f\<^sup>* \<Rightarrow> r'\<guillemotright> \<and> iso ?\<psi>"
         using \<rho>'.yields_isomorphic_representation by blast
       have "\<guillemotleft>\<phi> \<cdot> inv ?\<psi> : r' \<Rightarrow> r\<guillemotright> \<and> iso (\<phi> \<cdot> inv ?\<psi>)"
         using \<phi> \<psi> isos_compose by blast
       hence 3: "tabulation V H \<a> \<i> src trg r ((\<phi> \<cdot> inv ?\<psi> \<star> f) \<cdot> \<rho>') f g"
         using \<rho>'.is_preserved_by_base_iso by blast
       hence "\<exists>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
         by blast
       thus ?thesis
         using someI_ex [of "\<lambda>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"] by simp
     qed
 
     text \<open>
       The following observation is made by CKS near the beginning of the proof of Theorem 4:
       If \<open>w\<close> is an arbitrary 1-cell, and \<open>g\<close> and \<open>g \<star> w\<close> are maps, then \<open>w\<close> is in fact a map.
       It is applied frequently.
     \<close>
 
     lemma BS4:
     assumes "is_left_adjoint g" and "ide w" and "is_left_adjoint (g \<star> w)"
     shows "is_left_adjoint w"
     proof -
       text \<open>
         CKS say: ``by (i) there are maps \<open>m, n\<close> with \<open>w \<cong> nm\<^sup>*\<close>, so, by (ii), we have two
         tabulations \<open>(1, \<rho>, gw)\<close>, \<open>(m, \<sigma>, gn)\<close> of \<open>gw\<close>; since tabulations are unique
         up to equivalence, \<open>m\<close> is invertible and \<open>w \<cong> nm\<^sup>*\<close> is a map.''
       \<close>
       have ex_\<rho>: "\<exists>\<rho>. tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
       proof -
         have "(g \<star> w) \<star> src w \<cong> g \<star> w"
           by (metis assms(3) iso_runit ideD(1) isomorphic_def left_adjoint_is_ide
               runit_in_hom(2) src_hcomp)
         moreover have "(g \<star> w) \<star> (src w)\<^sup>* \<cong> g \<star> w"
         proof -
           have "(g \<star> w) \<star> src (g \<star> w) \<cong> g \<star> w"
             using calculation isomorphic_implies_ide(2) by auto
           moreover have "src (g \<star> w) \<cong> (src w)\<^sup>*"
           proof -
             interpret src_w: map_in_bicategory V H \<a> \<i> src trg \<open>src w\<close>
               using assms obj_is_self_adjoint by unfold_locales auto
             interpret src_w: adjunction_in_bicategory V H \<a> \<i> src trg
                                \<open>src w\<close> \<open>(src w)\<^sup>*\<close> src_w.\<eta> src_w.\<epsilon>
               using src_w.is_map left_adjoint_extends_to_adjunction by simp
             have "adjoint_pair (src w) (src w)"
               using assms obj_is_self_adjoint by simp
             moreover have "adjoint_pair (src w) (src w)\<^sup>*"
               using adjoint_pair_def src_w.adjunction_in_bicategory_axioms by auto
             ultimately have "src w \<cong> (src w)\<^sup>*"
               using left_adjoint_determines_right_up_to_iso by simp
             moreover have "src w = src (g \<star> w)"
               using assms isomorphic_def hcomp_simps(1) left_adjoint_is_ide by simp
             ultimately show ?thesis by simp
           qed
           moreover have "src (g \<star> w) = trg (src (g \<star> w))"
             using assms left_adjoint_is_ide by simp
           ultimately show ?thesis
             using assms left_adjoint_is_ide isomorphic_transitive isomorphic_symmetric
                   hcomp_ide_isomorphic
             by blast
         qed
         ultimately show ?thesis
           using assms obj_is_self_adjoint
                 left_adjoint_is_ide BS2' [of "src w" "g \<star> w" "g \<star> w"]
           by auto
       qed
       obtain \<rho> where \<rho>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
         using ex_\<rho> by auto
       obtain m n where mn: "is_left_adjoint m \<and> is_left_adjoint n \<and> isomorphic w (n \<star> m\<^sup>*)"
         using assms BS1 [of w] by auto
       have m\<^sub>a: "adjoint_pair m m\<^sup>* \<and> isomorphic w (n \<star> m\<^sup>*)"
         using mn adjoint_pair_def left_adjoint_extends_to_adjoint_pair by blast
       have ex_\<sigma>: "\<exists>\<sigma>. tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
       proof -
         have "hseq n m\<^sup>*"
           using mn isomorphic_implies_ide by auto
         have "trg (n \<star> m\<^sup>*) = trg w"
           using mn m\<^sub>a isomorphic_def
           by (metis (no_types, lifting) dom_inv in_homE trg_dom trg_inv)
         hence "trg n = trg w"
           using mn by (metis assms(2) ideD(1) trg.preserves_reflects_arr trg_hcomp)
         hence "hseq g n"
           using assms mn left_adjoint_is_ide ideD(1)
           by (metis hseq_char)
         have "hseq g w"
           using assms left_adjoint_is_ide by simp
         have "src m = src n"
           using mn m\<^sub>a \<open>hseq n m\<^sup>*\<close> adjoint_pair_antipar [of m "m\<^sup>*"] by fastforce
 
         have "is_left_adjoint (g \<star> n)"
           using assms mn left_adjoints_compose \<open>hseq g n\<close> by blast
         moreover have "src m = src (g \<star> n)"
           using assms mn \<open>hseq g n\<close> \<open>src m = src n\<close> by simp
         moreover have "(g \<star> n) \<star> m\<^sup>* \<cong> g \<star> w"
         proof -
           have 1: "src g = trg (n \<star> m\<^sup>*)"
             using assms \<open>trg (n \<star> m\<^sup>*) = trg w\<close> \<open>hseq g w\<close> by fastforce
           hence "(g \<star> n) \<star> m\<^sup>* \<cong> g \<star> n \<star> m\<^sup>*"
             using assms mn m\<^sub>a assoc_in_hom iso_assoc \<open>hseq g n\<close> \<open>hseq n m\<^sup>*\<close>
                   isomorphic_def left_adjoint_is_ide right_adjoint_is_ide
             by (metis hseqE ideD(2) ideD(3))
           also have "... \<cong> g \<star> w"
             using assms 1 mn m\<^sub>a isomorphic_symmetric hcomp_ide_isomorphic left_adjoint_is_ide
             by simp
           finally show ?thesis
             using isomorphic_transitive by blast
         qed
         ultimately show ?thesis
           using assms mn m\<^sub>a BS2' by blast
       qed
       obtain \<sigma> where \<sigma>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
         using ex_\<sigma> by auto
 
       interpret \<rho>: tabulation V H \<a> \<i> src trg \<open>g \<star> w\<close> \<rho> \<open>src w\<close> \<open>g \<star> w\<close>
         using \<rho> by auto
       interpret \<sigma>: tabulation V H \<a> \<i> src trg \<open>g \<star> w\<close> \<sigma> m \<open>g \<star> n\<close>
         using \<sigma> by auto
       text \<open>
         As usual, the sketch given by CKS seems more suggestive than it is a precise recipe.
         We can obtain an equivalence map \<open>\<guillemotleft>e : src w \<rightarrow> src m\<guillemotright>\<close> and \<open>\<theta>\<close> such that
         \<open>\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright>\<close>.
         We can also obtain an equivalence map \<open>\<guillemotleft>e' : src m \<rightarrow> src w\<guillemotright>\<close> and \<open>\<theta>'\<close> such that
         \<open>\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright>\<close>.  If \<open>\<theta>'\<close> can be taken to be an isomorphism; then we have
         \<open>e' \<cong> src w \<star> e' \<cong> m\<close>.  Since \<open>e'\<close> is an equivalence, this shows \<open>m\<close> is an equivalence,
         hence its right adjoint \<open>m\<^sup>*\<close> is also an equivalence and therefore a map.
         But \<open>w = n \<star> m\<^sub>a\<close>, so this shows that \<open>w\<close> is a map.
 
         Now, we may assume without loss of generality that \<open>e\<close> and \<open>e'\<close> are part of an
         adjoint equivalence.
         We have \<open>\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright>\<close>.
         We may take the transpose of \<open>\<theta>\<close> to obtain \<open>\<guillemotleft>\<zeta> : m \<Rightarrow> src w \<star> e'\<guillemotright>\<close>;
         then \<open>\<guillemotleft>\<theta>' \<cdot> \<zeta> : m \<Rightarrow> m\<guillemotright>\<close> and \<open>\<guillemotleft>\<zeta> \<cdot> \<theta>' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>\<close>.
         Since \<open>m\<close> and \<open>src w \<star> e'\<close> are maps, by \<open>BS3\<close> it must be that \<open>\<zeta>\<close> and \<open>\<theta>'\<close> are inverses.
         \<close>
         text \<open>
           {\bf Note:} CKS don't cite \<open>BS3\<close> here.  I am not sure whether this result can be proved
           without \<open>BS3\<close>.  For example, I am interested in knowing whether it can still be
           proved under the the assumption that 2-cells between maps are unique, but not
           necessarily invertible, or maybe even in a more general situation.  It looks like
           the invertibility part of \<open>BS3\<close> is not used in the proof below.
         \<close>
       have 2: "\<exists>e e' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
                   equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi> \<and>
                   \<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<star> n \<Rightarrow> (g \<star> w) \<star> e'\<guillemotright> \<and> iso \<nu> \<and>
                   \<sigma> = \<rho>.composite_cell e' \<theta>' \<cdot> \<nu> \<and>
                   \<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright> \<and> \<guillemotleft>\<nu>' : g \<star> w \<Rightarrow> (g \<star> n) \<star> e\<guillemotright> \<and> iso \<nu>' \<and>
                   \<rho> = ((g \<star> w) \<star> \<theta>) \<cdot> \<a>[g \<star> w, m, e] \<cdot> (\<sigma> \<star> e) \<cdot> \<nu>'"
         using \<rho> \<sigma>.apex_unique_up_to_equivalence [of \<rho> "src w" "g \<star> w"] comp_assoc
         by metis
       obtain e e' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
         where *: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi> \<and>
                   \<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<star> n \<Rightarrow> (g \<star> w) \<star> e'\<guillemotright> \<and> iso \<nu> \<and>
                   \<sigma> = \<rho>.composite_cell e' \<theta>' \<cdot> \<nu> \<and>
                   \<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright> \<and> \<guillemotleft>\<nu>' : g \<star> w \<Rightarrow> (g \<star> n) \<star> e\<guillemotright> \<and> iso \<nu>' \<and>
                   \<rho> = \<sigma>.composite_cell e \<theta> \<cdot> \<nu>'"
         using 2 comp_assoc by auto
       interpret ee': equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e e' \<phi> \<psi>
         using * by simp
 
       have equiv_e: "equivalence_map e"
         using ee'.equivalence_in_bicategory_axioms equivalence_map_def by auto
       obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi>'"
         using equivalence_refines_to_adjoint_equivalence [of e e' \<phi>]
               ee'.unit_in_hom(2) ee'.unit_is_iso ee'.antipar equiv_e
         by auto
       interpret ee': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e e' \<phi> \<psi>'
         using \<psi>' by simp
       interpret e'e: adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e' e \<open>inv \<psi>'\<close> \<open>inv \<phi>\<close>
         using * ee'.dual_adjoint_equivalence by simp
       have equiv_e': "equivalence_map e'"
         using e'e.equivalence_in_bicategory_axioms equivalence_map_def by auto
 
       have "hseq m e"
         using * ide_dom [of \<theta>]
         by (elim conjE in_homE) simp
       have "hseq (src w) e'"
         using * ide_dom [of \<theta>']
         by (elim conjE in_homE) simp
 
       have "e'e.trnr\<^sub>\<eta> m \<theta> \<in> hom m (src w \<star> e')"
       proof -
         have "src m = trg e"
           using \<open>hseq m e\<close> by auto
         moreover have "src (src w) = trg e'"
           using \<open>hseq (src w) e'\<close> by auto
         moreover have "ide m"
           using mn left_adjoint_is_ide by simp
         moreover have "ide (src w)"
           using assms by simp
         ultimately show ?thesis
           using * e'e.adjoint_transpose_right(1) by blast
       qed
       hence 3: "\<guillemotleft>e'e.trnr\<^sub>\<eta> m \<theta> : m \<Rightarrow> src w \<star> e'\<guillemotright>"
         by simp
       hence "\<guillemotleft>\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta> : m \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>"
         using * by auto
       moreover have "\<guillemotleft>m : m \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>src w \<star> e' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>"
         using mn 3 ide_cod [of "e'e.trnr\<^sub>\<eta> m \<theta>"] left_adjoint_is_ide by fastforce
       moreover have 4: "is_left_adjoint (src w \<star> e')"
       proof -
         have "is_left_adjoint (src w)"
           using assms obj_is_self_adjoint by simp
         moreover have "is_left_adjoint e'"
           using e'e.adjunction_in_bicategory_axioms adjoint_pair_def by auto
         ultimately show ?thesis
           using left_adjoints_compose \<open>hseq (src w) e'\<close> by auto
       qed
       ultimately have "\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta> = m \<and> e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>' = src w \<star> e'"
         using mn BS3 [of m m "\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta>" m]
               BS3 [of "src w \<star> e'" "src w \<star> e'" "e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>'" "src w \<star> e'"]
         by auto
       hence "inverse_arrows \<theta>' (e'e.trnr\<^sub>\<eta> m \<theta>)"
         using mn 4 left_adjoint_is_ide inverse_arrows_def by simp
       hence 5: "iso \<theta>'"
         by auto
       have "equivalence_map (src w \<star> e')"
         using assms obj_is_equivalence_map equiv_e' \<open>hseq (src w) e'\<close> equivalence_maps_compose
         by auto
       hence "equivalence_map m"
         using * 5 equivalence_map_preserved_by_iso isomorphic_def by auto
       hence "equivalence_map m\<^sup>*"
         using mn m\<^sub>a right_adjoint_to_equivalence_is_equivalence by simp
       hence "is_left_adjoint m\<^sup>*"
         using equivalence_is_left_adjoint by simp
       moreover have "hseq n m\<^sup>*"
         using mn isomorphic_implies_ide by auto
       ultimately have "is_left_adjoint (n \<star> m\<^sup>*)"
         using mn left_adjoints_compose by blast
       thus ?thesis
         using mn left_adjoint_preserved_by_iso isomorphic_def isomorphic_symmetric
         by metis
     qed
 
   end
 
   subsection "Choosing Tabulations"
 
   context bicategory_of_spans
   begin
 
     notation isomorphic  (infix "\<cong>" 50)
     notation iso_class ("\<lbrakk>_\<rbrakk>")
 
     text \<open>
       We will ultimately need to have chosen a specific tabulation for each 1-cell.
       This has to be done carefully, to avoid unnecessary choices.
       We start out by using \<open>BS1\<close> to choose a specific factorization of the form
       \<open>r \<cong> tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<close> for each 1-cell \<open>r\<close>.  This has to be done in such a way
       that all elements of an isomorphism class are assigned the same factorization.
     \<close>
 
     abbreviation isomorphic_rep
     where "isomorphic_rep r f g \<equiv> is_left_adjoint f \<and> is_left_adjoint g \<and> g \<star> f\<^sup>* \<cong> r"
 
     definition tab\<^sub>0
     where "tab\<^sub>0 r \<equiv> SOME f. \<exists>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"
 
     definition tab\<^sub>1
     where "tab\<^sub>1 r \<equiv> SOME g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) g"
 
     definition rep
     where "rep r \<equiv> SOME \<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
 
     lemma rep_props:
     assumes "ide r"
     shows "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso (rep r)"
     and "r \<cong> iso_class_rep \<lbrakk>r\<rbrakk>"
     and "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
     and "tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<cong> r"
     proof -
       have 1: "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
       proof -
         have "\<exists>f g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"
           using assms BS1 isomorphic_symmetric rep_iso_class isomorphic_transitive
           by blast
         hence "isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) (tab\<^sub>1 r)"
           using assms tab\<^sub>0_def tab\<^sub>1_def 
                 someI_ex [of "\<lambda>f. \<exists>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"]
                 someI_ex [of "\<lambda>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) g"]
           by simp
         thus ?thesis
           using assms isomorphic_symmetric isomorphic_transitive rep_iso_class by blast
       qed
       hence "\<exists>\<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
         using isomorphic_def by blast
       hence 2: "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso (rep r)"
         using someI_ex [of "\<lambda>\<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"] rep_def by auto
       show "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
         using 2 by simp
       show "iso (rep r)"
         using 2 by simp
       show "r \<cong> iso_class_rep \<lbrakk>r\<rbrakk>"
         using assms rep_iso_class isomorphic_symmetric by simp
       thus "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
         using 1 isomorphic_transitive by blast
       thus "tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<cong> r"
         by simp
     qed
 
     lemma tab\<^sub>0_in_hom [intro]:
     assumes "ide r"
     shows "\<guillemotleft>tab\<^sub>0 r : src (tab\<^sub>0 r) \<rightarrow> src r\<guillemotright>"
     and "\<guillemotleft>tab\<^sub>0 r : tab\<^sub>0 r \<Rightarrow> tab\<^sub>0 r\<guillemotright>"
     proof -
       show "\<guillemotleft>tab\<^sub>0 r : tab\<^sub>0 r \<Rightarrow> tab\<^sub>0 r\<guillemotright>"
         using assms rep_props left_adjoint_is_ide by auto
       have "trg (tab\<^sub>0 r) = src r"
         using assms rep_props
         by (metis ideD(1) isomorphic_implies_hpar(1) isomorphic_implies_hpar(3)
             right_adjoint_simps(2) src_hcomp)
       thus "\<guillemotleft>tab\<^sub>0 r : src (tab\<^sub>0 r) \<rightarrow> src r\<guillemotright>"
         using assms rep_props left_adjoint_is_ide
         by (intro in_hhomI, auto)
     qed
 
     lemma tab\<^sub>0_simps [simp]:
     assumes "ide r"
     shows "ide (tab\<^sub>0 r)"
     and "is_left_adjoint (tab\<^sub>0 r)"
     and "trg (tab\<^sub>0 r) = src r"
     and "dom (tab\<^sub>0 r) = tab\<^sub>0 r" and "cod (tab\<^sub>0 r) = tab\<^sub>0 r"
       using assms tab\<^sub>0_in_hom rep_props ide_dom left_adjoint_is_ide by auto
 
     lemma tab\<^sub>1_in_hom [intro]:
     assumes "ide r"
     shows "\<guillemotleft>tab\<^sub>1 r : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
     and "\<guillemotleft>tab\<^sub>1 r : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 r\<guillemotright>"
     proof -
       show "\<guillemotleft>tab\<^sub>1 r : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 r\<guillemotright>"
         using assms rep_props left_adjoint_is_ide by auto
       have "trg (tab\<^sub>1 r) = trg r"
         using assms rep_props
         by (metis ideD(1) isomorphic_implies_hpar(1) isomorphic_implies_hpar(4) trg_hcomp)
       moreover have "src (tab\<^sub>0 r) = src (tab\<^sub>1 r)"
         using assms rep_props by fastforce
       ultimately show "\<guillemotleft>tab\<^sub>1 r : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
         using assms rep_props left_adjoint_is_ide
         by (intro in_hhomI, auto)
     qed
 
     lemma tab\<^sub>1_simps [simp]:
     assumes "ide r"
     shows "ide (tab\<^sub>1 r)"
     and "is_left_adjoint (tab\<^sub>1 r)"
     and "src (tab\<^sub>1 r) = src (tab\<^sub>0 r)" and "trg (tab\<^sub>1 r) = trg r"
     and "dom (tab\<^sub>1 r) = tab\<^sub>1 r" and "cod (tab\<^sub>1 r) = tab\<^sub>1 r"
       using assms tab\<^sub>1_in_hom rep_props ide_dom left_adjoint_is_ide by auto
 
     lemma rep_in_hom [intro]:
     assumes "ide r"
     shows "\<guillemotleft>rep r : src r \<rightarrow> trg r\<guillemotright>"
     and "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
     proof -
       show "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
         using assms rep_props by auto
       thus "\<guillemotleft>rep r : src r \<rightarrow> trg r\<guillemotright>"
         using arrI vconn_implies_hpar(1-4) by force
     qed
 
     lemma rep_simps [simp]:
     assumes "ide r"
     shows "arr (rep r)"
     and "src (rep r) = src r" and "trg (rep r) = trg r"
     and "dom (rep r) = tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*" and "cod (rep r) = r"
      using assms rep_in_hom by auto
 
     lemma iso_rep:
     assumes "ide r"
     shows "iso (rep r)"
       using assms rep_props by simp
 
   end
 
   text \<open>
     Next, we assign a specific tabulation to each 1-cell r.
     We can't just do this any old way if we ultimately expect to obtain a mapping that is
     functorial with respect to vertical composition.  What we have to do is to assign the
     representative \<open>tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<close> its canonical tabulation, obtained as the adjoint
     transpose of the identity, and then translate this to a tabulation of \<open>r\<close> via the chosen
     isomorphism \<open>\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>.
   \<close>
 
   locale identity_in_bicategory_of_spans =
     bicategory_of_spans +
   fixes r :: 'a
   assumes is_ide: "ide r"
   begin
 
     interpretation tab\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close>
       using is_ide rep_props by unfold_locales auto
     interpretation tab\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>1 r\<close>
       using is_ide rep_props by unfold_locales auto
 
     text \<open>
       A tabulation \<open>(tab\<^sub>0 r, tab, tab\<^sub>1 r)\<close> of \<open>r\<close> can be obtained as the adjoint transpose
       of the isomorphism \<open>\<guillemotleft>rep r : (tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>.  It is essential to define
       it this way if we expect the mapping from 2-cells of the underlying bicategory
       to arrows of spans to preserve vertical composition.
     \<close>
 
     definition tab
     where "tab \<equiv> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) (rep r)"
 
     text \<open>
       In view of \<open>BS2'\<close>, the 1-cell \<open>(tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*\<close> has the canonical tabulation
       obtained via adjoint transpose of an identity.  In fact, this tabulation generates the
       chosen tabulation of \<open>r\<close> in the same isomorphism class by translation along the
       isomorphism \<open>\<guillemotleft>rep r : (tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>.  This fact is used to show that the
       mapping from 2-cells to arrows of spans preserves identities.
     \<close>
 
     lemma canonical_tabulation:
     shows "tabulation V H \<a> \<i> src trg
              ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) (tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)) (tab\<^sub>0 r) (tab\<^sub>1 r)"
     proof -
       have "\<exists>\<rho>. tabulation V H \<a> \<i> src trg ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<rho> (tab\<^sub>0 r) (tab\<^sub>1 r)"
         by (simp add: bicategory_of_spans.BS2' bicategory_of_spans_axioms is_ide
             isomorphic_reflexive)
       thus ?thesis
         using is_ide tab\<^sub>0.canonical_tabulation by simp
     qed
 
     lemma tab_def_alt:
     shows "tab = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
     and "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
     proof -
       have "tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) (rep r \<cdot> ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*))"
         using tab_def is_ide rep_in_hom [of r] comp_arr_dom by auto
       also have "... = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
         using is_ide tab\<^sub>0.trnr\<^sub>\<eta>_comp by auto
       finally show 1: "tab = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)" by simp
       have "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab =
             ((inv (rep r) \<star> tab\<^sub>0 r) \<cdot> (rep r \<star> tab\<^sub>0 r)) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
         unfolding 1 using comp_assoc by presburger
       also have "... = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
       proof - 
         have 1: "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> (rep r \<star> tab\<^sub>0 r) = ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r"
           using whisker_right [of "tab\<^sub>0 r" "inv (rep r)" "rep r"] iso_rep rep_in_hom
                 inv_is_inverse comp_inv_arr
           by (simp add: comp_inv_arr' is_ide)
         show ?thesis
         proof -
           have "\<guillemotleft>tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) :
                    tab\<^sub>1 r \<Rightarrow> (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r\<guillemotright>"
             by (meson canonical_tabulation tabulation_data.tab_in_hom(2) tabulation_def)
           hence "((tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) =
                  tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
             using 1 comp_cod_arr by blast
           thus ?thesis
             using 1 by simp
         qed
       qed
       finally show "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
         by blast
     qed
 
     lemma tab_is_tabulation:
     shows "tabulation V H \<a> \<i> src trg r tab (tab\<^sub>0 r) (tab\<^sub>1 r)"
       by (metis bicategory_of_spans.iso_rep bicategory_of_spans.rep_in_hom(2)
           bicategory_of_spans_axioms is_ide canonical_tabulation tab_def_alt(1)
           tabulation.is_preserved_by_base_iso)
 
     (*
      * TODO: If I pull the interpretation "tab" out of the following, Isabelle warns that
      * the lemma is a redundant introduction rule and is being "ignored" for that purpose.
      * However, the redundancy is only in the present context: if the enclosing locale is
      * interpreted elsewhere, then the rule is not redundant.  In order to make sure that
      * the rule is not "ignored", I have put the interpretation "tab" into the proof to
      * avoid the warning.
      *)
 
     lemma tab_in_hom [intro]:
     shows "\<guillemotleft>tab : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
     and "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
     proof -
       interpret tab: tabulation V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
         using tab_is_tabulation by simp
       show "\<guillemotleft>tab : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
         using tab.tab_in_hom by auto
       show "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
         using tab.tab_in_hom by auto
     qed
 
     lemma tab_simps [simp]:
     shows "arr tab"
     and "src tab = src (tab\<^sub>0 r)" and "trg tab = trg r"
     and "dom tab = tab\<^sub>1 r" and "cod tab = r \<star> tab\<^sub>0 r"
       using tab_in_hom by auto
 
   end
 
   text \<open>
     The following makes the chosen tabulation conveniently available whenever we are
     considering a particular 1-cell.
   \<close>
 
   sublocale identity_in_bicategory_of_spans \<subseteq> tabulation V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
     using is_ide tab_is_tabulation by simp
 
   context identity_in_bicategory_of_spans
   begin
 
     interpretation tab\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close>
       using is_ide rep_props by unfold_locales auto
     interpretation tab\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>1 r\<close>
       using is_ide rep_props by unfold_locales auto
 
     text \<open>
       The fact that adjoint transpose is a bijection allows us to invert the definition
       of \<open>tab\<close> in terms of \<open>rep\<close> to express rep in terms of tab.
     \<close>
 
     lemma rep_in_terms_of_tab:
     shows "rep r = T0.trnr\<^sub>\<epsilon> r tab"
       using is_ide T0.adjoint_transpose_right(3) [of r "tab\<^sub>1 r" "rep r"] tab_def
       by fastforce
 
     lemma isomorphic_implies_same_tab:
     assumes "isomorphic r r'"
     shows "tab\<^sub>0 r = tab\<^sub>0 r'" and "tab\<^sub>1 r = tab\<^sub>1 r'"
       using assms tab\<^sub>0_def tab\<^sub>1_def iso_class_eqI by auto
 
     text \<open>
       ``Every 1-cell has a tabulation as a span of maps.''
       Has a nice simple ring to it, but maybe not so useful for us, since we generally
       really need to know that the tabulation has a specific form.
     \<close>
 
     lemma has_tabulation:
     shows "\<exists>\<rho> f g. is_left_adjoint f \<and> is_left_adjoint g \<and> tabulation V H \<a> \<i> src trg r \<rho> f g"
       using is_ide tab_is_tabulation rep_props by blast
 
   end
 
   subsection "Tabulations in a Bicategory of Spans"
 
   context bicategory_of_spans
   begin
 
     abbreviation tab_of_ide
     where "tab_of_ide r \<equiv> identity_in_bicategory_of_spans.tab V H \<a> \<i> src trg r"
 
     abbreviation prj\<^sub>0
     where "prj\<^sub>0 h k \<equiv> tab\<^sub>0 (k\<^sup>* \<star> h)"
 
     abbreviation prj\<^sub>1
     where "prj\<^sub>1 h k \<equiv> tab\<^sub>1 (k\<^sup>* \<star> h)"
 
     lemma prj_in_hom [intro]:
     assumes "ide h" and "is_left_adjoint k" and "trg h = trg k"
     shows "\<guillemotleft>prj\<^sub>0 h k : src (prj\<^sub>0 h k) \<rightarrow> src h\<guillemotright>"
     and "\<guillemotleft>prj\<^sub>1 h k : src (prj\<^sub>0 h k) \<rightarrow> src k\<guillemotright>"
     and "\<guillemotleft>prj\<^sub>0 h k : prj\<^sub>0 h k \<Rightarrow> prj\<^sub>0 h k\<guillemotright>"
     and "\<guillemotleft>prj\<^sub>1 h k : prj\<^sub>1 h k \<Rightarrow> prj\<^sub>1 h k\<guillemotright>"
       by (intro in_hhomI, auto simp add: assms(1-3))
 
     lemma prj_simps [simp]:
     assumes "ide h" and "is_left_adjoint k" and "trg h = trg k"
     shows "trg (prj\<^sub>0 h k) = src h"
     and "src (prj\<^sub>1 h k) = src (prj\<^sub>0 h k)" and "trg (prj\<^sub>1 h k) = src k"
     and "dom (prj\<^sub>0 h k) = prj\<^sub>0 h k" and "cod (prj\<^sub>0 h k) = prj\<^sub>0 h k"
     and "dom (prj\<^sub>1 h k) = prj\<^sub>1 h k" and "cod (prj\<^sub>1 h k) = prj\<^sub>1 h k"
     and "is_left_adjoint (prj\<^sub>0 h k)" and "is_left_adjoint (prj\<^sub>1 h k)"
       using assms prj_in_hom by auto
 
   end
 
   text \<open>
     Many of the commutativity conditions that we would otherwise have to worry about
     when working with tabulations in a bicategory of spans reduce to trivialities.
     The following locales try to exploit this to make our life more manageable.
   \<close>
 
   locale span_of_maps =
     bicategory_of_spans +
   fixes leg\<^sub>0 :: 'a
   and leg\<^sub>1 :: 'a
   assumes leg0_is_map: "is_left_adjoint leg\<^sub>0"
   and leg1_is_map : "is_left_adjoint leg\<^sub>1"
 
   text \<open>
     The purpose of the somewhat strange-looking assumptions in this locale is
     to cater to the form of data that we obtain from \<open>T1\<close>.  Under the assumption
     that we are in a bicategory of spans and that the legs of \<open>r\<close> and \<open>s\<close> are maps,
     the hypothesized 2-cells will be uniquely determined isomorphisms, and an
     arrow of spans \<open>w\<close> from \<open>r\<close> to \<open>s\<close> will be a map.  We want to prove this once and
     for all under the weakest assumptions we can manage.
   \<close>
 
   locale arrow_of_spans_of_maps =
     bicategory_of_spans V H \<a> \<i> src trg +
     r: span_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 +
     s: span_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"    ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r\<^sub>0 :: 'a
   and r\<^sub>1 :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a
   and w :: 'a +
   assumes is_ide: "ide w"
   and leg0_lax: "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
   and leg1_iso: "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
   begin
 
     notation isomorphic  (infix "\<cong>" 50)
 
     lemma composite_leg1_is_map:
     shows "is_left_adjoint (s\<^sub>1 \<star> w)"
       using r.leg1_is_map leg1_iso left_adjoint_preserved_by_iso' isomorphic_def
             isomorphic_symmetric
       by auto
 
     lemma is_map:
     shows "is_left_adjoint w"
       using is_ide composite_leg1_is_map s.leg1_is_map BS4 [of s\<^sub>1 w] by auto
 
     lemma hseq_leg\<^sub>0:
     shows "hseq s\<^sub>0 w"
       by (metis ideD(1) ide_dom in_homE leg0_lax)
 
     lemma composite_with_leg0_is_map:
     shows "is_left_adjoint (s\<^sub>0 \<star> w)"
       using left_adjoints_compose is_map s.leg0_is_map hseq_leg\<^sub>0 by blast
 
     lemma leg0_uniquely_isomorphic:
     shows "s\<^sub>0 \<star> w \<cong> r\<^sub>0"
     and "\<exists>!\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
     proof -
       show 1: "s\<^sub>0 \<star> w \<cong> r\<^sub>0"
         using leg0_lax composite_with_leg0_is_map r.leg0_is_map BS3 [of "s\<^sub>0 \<star> w" r\<^sub>0]
               isomorphic_def
         by auto
       have "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> iso \<theta>"
         using 1 isomorphic_def by simp
       moreover have "\<And>\<theta> \<theta>'. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<Longrightarrow> \<guillemotleft>\<theta>' : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<Longrightarrow> \<theta> = \<theta>'"
         using BS3 r.leg0_is_map composite_with_leg0_is_map by blast
       ultimately show "\<exists>!\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" by blast
     qed
 
     lemma leg1_uniquely_isomorphic:
     shows "r\<^sub>1 \<cong> s\<^sub>1 \<star> w"
     and "\<exists>!\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
     proof -
       show 1: "r\<^sub>1 \<cong> s\<^sub>1 \<star> w"
         using leg1_iso isomorphic_def by auto
       have "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
         using leg1_iso isomorphic_def isomorphic_symmetric by simp
       moreover have "\<And>\<nu> \<nu>'. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<Longrightarrow> \<guillemotleft>\<nu>' : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<Longrightarrow> \<nu> = \<nu>'"
         using BS3 r.leg1_is_map composite_leg1_is_map by blast
       ultimately show "\<exists>!\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" by blast
     qed
 
     definition the_\<theta>
     where "the_\<theta> \<equiv> THE \<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
 
     definition the_\<nu>
     where "the_\<nu> \<equiv> THE \<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
 
     lemma the_\<theta>_props:
     shows "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" and "iso the_\<theta>"
     proof -
       show "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
         unfolding the_\<theta>_def
         using the1I2 [of "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"]
               leg0_uniquely_isomorphic
         by simp
       thus "iso the_\<theta>"
         using BS3 r.leg0_is_map composite_with_leg0_is_map by simp
     qed
 
     lemma the_\<theta>_in_hom [intro]:
     shows "\<guillemotleft>the_\<theta> : src r\<^sub>0 \<rightarrow> trg r\<^sub>0\<guillemotright>"
     and "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
       using the_\<theta>_props apply auto
       by (metis cod_trg in_hhom_def in_homE isomorphic_implies_hpar(3) leg0_uniquely_isomorphic(1)
           src_dom trg.preserves_cod)
 
     lemma the_\<theta>_simps [simp]:
     shows "arr the_\<theta>"
     and "src the_\<theta> = src r\<^sub>0" and "trg the_\<theta> = trg r\<^sub>0"
     and "dom the_\<theta> = s\<^sub>0 \<star> w" and "cod the_\<theta> = r\<^sub>0"
       using the_\<theta>_in_hom by auto
 
     lemma the_\<nu>_props:
     shows "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" and "iso the_\<nu>"
     proof -
       show "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
         unfolding the_\<nu>_def
         using the1I2 [of "\<lambda>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" "\<lambda>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"]
               leg1_uniquely_isomorphic
         by simp
       thus "iso the_\<nu>"
         using BS3 r.leg1_is_map composite_leg1_is_map by simp
     qed
 
     lemma the_\<nu>_in_hom [intro]:
     shows "\<guillemotleft>the_\<nu> : src r\<^sub>1 \<rightarrow> trg r\<^sub>1\<guillemotright>"
     and "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
       using the_\<nu>_props apply auto
       by (metis in_hhom_def in_homE isomorphic_implies_hpar(3) leg1_uniquely_isomorphic(1)
           src_cod trg_dom)
 
     lemma the_\<nu>_simps [simp]:
     shows "arr the_\<nu>"
     and "src the_\<nu> = src r\<^sub>1" and "trg the_\<nu> = trg r\<^sub>1"
     and "dom the_\<nu> = r\<^sub>1" and "cod the_\<nu> = s\<^sub>1 \<star> w"
       using the_\<nu>_in_hom by auto
 
   end
 
   (*
    * TODO: I could probably avoid repeating the declarations of the locale parameters
    * if I was willing to accept them being given in their order of appearance.
    *)
 
   locale arrow_of_spans_of_maps_to_tabulation_data =
     bicategory_of_spans V H \<a> \<i> src trg +
     arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w +
     \<sigma>: tabulation_data V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r\<^sub>0 :: 'a
   and r\<^sub>1 :: 'a
   and s :: 'a
   and \<sigma> :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a
   and w :: 'a
 
   text \<open>
     The following declaration allows us to inherit the rules and other facts defined in
     locale @{locale uw\<theta>}.  It is tedious to prove very much without these in place.
   \<close>
 
   sublocale arrow_of_spans_of_maps_to_tabulation_data \<subseteq> uw\<theta> V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 r\<^sub>0 w the_\<theta>
     using \<sigma>.tab_in_hom is_ide the_\<theta>_props by unfold_locales auto
 
   locale arrow_of_spans_of_maps_to_tabulation =
     arrow_of_spans_of_maps_to_tabulation_data +
     tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
 
   locale tabulation_in_maps =
     span_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1 +
     tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and s :: 'a
   and \<sigma> :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a
 
   sublocale tabulation_in_maps \<subseteq> tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 ..
 
   sublocale identity_in_bicategory_of_spans \<subseteq>
               tabulation_in_maps V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
     using is_ide rep_props by unfold_locales auto
 
   locale cospan_of_maps_in_bicategory_of_spans =
     bicategory_of_spans +
     fixes h :: 'a
     and k :: 'a
     assumes h_is_map: "is_left_adjoint h"
     and k_is_map: "is_left_adjoint k"
     and cospan: "trg h = trg k"
   begin
 
     text \<open>
       The following sublocale declaration is perhaps pushing the limits of sensibility,
       but the purpose is, given a cospan of maps \<open>(h, k)\<close>, to obtain ready access to the
       composite \<open>k\<^sup>* \<star> h\<close> and its chosen tabulation.
     \<close>
 
     sublocale identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close>
       using h_is_map k_is_map cospan left_adjoint_is_ide
       by unfold_locales auto
 
     notation isomorphic  (infix "\<cong>" 50)
 
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     interpretation h: map_in_bicategory V H \<a> \<i> src trg h
       using h_is_map by unfold_locales auto
     interpretation k: map_in_bicategory V H \<a> \<i> src trg k
       using k_is_map by unfold_locales auto
 
     text \<open>
       Our goal here is to reformulate the biuniversal properties of the chosen tabulation
       of \<open>k\<^sup>* \<star> h\<close> in terms of its transpose, which yields a 2-cell from \<open>k \<star> tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
       to \<open>h \<star> tab\<^sub>0 (k\<^sup>* \<star> h)\<close>.  These results do not depend on \<open>BS3\<close>.
     \<close>
 
     abbreviation p\<^sub>0
     where "p\<^sub>0 \<equiv> prj\<^sub>0 h k"
 
     abbreviation p\<^sub>1
     where "p\<^sub>1 \<equiv> prj\<^sub>1 h k"
 
     lemma p\<^sub>0_in_hom [intro]:
     shows "\<guillemotleft>p\<^sub>0 : src p\<^sub>0 \<rightarrow> src h\<guillemotright>"
       by auto
 
     lemma p\<^sub>1_in_hom [intro]:
     shows "\<guillemotleft>p\<^sub>1 : src p\<^sub>0 \<rightarrow> src k\<guillemotright>"
       using prj_in_hom cospan h.ide_left k_is_map by blast
 
     lemma p\<^sub>0_simps [simp]:
     shows "trg p\<^sub>0 = src h"
       by simp
 
     lemma p\<^sub>1_simps [simp]:
     shows "trg p\<^sub>1 = src k"
       using k.antipar(1) by auto
 
     definition \<phi>
     where "\<phi> \<equiv> k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab)"
 
     lemma \<phi>_in_hom [intro]:
     shows "\<guillemotleft>\<phi> : src p\<^sub>0 \<rightarrow> trg h\<guillemotright>"
     and "\<guillemotleft>\<phi> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
     proof -
       show 1: "\<guillemotleft>\<phi> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
         unfolding \<phi>_def
         using k.antipar cospan k.adjoint_transpose_left(2) [of "h \<star> p\<^sub>0" "p\<^sub>1"]
         by fastforce
       show "\<guillemotleft>\<phi> : src p\<^sub>0 \<rightarrow> trg h\<guillemotright>"
         using 1 k.antipar arrI cospan vconn_implies_hpar(1-2) by force
     qed
 
     lemma \<phi>_simps [simp]:
     shows "arr \<phi>"
     and "src \<phi> = src p\<^sub>0" and "trg \<phi> = trg h"
     and "dom \<phi> = k \<star> p\<^sub>1" and "cod \<phi> = h \<star> p\<^sub>0"
       using \<phi>_in_hom by auto
 
     lemma transpose_\<phi>:
     shows "tab = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi>"
     proof -
       have "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi> = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab"
         unfolding \<phi>_def
         using k.antipar cospan
               k.adjoint_transpose_left(4)
                 [of "h \<star> p\<^sub>0" "p\<^sub>1" "\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab"]
         by fastforce
       also have "... = (\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0]) \<cdot> tab"
         using comp_assoc by presburger
       also have "... = tab"
         using k.antipar cospan comp_cod_arr comp_assoc_assoc' by simp
       finally show ?thesis by simp
     qed
 
     lemma transpose_triangle:
     assumes "ide w"
     and "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>" and "\<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright>"
     shows "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>) =
           (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
     proof -
       have u: "ide u"
         using assms(2) by auto
       have v: "ide v"
         using assms(3) by auto
       have 0: "src p\<^sub>0 = trg w"
         by (metis assms(2) hseqE ideD(1) src.preserves_reflects_arr u vconn_implies_hpar(3))
       have 1: "src h = trg u"
         using assms(1-2) 0 trg_dom trg_cod vconn_implies_hpar(4) by auto
       have 2: "src k = trg v"
         using assms(1,3) 0 trg_dom trg_cod hseqI'
         by (metis ideD(1) leg1_simps(2) leg1_simps(3) p\<^sub>1_simps trg_hcomp vconn_implies_hpar(4))
       have 3: "src u = src v \<and> src u = src w"
         using assms 0 k.antipar src_dom src_cod hseqI'
         by (metis ideD(1) leg0_simps(2) leg1_simps(2) leg1_simps(3) src_hcomp
             vconn_implies_hpar(3))
       have 4: "src h = trg \<theta>"
         using assms 1 k.antipar by auto
       define \<chi> where "\<chi> = \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)"
       have \<chi>: "\<guillemotleft>\<chi> : p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> p\<^sub>0 \<star> w\<guillemotright>"
         unfolding \<chi>_def
         using assms 0 k.antipar cospan by (intro comp_in_homI, auto)
       have "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>) =
             k.trnl\<^sub>\<epsilon> (h \<star> u) ((k\<^sup>* \<star> h \<star> \<theta>) \<cdot> \<chi> \<cdot> \<nu>)"
         unfolding \<chi>_def
         using assms 1 k.antipar cospan assoc_naturality [of "k\<^sup>*" h \<theta>] comp_assoc
         by (metis "4" h.ide_left ide_char in_homE k.ide_right)
       also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k\<^sup>* \<star> h \<star> \<theta>) \<cdot> (k \<star> \<chi> \<cdot> \<nu>)"
       proof -
         have "ide (h \<star> u)"
           using "1" u assms h.ide_left by blast
         moreover have "seq (k\<^sup>* \<star> h \<star> \<theta>) (\<chi> \<cdot> \<nu>)"
           using assms 1 k.antipar cospan \<chi> seqI'
           apply (intro seqI)
                   apply auto
             apply blast
         proof -
           have "dom (k\<^sup>* \<star> h \<star> \<theta>) = k\<^sup>* \<star> h \<star> p\<^sub>0 \<star> w"
              using assms
              by (metis "4" cospan hcomp_simps(2-3) h.ide_left hseqI' ide_char in_homE
                  k.antipar(2) k.ide_right) 
           also have "... = cod \<chi>"
              using \<chi> by auto
           finally show "dom (k\<^sup>* \<star> h \<star> \<theta>) = cod \<chi>" by simp
         qed
         moreover have "src k = trg (k\<^sup>* \<star> h \<star> \<theta>)"
           using assms k.antipar cospan calculation(2) by auto
         ultimately show ?thesis
           using k.trnl\<^sub>\<epsilon>_comp by simp
       qed
       also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k\<^sup>* \<star> h \<star> \<theta>) \<cdot> (k \<star> \<chi>) \<cdot> (k \<star> \<nu>)"
         using assms u \<chi> whisker_left
         by (metis k.ide_left seqI')
       also have
         "... = (\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> u] \<cdot> (k \<star> k\<^sup>* \<star> h \<star> \<theta>)) \<cdot> (k \<star> \<chi>) \<cdot> (k \<star> \<nu>)"
         unfolding k.trnl\<^sub>\<epsilon>_def by simp
       also have "... = (h \<star> \<theta>) \<cdot>
                          (\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
                          \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<chi>)) \<cdot>
                          (k \<star> \<nu>)"
       proof -
         have "\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> u] \<cdot> (k \<star> k\<^sup>* \<star> h \<star> \<theta>) =
               \<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
           using assms 4 k.antipar cospan assoc'_naturality [of k "k\<^sup>*" "h \<star> \<theta>"]
           by fastforce
         also have "... = \<l>[h \<star> u] \<cdot> ((k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>)) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
           using comp_assoc by presburger
         also have "... = (\<l>[h \<star> u] \<cdot> (trg k \<star> h \<star> \<theta>)) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
                            \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
         proof -
           have "(k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) = k.\<epsilon> \<cdot> (k \<star> k\<^sup>*) \<star> (h \<star> u) \<cdot> (h \<star> \<theta>)"
             using assms 1 k.antipar cospan interchange comp_arr_dom comp_cod_arr
             by fastforce
           also have "... = k.\<epsilon> \<star> h \<star> \<theta>"
             using assms k.antipar cospan comp_arr_dom comp_cod_arr k.counit_in_hom
                   whisker_left
             by (metis h.ide_left in_homE)
           also have "... = (trg k \<star> h \<star> \<theta>) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)"
             using assms 4 k.antipar cospan whisker_left comp_arr_dom comp_cod_arr
                   interchange [of "trg k" k.\<epsilon> "h \<star> \<theta>" "h \<star> p\<^sub>0 \<star> w"]
             by auto
           finally have "(k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) = (trg k \<star> h \<star> \<theta>) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)"
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
         proof -
           have "\<l>[h \<star> u] \<cdot> (trg k \<star> h \<star> \<theta>) = (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w]"
             using assms 1 4 k.antipar cospan lunit_naturality [of "h \<star> \<theta>"]
             by (metis hcomp_simps(3-4) h.ide_left hseqI' ide_char in_homE trg_hcomp)
           thus ?thesis
             using comp_assoc by presburger
         qed
         finally have "\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> u] \<cdot> (k \<star> k\<^sup>* \<star> h \<star> \<theta>) =
                       (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
                         \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
           by simp
         thus ?thesis
           using comp_assoc by presburger
       qed
       also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
       proof -
         have "\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
                \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)) =
               \<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot>
                (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
                \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
         proof -
           have "\<l>[h \<star> p\<^sub>0 \<star> w] =
                 \<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
           proof -
             have "\<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) =
                   \<a>[h, p\<^sub>0, w] \<cdot> \<ll> ((h \<star> p\<^sub>0) \<star> w) \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
               using assms 0 k.antipar cospan comp_cod_arr \<ll>_ide_simp by simp
             also have "... = \<a>[h, p\<^sub>0, w] \<cdot> \<ll> (\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
               using assms 0 k.antipar cospan \<ll>.is_natural_2 [of "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"] by simp
             also have "... = \<a>[h, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w] \<cdot> \<ll> (h \<star> p\<^sub>0 \<star> w)"
               using assms 0 k.antipar cospan \<ll>.is_natural_1 [of "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"] comp_assoc
               by simp
             also have "... = (\<a>[h, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<ll> (h \<star> p\<^sub>0 \<star> w)"
               using comp_assoc by presburger
             also have "... = \<ll> (h \<star> p\<^sub>0 \<star> w)"
               using assms 0 k.antipar cospan comp_cod_arr comp_assoc_assoc' by simp
             also have "... = \<l>[h \<star> p\<^sub>0 \<star> w]"
               using assms 0 k.antipar cospan \<ll>_ide_simp by simp
             finally show ?thesis by simp
           qed
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
                \<a>\<^sup>-\<^sup>1[trg h, h \<star> p\<^sub>0, w] \<cdot>
                ((trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)) \<cdot>
                \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
           using assms 0 k.antipar cospan lunit_hcomp comp_assoc by simp
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
                (\<a>\<^sup>-\<^sup>1[trg h, h \<star> p\<^sub>0, w] \<cdot> (k.\<epsilon> \<star> (h \<star> p\<^sub>0) \<star> w)) \<cdot>
                ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
         proof -
           have "(trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) =
                 (k.\<epsilon> \<star> (h \<star> p\<^sub>0) \<star> w) \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
             using assms 0 k.antipar cospan comp_arr_dom comp_cod_arr
                   interchange [of "trg h" k.\<epsilon> "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]" "h \<star> p\<^sub>0 \<star> w"]
                   interchange [of k.\<epsilon> "k \<star> k\<^sup>*" "(h \<star> p\<^sub>0) \<star> w" "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"]
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
                ((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> 
                ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
           using assms 0 k.antipar cospan assoc'_naturality [of k.\<epsilon> "h \<star> p\<^sub>0" w] comp_assoc
           by simp
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
                            ((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> 
                            ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                            (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot>
                            (k \<star> tab \<star> w)"
         proof -
           have "k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) =
                 (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot>
                 (k \<star> tab \<star> w)"
           proof -
             have "seq \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] (\<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
               using \<chi>_def assms 0 k.antipar cospan \<chi> by blast
             thus ?thesis
               using assms 0 k.antipar cospan whisker_left by auto
           qed
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
                            ((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> 
                            ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                            (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot>
                            \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w]) \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
         proof -
           have "k \<star> tab \<star> w = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> (k \<star> tab \<star> w)"
           proof -
             have "\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> (k \<star> tab \<star> w) =
                   (\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w]) \<cdot> (k \<star> tab \<star> w)"
               using comp_assoc by presburger
             also have "... = (k \<star> ((k\<^sup>* \<star> h) \<star> p\<^sub>0) \<star> w) \<cdot> (k \<star> tab \<star> w)"
                using assms k.antipar 0 comp_assoc_assoc' by simp
             also have "... = k \<star> tab \<star> w"
                using assms k.antipar 0 comp_cod_arr by simp
             finally show ?thesis by simp
           qed
           also have "... = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
             using assms 0 k.antipar cospan assoc'_naturality [of k tab w] by simp
           finally have "k \<star> tab \<star> w = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
                            ((k.\<epsilon> \<star> h \<star> p\<^sub>0) \<star> w) \<cdot>
                            (\<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<star> w) \<cdot>
                            ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
         proof -
           have "\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot>
                   \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot>
                   (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot> \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] =
                 \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<star> w"
           proof -
             have "\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot>
                     \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w]) \<cdot>
                     (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot> \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] =
                   \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> ((\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                     \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                     (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, (\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using assms 0 k.antipar cospan \<alpha>_def \<a>'_def by simp
             also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                                 (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
               using assms 0 k.antipar cospan
               by (intro E.eval_eqI, simp_all)
             also have "... = \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<star> w"
               using assms 0 k.antipar cospan \<alpha>_def \<a>'_def by simp
             finally show ?thesis by simp
           qed
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot>
                            (\<l>[h \<star> p\<^sub>0] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0) \<cdot>
                            \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0]) \<cdot>
                            (k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
           using assms 0 k.antipar cospan comp_assoc whisker_right by auto
         also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
           unfolding \<phi>_def k.trnl\<^sub>\<epsilon>_def
           using assms 0 k.antipar cospan comp_assoc whisker_left by simp
         finally have "\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
                \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
                (k \<star> \<a>[k\<^sup>*, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)) =
                       \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
           by blast
         thus ?thesis
           using \<chi>_def comp_assoc by simp
       qed
       finally show ?thesis by simp
     qed
 
     text \<open>
       \<open>BS3\<close> implies that \<open>\<phi>\<close> is the unique 2-cell from \<open>k \<star> p\<^sub>1\<close> to \<open>h \<star> p\<^sub>0\<close> and is an isomorphism.
     \<close>
 
     lemma \<phi>_uniqueness:
     shows "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright> \<Longrightarrow> \<mu> = \<phi>" and "iso \<phi>"
     proof -
       have 2: "is_left_adjoint (k \<star> p\<^sub>1)"
         using k.antipar cospan left_adjoints_compose by (simp add: k_is_map)
       have 3: "is_left_adjoint (h \<star> p\<^sub>0)"
         using k.antipar cospan left_adjoints_compose by (simp add: h_is_map)
       show "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright> \<Longrightarrow> \<mu> = \<phi>"
         using \<phi>_in_hom 2 3 BS3 by simp
       show "iso \<phi>"
         using \<phi>_in_hom 2 3 BS3 by simp
     qed
 
     text \<open>
       As a consequence, the chosen tabulation of \<open>k\<^sup>* \<star> h\<close> is the unique 2-cell from
       \<open>p\<^sub>1\<close> to \<open>(k\<^sup>* \<star> h) \<star> p\<^sub>0\<close>, and therefore if we are given any such 2-cell we may
       conclude it yields a tabulation of \<open>k\<^sup>* \<star> h\<close>.
     \<close>
 
     lemma tab_uniqueness:
     assumes "\<guillemotleft>\<tau> : p\<^sub>1 \<Rightarrow> (k\<^sup>* \<star> h) \<star> p\<^sub>0\<guillemotright>"
     shows "\<tau> = tab"
     proof -
       have "\<guillemotleft>k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>) : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
         using assms k.antipar cospan k.adjoint_transpose_left(2) [of "h \<star> p\<^sub>0" "p\<^sub>1"]
               assoc_in_hom
         by force
       hence "tab = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 (k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>))"
         using transpose_\<phi> \<phi>_uniqueness(1) by auto
       also have "... = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>"
         using assms k.antipar cospan k.adjoint_transpose_left(4) assoc_in_hom by auto
       also have "... = (\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>*, h, p\<^sub>0]) \<cdot> \<tau>"
         using comp_assoc by presburger
       also have "... = \<tau>"
         using assms k.antipar cospan comp_cod_arr comp_assoc_assoc' by auto
       finally show ?thesis by simp
     qed
 
     text \<open>
       The following lemma reformulates the biuniversal property of the canonical tabulation
       of \<open>k\<^sup>* \<star> h\<close> as a biuniversal property of \<open>\<phi>\<close>, regarded as a square that commutes up to
       isomorphism.
     \<close>
 
     lemma \<phi>_biuniversal_prop:
     assumes "ide u" and "ide v"
     shows "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright> \<Longrightarrow>
                 \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                         (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
     and "\<And>w w' \<theta> \<theta>' \<beta>.
             \<lbrakk> ide w; ide w';
               \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>;
               \<guillemotleft>\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>;
               (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
               (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>) \<rbrakk>
                     \<Longrightarrow> \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<beta>"
     proof -
       fix \<mu>
       assume \<mu>: "\<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright>"
       have 1: "src h = trg u"
         using assms \<mu> ide_cod
         by (metis ide_def in_homE seq_if_composable)
       have 2: "src k = trg v"
         using assms \<mu> ide_dom
         by (metis ideD(1) in_homE not_arr_null seq_if_composable)
       let ?\<omega> = "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u] \<cdot> k.trnl\<^sub>\<eta> v \<mu>"
       have \<omega>: "\<guillemotleft>?\<omega> : v \<Rightarrow> (k\<^sup>* \<star> h) \<star> u\<guillemotright>"
         using assms \<mu> 1 2 k.antipar cospan k.adjoint_transpose_left(1) [of "h \<star> u" v]
               assoc_in_hom
         by auto
       obtain w \<theta> \<nu>
       where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                   ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = ?\<omega>"
         using assms \<omega> T1 [of u ?\<omega>] comp_assoc by (metis in_homE)
       have 0: "src p\<^sub>0 = trg w"
         using w\<theta>\<nu> ide_dom
         by (metis hseqE ideD(1) in_homE)
       have "\<mu> = k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>)"
       proof -
         have "\<mu> = k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ?\<omega>)"
         proof -
           have "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ?\<omega>) =
                 k.trnl\<^sub>\<epsilon> (h \<star> u) ((\<a>[k\<^sup>*, h, u] \<cdot> \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u]) \<cdot> k.trnl\<^sub>\<eta> v \<mu>)"
             using comp_assoc by presburger
           also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k.trnl\<^sub>\<eta> v \<mu>)"
           proof -
             have "(\<a>[k\<^sup>*, h, u] \<cdot> \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u]) \<cdot> k.trnl\<^sub>\<eta> v \<mu> = (k\<^sup>* \<star> h \<star> u) \<cdot> k.trnl\<^sub>\<eta> v \<mu>"
               using comp_assoc_assoc'
               by (simp add: "1" assms(1) cospan k.antipar(2))
             also have "... = k.trnl\<^sub>\<eta> v \<mu>"
               using "1" \<omega> assms(1) comp_ide_arr cospan k.antipar(2) by fastforce
             finally show ?thesis
               by simp
           qed
           also have "... = \<mu>"
             using assms \<mu> k.antipar cospan 1 2 k.adjoint_transpose_left(3) by simp
           finally show ?thesis by simp
         qed
         thus ?thesis using w\<theta>\<nu> by simp
       qed
       also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
         using assms k.antipar cospan w\<theta>\<nu> transpose_triangle [of w \<theta> u \<nu>] by auto
       finally have "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
         by simp
       thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and>
                     \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                     (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot>
                       \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
         using w\<theta>\<nu> by blast
       next
       fix w w' \<theta> \<theta>' \<beta>
       assume w: "ide w"
       assume w': "ide w'"
       assume \<theta>: "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
       assume \<theta>': "\<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
       assume \<beta>: "\<guillemotleft>\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>"
       assume eq: "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
                   (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>)"
       have 0: "src p\<^sub>0 = trg w"
         using \<theta> ide_dom
         by (metis ideD(1) in_homE not_arr_null seq_if_composable)
       interpret uw\<theta>w'\<theta>': uw\<theta>w'\<theta>' V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close>
                              u w \<theta> w' \<theta>'
         using w \<theta> w' \<theta>' apply (unfold_locales) by auto
       show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<beta>"
       proof -
         let ?LHS = "\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)"
         let ?RHS = "\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>') \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w'] \<cdot> (tab \<star> w') \<cdot> \<beta>"
         have eq': "?LHS = ?RHS"
         proof -
           have "k.trnl\<^sub>\<epsilon> (h \<star> u) ?LHS =
                 k.trnl\<^sub>\<epsilon> (h \<star> u)
                         (\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> (p\<^sub>1 \<star> w))"
             using assms 0 w \<theta> \<beta> k.antipar cospan comp_arr_dom
             by (metis tab_simps(1) tab_simps(4) whisker_right)
           also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> p\<^sub>1 \<star> w)"
             using assms w \<theta> \<beta> transpose_triangle
             by (metis arr_dom ide_hcomp ide_in_hom(2) in_homE ide_leg1 not_arr_null
                 seq_if_composable)
           also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
             using assms 0 w k.antipar cospan comp_arr_dom by simp
           also have "... = (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>)"
             using eq by blast
           also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) ?RHS"
             using assms w' \<theta>' \<beta> transpose_triangle by simp
           finally have 4: "k.trnl\<^sub>\<epsilon> (h \<star> u) ?LHS = k.trnl\<^sub>\<epsilon> (h \<star> u) ?RHS"
             by simp
           have "src k = trg (p\<^sub>1 \<star> w)"
             using assms 0 w k.antipar cospan by simp
           moreover have "src k\<^sup>* = trg (h \<star> u)"
             using assms 0 w k.antipar cospan by simp
           moreover have "ide (h \<star> u)"
             using assms 0 w k.antipar cospan by simp
           moreover have "ide (p\<^sub>1 \<star> w)"
             using assms 0 w k.antipar cospan by simp
           ultimately have "inj_on (k.trnl\<^sub>\<epsilon> (h \<star> u)) (hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u))"
             using assms 0 w w' k.antipar cospan k.adjoint_transpose_left(6) bij_betw_imp_inj_on
             by blast
           moreover have "?LHS \<in> hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"
           proof -
             have "\<guillemotleft>\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) :
                      p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> u\<guillemotright>"
               using k.antipar cospan
               apply (intro comp_in_homI) by auto
             thus ?thesis by simp
           qed
           moreover have "?RHS \<in> hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"
           proof -
             have "\<guillemotleft>\<a>[k\<^sup>*, h, u] \<cdot> ((k\<^sup>* \<star> h) \<star> \<theta>') \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w'] \<cdot>
                     (tab \<star> w') \<cdot> \<beta> : p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> u\<guillemotright>"
               using \<beta> k.antipar cospan
               apply (intro comp_in_homI) by auto
             thus ?thesis by blast
           qed
           ultimately show "?LHS = ?RHS"
             using assms 4 k.antipar cospan bij_betw_imp_inj_on
                   inj_on_def [of "k.trnl\<^sub>\<epsilon> (h \<star> u)" "hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"]
             by simp
         qed
         moreover have "seq \<a>[k\<^sup>*, h, u] (composite_cell w \<theta>)"
           using assms k.antipar cospan tab_in_hom by fastforce
         moreover have "seq \<a>[k\<^sup>*, h, u] (composite_cell w' \<theta>' \<cdot> \<beta>)"
           using assms \<beta> k.antipar cospan tab_in_hom by fastforce
         ultimately have "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
           using assms 0 w w' \<beta> k.antipar cospan iso_assoc iso_is_section section_is_mono
                 monoE [of "\<a>[k\<^sup>*, h, u]" "composite_cell w \<theta>" "composite_cell w' \<theta>' \<cdot> \<beta>"]
                 comp_assoc
           by simp
         thus ?thesis
           using w w' \<theta> \<theta>' \<beta> eq' T2 [of w w' \<theta> u \<theta>' \<beta>] by metis
       qed
     qed
 
     text \<open>
       Using the uniqueness properties established for \<open>\<phi>\<close>, we obtain yet another reformulation
       of the biuniversal property associated with the chosen tabulation of \<open>k\<^sup>* \<star> h\<close>,
       this time as a kind of pseudo-pullback.  We will use this to show that the
       category of isomorphism classes of maps has pullbacks.
     \<close>
 
     lemma has_pseudo_pullback:
     assumes "is_left_adjoint u" and "is_left_adjoint v" and "isomorphic (k \<star> v) (h \<star> u)"
     shows "\<exists>w. is_left_adjoint w \<and> isomorphic (p\<^sub>0 \<star> w) u \<and> isomorphic v (p\<^sub>1 \<star> w)"
     and "\<And>w w'. \<lbrakk> is_left_adjoint w; is_left_adjoint w';
                   p\<^sub>0 \<star> w \<cong> u; v \<cong> p\<^sub>1 \<star> w; p\<^sub>0 \<star> w' \<cong> u; v \<cong> p\<^sub>1 \<star> w' \<rbrakk> \<Longrightarrow> w \<cong> w'"
     proof -
       interpret u: map_in_bicategory V H \<a> \<i> src trg u
         using assms(1) by unfold_locales auto
       interpret v: map_in_bicategory V H \<a> \<i> src trg v
         using assms(2) by unfold_locales auto
       obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright> \<and> iso \<mu>"
         using assms(3) by auto
       obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and>
                                \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                                (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
         using assms \<mu> \<phi>_biuniversal_prop(1) [of u v \<mu>] by auto
       have "is_left_adjoint w \<and> isomorphic (p\<^sub>0 \<star> w) u \<and> isomorphic v (p\<^sub>1 \<star> w)"
       proof (intro conjI)
         show 1: "is_left_adjoint w"
           using assms(2) w\<theta>\<nu> left_adjoint_preserved_by_iso' isomorphic_def BS4 leg1_is_map
           by blast
         show "v \<cong> p\<^sub>1 \<star> w"
           using w\<theta>\<nu> isomorphic_def by blast
         show "p\<^sub>0 \<star> w \<cong> u"
         proof -
           have "src p\<^sub>0 = trg w"
             using w\<theta>\<nu> ide_dom
             by (metis ideD(1) in_homE not_arr_null seq_if_composable)
           hence "is_left_adjoint (p\<^sub>0 \<star> w)"
             using 1 left_adjoints_compose by simp
           thus ?thesis
             using assms w\<theta>\<nu> 1 BS3 isomorphic_def by metis
         qed
       qed
       thus "\<exists>w. is_left_adjoint w \<and> p\<^sub>0 \<star> w \<cong> u \<and> v \<cong> p\<^sub>1 \<star> w"
         by blast
       show "\<And>w w'. \<lbrakk> is_left_adjoint w; is_left_adjoint w';
                      p\<^sub>0 \<star> w \<cong> u; v \<cong> p\<^sub>1 \<star> w; p\<^sub>0 \<star> w' \<cong> u; v \<cong> p\<^sub>1 \<star> w' \<rbrakk> \<Longrightarrow> w \<cong> w'"
       proof -
         fix w w'
         assume w: "is_left_adjoint w" and w': "is_left_adjoint w'"
         assume 1: "p\<^sub>0 \<star> w \<cong> u"
         assume 2: "v \<cong> p\<^sub>1 \<star> w"
         assume 3: "p\<^sub>0 \<star> w' \<cong> u"
         assume 4: "v \<cong> p\<^sub>1 \<star> w'"
         obtain \<theta> where \<theta>: "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
           using 1 by auto
         obtain \<theta>' where \<theta>': "\<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
           using 3 by auto
         obtain \<nu> where \<nu>: "\<guillemotleft>\<nu>: v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
           using 2 by blast
         obtain \<nu>' where \<nu>': "\<guillemotleft>\<nu>': v \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>'"
           using 4 by blast
         let ?\<beta> = "\<nu>' \<cdot> inv \<nu>"
         have \<beta>: "\<guillemotleft>?\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>"
           using \<nu> \<nu>' by (elim conjE in_homE, auto)
         interpret uw\<theta>: uw\<theta> V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close> u w \<theta>
           using w \<theta> left_adjoint_is_ide
           by unfold_locales auto
         interpret uw'\<theta>': uw\<theta> V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close>
                              u w' \<theta>'
           using w' \<theta>' left_adjoint_is_ide
           by unfold_locales auto
         interpret uw\<theta>w'\<theta>': uw\<theta>w'\<theta>' V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close> u w \<theta> w' \<theta>'
           using w w' \<theta> \<theta>' left_adjoint_is_ide by unfold_locales
         have "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
               (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot>
                 (k \<star> ?\<beta>)"
         proof -
           let ?LHS = "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
           let ?RHS = "(h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> ?\<beta>)"
           have "\<guillemotleft>?LHS : k \<star> p\<^sub>1 \<star> w \<Rightarrow> h \<star> u\<guillemotright>"
             using w k.antipar by fastforce
           moreover have "\<guillemotleft>?RHS : k \<star> p\<^sub>1 \<star> w \<Rightarrow> h \<star> u\<guillemotright>"
             using w k.antipar \<beta> by fastforce
           moreover have "is_left_adjoint (k \<star> p\<^sub>1 \<star> w)"
             using w k.is_map left_adjoints_compose by simp
           moreover have "is_left_adjoint (h \<star> u)"
             using assms h.is_map left_adjoints_compose by auto
           ultimately show "?LHS = ?RHS"
             using BS3 by blast
         qed
         hence "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = ?\<beta>"
           using assms left_adjoint_is_ide w w' \<theta> \<theta>' \<nu> \<nu>' \<beta>
                 \<phi>_biuniversal_prop(2) [of u v w w' \<theta> \<theta>' ?\<beta>]
           by presburger
         thus "w \<cong> w'"
           using w w' BS3 isomorphic_def by metis
       qed
     qed
 
   end
 
   subsubsection "Tabulations in Maps"
 
   text \<open>
     Here we focus our attention on the properties of tabulations in a bicategory of spans,
     in the special case in which both legs are maps.
   \<close>
 
   context tabulation_in_maps
   begin
 
     text \<open>
       The following are the conditions under which \<open>w\<close> is a 1-cell induced via \<open>T1\<close> by
       a 2-cell \<open>\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>\<close>:  \<open>w\<close> is an arrow of spans and \<open>\<omega>\<close> is obtained by
       composing the tabulation \<open>\<sigma>\<close> with \<open>w\<close> and the isomorphisms that witness \<open>w\<close> being
       an arrow of spans.
     \<close>
 
     abbreviation is_induced_by_cell
     where "is_induced_by_cell w r\<^sub>0 \<omega> \<equiv>
            arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<omega>) s\<^sub>0 s\<^sub>1 w \<and>
            composite_cell w (arrow_of_spans_of_maps.the_\<theta> V H r\<^sub>0 s\<^sub>0 w) \<cdot>
              (arrow_of_spans_of_maps.the_\<nu> V H (dom \<omega>) s\<^sub>1 w) = \<omega>"
 
     lemma induced_map_unique:
     assumes "is_induced_by_cell w r\<^sub>0 \<omega>" and "is_induced_by_cell w' r\<^sub>0 \<omega>"
     shows "isomorphic w w'"
     proof -
       interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s\<^sub>0 s\<^sub>1 w
         using assms(1) by auto
       interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w
         ..
       interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s\<^sub>0 s\<^sub>1 w'
         using assms(2) by auto
       interpret w': arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w'
         ..
       let ?\<beta> = "w'.the_\<nu> \<cdot> inv w.the_\<nu>"
       have \<beta>: "\<guillemotleft>?\<beta> : s\<^sub>1 \<star> w \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
         using w.the_\<nu>_props w'.the_\<nu>_props arr_iff_in_hom by auto
       have 1: "composite_cell w w.the_\<theta> = composite_cell w' w'.the_\<theta> \<cdot> (w'.the_\<nu> \<cdot> inv w.the_\<nu>)"
       proof -
         have "composite_cell w' w'.the_\<theta> \<cdot> (w'.the_\<nu> \<cdot> inv w.the_\<nu>) =
               ((composite_cell w' w'.the_\<theta>) \<cdot> w'.the_\<nu>) \<cdot> inv w.the_\<nu>"
           using comp_assoc by presburger
         also have "... = \<omega> \<cdot> inv w.the_\<nu>"
           using assms(2) comp_assoc by simp
         also have "... = (composite_cell w w.the_\<theta> \<cdot> w.the_\<nu>) \<cdot> inv w.the_\<nu>"
           using assms(1) comp_assoc by simp
         also have "... = composite_cell w w.the_\<theta> \<cdot> w.the_\<nu> \<cdot> inv w.the_\<nu>"
           using comp_assoc by presburger
         also have "... = composite_cell w w.the_\<theta>"
         proof -
           have "w.the_\<nu> \<cdot> inv w.the_\<nu> = s\<^sub>1 \<star> w"
             using w.the_\<nu>_props comp_arr_inv inv_is_inverse by auto
           thus ?thesis
             using composite_cell_in_hom w.ide_w w.the_\<theta>_props comp_arr_dom
             by (metis composite_cell_in_hom in_homE w.w_in_hom(1))
         qed
         finally show ?thesis by auto
       qed
       have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
         using 1 \<beta> w.is_ide w'.is_ide w.the_\<theta>_props w'.the_\<theta>_props
               T2 [of w w' w.the_\<theta> r\<^sub>0 w'.the_\<theta> ?\<beta>]
         by blast
       thus ?thesis
         using BS3 w.is_map w'.is_map by blast
     qed
 
     text \<open>
       The object src \<open>s\<^sub>0\<close> forming the apex of the tabulation satisfies the conditions for
       being a map induced via \<open>T1\<close> by the 2-cell \<open>\<sigma>\<close> itself.  This is ultimately required
       for the map from 2-cells to arrows of spans to be functorial with respect to vertical
       composition.
     \<close>
 
     lemma apex_is_induced_by_cell:
     shows "is_induced_by_cell (src s\<^sub>0) s\<^sub>0 \<sigma>"
     proof -
       have 1: "arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1 s\<^sub>0 s\<^sub>1 (src s\<^sub>0)"
         using iso_runit [of s\<^sub>0] iso_runit [of s\<^sub>1] tab_in_hom
         apply unfold_locales
           apply simp
         using ide_leg0 isomorphic_def
          apply blast
         using ide_leg1 isomorphic_def leg1_simps(3) runit'_in_vhom [of s\<^sub>1 "src s\<^sub>0"] iso_runit'
         by blast
       interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 \<open>dom \<sigma>\<close> s\<^sub>0 s\<^sub>1 \<open>src s\<^sub>0\<close>
         using 1 tab_in_hom by simp
       interpret w: arrow_of_spans_of_maps_to_tabulation
                      V H \<a> \<i> src trg s\<^sub>0 \<open>dom \<sigma>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 \<open>src s\<^sub>0\<close>
         ..
       show "is_induced_by_cell (src s\<^sub>0) s\<^sub>0 \<sigma>"
       proof (intro conjI)
         show "arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 (dom \<sigma>) s\<^sub>0 s\<^sub>1 (src s\<^sub>0)"
           using w.arrow_of_spans_of_maps_axioms by simp
         show "composite_cell (src s\<^sub>0) w.the_\<theta> \<cdot> w.the_\<nu> = \<sigma>"
         proof -
           have \<theta>: "w.the_\<theta> = \<r>[s\<^sub>0]"
             using iso_runit [of s\<^sub>0] w.leg0_uniquely_isomorphic w.the_\<theta>_props
                   the1_equality [of "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> src s\<^sub>0 \<Rightarrow> s\<^sub>0\<guillemotright> \<and> iso \<theta>"]
             by auto
           have \<nu>: "w.the_\<nu> = \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
             using iso_runit' w.leg1_uniquely_isomorphic w.the_\<nu>_props leg1_simps(3)
                   the1_equality [of "\<lambda>\<nu>. \<guillemotleft>\<nu> : s\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> src s\<^sub>0\<guillemotright> \<and> iso \<nu>"] tab_in_vhom'
             by auto
           have "composite_cell (src s\<^sub>0) \<r>[s\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1] = \<sigma>"
           proof -
             have "composite_cell (src s\<^sub>0) \<r>[s\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1] =
                   ((s \<star> \<r>[s\<^sub>0]) \<cdot> \<a>[s, s\<^sub>0, src s\<^sub>0]) \<cdot> (\<sigma> \<star> src s\<^sub>0) \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
               using comp_assoc by presburger
             also have "... = (\<r>[s \<star> s\<^sub>0] \<cdot> (\<sigma> \<star> src s\<^sub>0)) \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
               using runit_hcomp comp_assoc by simp
             also have "... = \<sigma> \<cdot> \<r>[s\<^sub>1] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
               using runit_naturality tab_in_hom
               by (metis tab_simps(1) tab_simps(2) tab_simps(4) tab_simps(5) comp_assoc)
             also have "... = \<sigma>"
               using iso_runit tab_in_hom comp_arr_dom comp_arr_inv inv_is_inverse by simp
             finally show ?thesis by simp
           qed
           thus ?thesis
             using \<theta> \<nu> comp_assoc by simp
         qed
       qed
     qed
 
   end
 
   subsubsection "Composing Tabulations"
 
   text \<open>
     Given tabulations \<open>(r\<^sub>0, \<rho>, r\<^sub>1)\<close> of \<open>r\<close> and \<open>(s\<^sub>0, \<sigma>, s\<^sub>1)\<close> of \<open>s\<close> in a bicategory of spans,
     where \<open>(r\<^sub>0, r\<^sub>1)\<close> and \<open>(s\<^sub>0, s\<^sub>1)\<close> are spans of maps and 1-cells \<open>r\<close> and \<open>s\<close> are composable,
     we can construct a 2-cell that yields a tabulation of \<open>r \<star> s\<close>.
     The proof uses the fact that the 2-cell \<open>\<phi>\<close> associated with the cospan \<open>(r\<^sub>0, s\<^sub>1)\<close>
     is an isomorphism, which we have proved above
     (\<open>cospan_of_maps_in_bicategory_of_spans.\<phi>_uniqueness\<close>) using \<open>BS3\<close>.
     However, this is the only use of \<open>BS3\<close> in the proof, and it seems plausible that it would be
     possible to establish that \<open>\<phi>\<close> is an isomorphism in more general situations in which the
     subbicategory of maps is not locally essentially discrete.  Alternatively, more general
     situations could be treated by adding the assertion that \<open>\<phi>\<close> is an isomorphism as part of
     a weakening of \<open>BS3\<close>.
   \<close>
 
   locale composite_tabulation_in_maps =
     bicategory_of_spans V H \<a> \<i> src trg +
     \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
     \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r :: 'a
   and \<rho> :: 'a
   and r\<^sub>0 :: 'a
   and r\<^sub>1 :: 'a
   and s :: 'a
   and \<sigma> :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a +
   assumes composable: "src r = trg s"
   begin
 
     text \<open>
       Interpret \<open>(r\<^sub>0, s\<^sub>1)\<close> as a @{locale cospan_of_maps_in_bicategory_of_spans},
       to obtain the isomorphism \<open>\<phi>\<close> in the central diamond, along with the assertion
       that it is unique.
     \<close>
     interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0
       using \<rho>.leg0_is_map \<sigma>.leg1_is_map composable by unfold_locales auto
 
     text \<open>
       We need access to simps, etc. in the preceding interpretation, yet trying to declare
       it as a sublocale introduces too many conflicts at the moment.
       As it confusing elsewhere to figure out exactly how, in other contexts, to express
       the particular interpretation that is needed, to make things easier we include the
       following lemma.  Then we can just recall the lemma to find out how to express
       the interpretation required in a given context.
     \<close>
 
     lemma r\<^sub>0s\<^sub>1_is_cospan:
     shows "cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0"
       ..
 
     text \<open>
       The following define the projections associated with the natural tabulation of \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>.
     \<close>
 
     abbreviation p\<^sub>0
     where "p\<^sub>0 \<equiv> r\<^sub>0s\<^sub>1.p\<^sub>0"
 
     abbreviation p\<^sub>1
     where "p\<^sub>1 \<equiv> r\<^sub>0s\<^sub>1.p\<^sub>1"
 
     text \<open>
 $$
 \xymatrix{
   && {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 $$
     \<close>
 
     text \<open>
       Next, we define the 2-cell that is the composite of the tabulation \<open>\<sigma>\<close>, the tabulation \<open>\<rho>\<close>,
       and the central diamond that commutes up to unique isomorphism \<open>\<phi>\<close>.
     \<close>
 
     definition tab
     where "tab \<equiv> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
                    (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1)"
 
     lemma tab_in_hom [intro]:
     shows "\<guillemotleft>tab : r\<^sub>1 \<star> p\<^sub>1 \<Rightarrow> (r \<star> s) \<star> s\<^sub>0 \<star> p\<^sub>0\<guillemotright>"
       using \<rho>.T0.antipar(1) r\<^sub>0s\<^sub>1.\<phi>_in_hom composable \<rho>.leg0_in_hom(1) \<sigma>.leg1_in_hom(1)
             composable tab_def
       by auto
 
     interpretation tabulation_data V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
       using composable tab_in_hom
       by unfold_locales auto
 
     text \<open>
       In the subsequent proof we will use coherence to shortcut a few of the calculations.
     \<close>
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     text \<open>
       The following is applied twice in the proof of property \<open>T2\<close> for the composite
       tabulation.  It's too long to repeat.
     \<close>
 
     lemma technical:
     assumes "ide w"
     and "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
     and "w\<^sub>r = p\<^sub>1 \<star> w"
     and "\<theta>\<^sub>r = (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
                 (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
     shows "\<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r = \<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
     text \<open>
 $$
 \xymatrix{
   && X \ar[d]^{w} \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta}} \\
   && {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 $$
     \<close>
     proof -
       interpret uw\<theta>: uw\<theta> V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close> u w \<theta>
         using assms(1-2) composable
         by unfold_locales auto
       show ?thesis
       proof -
         have "\<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
               (\<a>[r, s, u] \<cdot> ((r \<star> s) \<star> \<theta>)) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
           using comp_assoc by presburger
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> \<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
           using assoc_naturality [of r s \<theta>] composable comp_assoc by simp
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> \<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            ((\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
                            \<rho>.composite_cell p\<^sub>1 r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
           unfolding tab_def
           using comp_assoc by presburger
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
                            ((r \<star> \<sigma> \<star> p\<^sub>0) \<cdot> \<rho>.composite_cell p\<^sub>1 r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                            \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
           using composable \<rho>.T0.antipar(1) comp_assoc whisker_right by auto
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
                            ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
                             (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
           using composable \<rho>.T0.antipar(1) whisker_right tab_def tab_in_hom(2)
                 composable comp_assoc
           by force
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
                            ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
                            ((\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]) \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
           using assoc'_naturality [of \<rho> p\<^sub>1 w] \<rho>.T0.antipar(1) r\<^sub>0s\<^sub>1.base_simps(2) comp_assoc
           by auto
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
                            ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
                            \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w]) \<cdot> \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
         proof -
           have "(\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
                  \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
           proof -
             have "(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) =
                   \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1 \<star> w]"
               using pentagon' \<rho>.T0.antipar(1) comp_assoc by simp
             moreover have 1: "seq (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w)(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]))"
               using \<rho>.T0.antipar(1)
               by (intro seqI hseqI, auto)
             ultimately
             have "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
                    ((\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
                      \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
               using \<rho>.T0.antipar(1) iso_assoc
                     invert_side_of_triangle(2)
                       [of "(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])"
                           "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]" "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1 \<star> w]"]
               by fastforce
             hence "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
                    (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
                      \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
               using comp_assoc by presburger
             moreover have "seq (inv (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w)) \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
               using \<rho>.T0.antipar(1) 1 by fastforce
             ultimately show ?thesis
               using \<rho>.T0.antipar(1) iso_assoc
                     invert_side_of_triangle(1)
                       [of "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]" "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w"
                           "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"]
               by fastforce
           qed
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
                            (((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w]) \<cdot>
                            (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
         proof -
           have "((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] = \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w] \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
             using assoc'_naturality [of r r\<^sub>0s\<^sub>1.\<phi> w] r\<^sub>0s\<^sub>1.cospan by auto
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (r \<star> s \<star> \<theta>) \<cdot>
                            (\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                              (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w]) \<cdot>
                            (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
         proof -
           have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w] =
                 \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w)"
             using assoc'_naturality [of r "\<sigma> \<star> p\<^sub>0" w]
             by (simp add: composable)
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (r \<star> s \<star> \<theta>) \<cdot>
                            (r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
                            ((r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
                            \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
         proof -
           have "\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                   (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] =
                 r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]"
           proof -
             have "\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
                     (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] =
                   \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, (\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                     (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot>
                     \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using \<alpha>_def \<a>'_def composable by simp
             also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                                 \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using composable
               by (intro E.eval_eqI, simp_all)
             also have "... = r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]"
               using \<alpha>_def \<a>'_def composable by simp
             finally show ?thesis by simp
           qed
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (r \<star> s \<star> \<theta>) \<cdot>
                            (r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
                            \<rho>.composite_cell (p\<^sub>1 \<star> w)
                              (((\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])"
           using assms(3) arrI \<rho>.T0.antipar(1) whisker_left by auto
         also have "... = (r \<star> (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
                               (\<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot> ((\<sigma> \<star> p\<^sub>0) \<star> w)) \<cdot>
                               (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
                            \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
           using \<rho>.T0.antipar(1) comp_assoc whisker_left by auto
         also have "... = (r \<star> (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
                               (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                               (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
                            \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
           using assoc_naturality [of \<sigma> p\<^sub>0 w] comp_assoc by simp
         finally show ?thesis
           using assms(3-4) by simp
       qed
     qed
 
     lemma composite_is_tabulation:
     shows "tabulation V H \<a> \<i> src trg (r \<star> s) tab (s\<^sub>0 \<star> p\<^sub>0) (r\<^sub>1 \<star> p\<^sub>1)"
     proof
       show "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> (r \<star> s) \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
                    \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright> \<and>
                            \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                            composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
       proof -
         fix u \<omega>
         assume u: "ide u"
         assume \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> (r \<star> s) \<star> u\<guillemotright>"
         let ?v = "dom \<omega>"
         have 1: "\<guillemotleft>\<a>[r, s, u] \<cdot> \<omega> : ?v \<Rightarrow> r \<star> s \<star> u\<guillemotright>"
         proof -
           (*
            * TODO: I think this highlights the current issue with assoc_in_hom:
            * it can't be applied automatically here because there isn't any way to
            * obtain the equations src r = trg s and src s = trg u from assumption \<omega>.
            * Maybe this can be improved with a little bit of thought, but not while
            * a lot of other stuff is being changed, too.
            *)
           have "src r = trg s \<and> src s = trg u"
             by (metis \<omega> arr_cod hseq_char in_homE hcomp_simps(1))
           thus ?thesis
             using u \<omega> by fastforce
         qed
 
         obtain w\<^sub>r \<theta>\<^sub>r \<nu>\<^sub>r
         where w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r: "ide w\<^sub>r \<and> \<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright> \<and>
                                \<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright> \<and> iso \<nu>\<^sub>r \<and>
                                \<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r \<cdot> \<nu>\<^sub>r = \<a>[r, s, u] \<cdot> \<omega>"
           using u \<omega> \<rho>.T1 [of "s \<star> u" "\<a>[r, s, u] \<cdot> \<omega>"]
           by (metis 1 \<rho>.ide_base \<sigma>.ide_base arr_cod composable ide_hcomp in_homE
               match_1 not_arr_null seq_if_composable)
         text \<open>
 $$
 \xymatrix{
   && X \ar@ {.>}[ddl]^{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
   \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r}} \\
   && \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && \\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 $$
         \<close>
         text \<open>We need some simps, etc., otherwise the subsequent diagram chase is very painful.\<close>
         have w\<^sub>r: "ide w\<^sub>r"
           using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
         have [simp]: "src w\<^sub>r = src u"
            using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<omega> 1 comp_arr_dom in_homE seqE hcomp_simps(1) vseq_implies_hpar(1)
            by (metis src_hcomp)
         have [simp]: "trg w\<^sub>r = src \<rho>"
           using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r
           by (metis 1 arrI not_arr_null seqE seq_if_composable)
         have \<theta>\<^sub>r_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright>"
           using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
         have \<theta>\<^sub>r_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>r : src u \<rightarrow> trg s\<guillemotright>"
           using \<theta>\<^sub>r_in_hom src_cod [of \<theta>\<^sub>r] trg_cod [of \<theta>\<^sub>r]
           by (metis \<open>src w\<^sub>r = src u\<close> \<sigma>.leg1_simps(4) arr_dom in_hhomI in_homE r\<^sub>0s\<^sub>1.cospan
               src_hcomp trg_hcomp vconn_implies_hpar(1) vconn_implies_hpar(2))
         have [simp]: "src \<theta>\<^sub>r = src u" using \<theta>\<^sub>r_in_hhom by auto
         have [simp]: "trg \<theta>\<^sub>r = trg s" using \<theta>\<^sub>r_in_hhom by auto
         have [simp]: "dom \<theta>\<^sub>r = r\<^sub>0 \<star> w\<^sub>r" using \<theta>\<^sub>r_in_hom by blast
         have [simp]: "cod \<theta>\<^sub>r = s \<star> u" using \<theta>\<^sub>r_in_hom by blast
         have \<nu>\<^sub>r_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright>" using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
         have \<nu>\<^sub>r_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>r : src u \<rightarrow> trg r\<guillemotright>"
           using \<nu>\<^sub>r_in_hom src_dom [of \<nu>\<^sub>r] trg_dom [of \<nu>\<^sub>r]
           by (metis \<open>src w\<^sub>r = src u\<close> \<rho>.leg1_simps(4) arr_cod in_hhomI in_homE
               src_hcomp trg_hcomp vconn_implies_hpar(3) vconn_implies_hpar(4))
         have [simp]: "src \<nu>\<^sub>r = src u" using \<nu>\<^sub>r_in_hhom by auto
         have [simp]: "trg \<nu>\<^sub>r = trg r" using \<nu>\<^sub>r_in_hhom by auto
         have [simp]: "dom \<nu>\<^sub>r = ?v" using \<nu>\<^sub>r_in_hom by auto
         have [simp]: "cod \<nu>\<^sub>r = r\<^sub>1 \<star> w\<^sub>r" using \<nu>\<^sub>r_in_hom by auto
         have iso_\<nu>\<^sub>r: "iso \<nu>\<^sub>r" using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
 
         obtain w\<^sub>s \<theta>\<^sub>s \<nu>\<^sub>s
         where w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s: "ide w\<^sub>s \<and> \<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu>\<^sub>s : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s\<^sub>1 \<star> w\<^sub>s\<guillemotright> \<and> iso \<nu>\<^sub>s \<and>
                       \<sigma>.composite_cell w\<^sub>s \<theta>\<^sub>s \<cdot> \<nu>\<^sub>s = \<theta>\<^sub>r"
           using u w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<sigma>.T1 [of u \<theta>\<^sub>r] by auto
         text \<open>
 $$
 \xymatrix{
   && X \ar[ddl]^{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
   \ar@/ur20pt/[dddrr]^{u} \ar@ {.>}[ddr]_{w_s} \xtwocell[dddrr]{}\omit{^{<-1.5>\theta_s}}
   \xtwocell[ddd]{}\omit{^{<1>\nu_s}} \\
   && \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 $$
         \<close>
         have w\<^sub>s: "ide w\<^sub>s"
           using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
         have [simp]: "src w\<^sub>s = src u"
           using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s src_cod
           by (metis \<sigma>.leg0_simps(2) \<sigma>.tab_simps(2) \<theta>\<^sub>r_in_hom arrI hseqI' ideD(1) seqE
               seq_if_composable src_hcomp vconn_implies_hpar(3))
         have [simp]: "trg w\<^sub>s = src \<sigma>"
           using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s
           by (metis \<sigma>.tab_simps(2) arr_dom in_homE not_arr_null seq_if_composable)
         have \<theta>\<^sub>s_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright>"
           using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
         have \<theta>\<^sub>s_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>s : src u \<rightarrow> src s\<guillemotright>"
           using \<theta>\<^sub>s_in_hom src_cod trg_cod
           by (metis \<theta>\<^sub>r_in_hom arrI hseqE in_hhom_def seqE vconn_implies_hpar(1)
               vconn_implies_hpar(3) w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
         have [simp]: "src \<theta>\<^sub>s = src u" using \<theta>\<^sub>s_in_hhom by auto
         have [simp]: "trg \<theta>\<^sub>s = src s" using \<theta>\<^sub>s_in_hhom by auto
         have [simp]: "dom \<theta>\<^sub>s = s\<^sub>0 \<star> w\<^sub>s" using \<theta>\<^sub>s_in_hom by blast
         have [simp]: "cod \<theta>\<^sub>s = u" using \<theta>\<^sub>s_in_hom by blast
         have \<nu>\<^sub>s_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>s : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s\<^sub>1 \<star> w\<^sub>s\<guillemotright>" using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
         have \<nu>\<^sub>s_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>s : src u \<rightarrow> trg s\<guillemotright>"
           using \<nu>\<^sub>s_in_hom src_dom trg_cod
           by (metis \<open>src \<theta>\<^sub>r = src u\<close> \<open>trg \<theta>\<^sub>r = trg s\<close> \<theta>\<^sub>r_in_hom in_hhomI in_homE src_dom trg_dom)
         have [simp]: "src \<nu>\<^sub>s = src u" using \<nu>\<^sub>s_in_hhom by auto
         have [simp]: "trg \<nu>\<^sub>s = trg s" using \<nu>\<^sub>s_in_hhom by auto
         have [simp]: "dom \<nu>\<^sub>s = r\<^sub>0 \<star> w\<^sub>r" using \<nu>\<^sub>s_in_hom by auto
         have [simp]: "cod \<nu>\<^sub>s = s\<^sub>1 \<star> w\<^sub>s" using \<nu>\<^sub>s_in_hom by auto
         have iso_\<nu>\<^sub>s: "iso \<nu>\<^sub>s" using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
 
         obtain w \<theta>\<^sub>t \<nu>\<^sub>t
         where w\<theta>\<^sub>t\<nu>\<^sub>t: "ide w \<and> \<guillemotleft>\<theta>\<^sub>t : p\<^sub>0 \<star> w \<Rightarrow> w\<^sub>s\<guillemotright> \<and> \<guillemotleft>\<nu>\<^sub>t : w\<^sub>r \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>\<^sub>t \<and>
                     (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) = \<nu>\<^sub>s"
           using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s iso_\<nu>\<^sub>s r\<^sub>0s\<^sub>1.\<phi>_biuniversal_prop(1) [of w\<^sub>s w\<^sub>r \<nu>\<^sub>s] by blast
         text \<open>
 $$
 \xymatrix{
   && X \ar[ddl]_{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
   \ar@/ur20pt/[dddrr]^{u} \ar[ddr]^{w_s} \xtwocell[dddrr]{}\omit{^{<-1.5>\theta_s}}
   \ar@ {.>}[d]^{w} \xtwocell[ddl]{}\omit{^<-2>{\nu_t}} \xtwocell[ddr]{}\omit{^<2>{\theta_t}} \\
   && {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 $$
         \<close>
         text \<open>{\bf Note:} \<open>w\<close> is not necessarily a map.\<close>
         have w: "ide w"
           using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
         have [simp]: "src w = src u"
           using w\<theta>\<^sub>t\<nu>\<^sub>t src_cod
           by (metis \<nu>\<^sub>s_in_hom \<open>src \<nu>\<^sub>s = src u\<close> arrI seqE src_hcomp src_vcomp vseq_implies_hpar(1))
         have [simp]: "trg w = src p\<^sub>0"
           using w\<theta>\<^sub>t\<nu>\<^sub>t
           by (metis \<nu>\<^sub>s_in_hom arrI not_arr_null r\<^sub>0s\<^sub>1.\<phi>_simps(2) seqE seq_if_composable)
         have \<theta>\<^sub>t_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>t : p\<^sub>0 \<star> w \<Rightarrow> w\<^sub>s\<guillemotright>"
           using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
         have \<theta>\<^sub>t_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>t : src u \<rightarrow> src \<sigma>\<guillemotright>"
           using \<theta>\<^sub>t_in_hom src_cod trg_cod \<open>src w\<^sub>s = src u\<close> \<open>trg w\<^sub>s = src \<sigma>\<close> by fastforce
         have [simp]: "src \<theta>\<^sub>t = src u" using \<theta>\<^sub>t_in_hhom by auto
         have [simp]: "trg \<theta>\<^sub>t = src \<sigma>" using \<theta>\<^sub>t_in_hhom by auto
         have [simp]: "dom \<theta>\<^sub>t = p\<^sub>0 \<star> w" using \<theta>\<^sub>t_in_hom by blast
         have (* [simp]: *) "cod \<theta>\<^sub>t = w\<^sub>s" using \<theta>\<^sub>t_in_hom by blast
         have \<nu>\<^sub>t_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>t : w\<^sub>r \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright>" using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
         have \<nu>\<^sub>t_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>t : src u \<rightarrow> src \<rho>\<guillemotright>"
           using \<nu>\<^sub>t_in_hom src_dom trg_dom \<open>src w\<^sub>r = src u\<close> \<open>trg w\<^sub>r = src \<rho>\<close> by fastforce
         have [simp]: "src \<nu>\<^sub>t = src u" using \<nu>\<^sub>t_in_hhom by auto
         have [simp]: "trg \<nu>\<^sub>t = src \<rho>" using \<nu>\<^sub>t_in_hhom by auto
         have (* [simp]: *) "dom \<nu>\<^sub>t = w\<^sub>r" using \<nu>\<^sub>t_in_hom by auto
         have [simp]: "cod \<nu>\<^sub>t = p\<^sub>1 \<star> w" using \<nu>\<^sub>t_in_hom by auto
         have iso_\<nu>\<^sub>t: "iso \<nu>\<^sub>t" using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
 
         define \<theta> where "\<theta> = \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
         have \<theta>: "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
         proof (unfold \<theta>_def, intro comp_in_homI)
           show "\<guillemotleft>\<a>[s\<^sub>0, p\<^sub>0, w] : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> s\<^sub>0 \<star> p\<^sub>0 \<star> w\<guillemotright>"
             using w\<theta>\<^sub>t\<nu>\<^sub>t by auto
           show "\<guillemotleft>s\<^sub>0 \<star> \<theta>\<^sub>t : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0 \<star> w\<^sub>s\<guillemotright>"
             using w\<theta>\<^sub>t\<nu>\<^sub>t by auto
           show "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright>"
             using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
         qed
         define \<nu> where "\<nu> = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
         have \<nu>: "\<guillemotleft>\<nu> : ?v \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright>"
         proof (unfold \<nu>_def, intro comp_in_homI)
           show "\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright>"
             using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by blast
           show "\<guillemotleft>r\<^sub>1 \<star> \<nu>\<^sub>t : r\<^sub>1 \<star> w\<^sub>r \<Rightarrow> r\<^sub>1 \<star> p\<^sub>1 \<star> w\<guillemotright>"
             using w\<theta>\<^sub>t\<nu>\<^sub>t by (intro hcomp_in_vhom, auto)
           show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] : r\<^sub>1 \<star> p\<^sub>1 \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright>"
             using w\<theta>\<^sub>t\<nu>\<^sub>t assoc_in_hom by (simp add: \<rho>.T0.antipar(1))
         qed
         have iso_\<nu>: "iso \<nu>"
           using \<nu> w\<theta>\<^sub>t\<nu>\<^sub>t w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<rho>.T0.antipar(1)
           by (unfold \<nu>_def, intro isos_compose) auto
         have *: "arr ((s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot> (\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                        (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
           using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t \<theta>\<^sub>r_in_hom comp_assoc by auto
 
         have "((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = \<omega>"
         proof -
           have "seq (r \<star> \<theta>\<^sub>r) (\<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r)"
             using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<rho>.base_simps(2) composable by fastforce
           hence "\<omega> = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> \<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r \<cdot> \<nu>\<^sub>r"
             using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r invert_side_of_triangle(1) iso_assoc
             by (metis 1 \<rho>.ide_base \<sigma>.ide_base arrI assoc'_eq_inv_assoc composable hseq_char'
                 seqE seq_if_composable u vconn_implies_hpar(2) vconn_implies_hpar(4) w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> \<rho>.composite_cell w\<^sub>r (\<sigma>.composite_cell w\<^sub>s \<theta>\<^sub>s \<cdot> \<nu>\<^sub>s) \<cdot> \<nu>\<^sub>r"
             using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
                              (\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
             using w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc by simp
           text \<open>Rearrange to create \<open>\<theta>\<close> and \<open>\<nu>\<close>, leaving \<open>tab\<close> in the middle.\<close>
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
                              ((\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t)) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
             using comp_assoc by presburger
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (\<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
                              ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t)) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
           proof -
             have "(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) = \<sigma> \<star> \<theta>\<^sub>t"
               using comp_arr_dom comp_cod_arr interchange
               by (metis \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> \<sigma>.tab_simps(1) \<sigma>.tab_simps(4) arrI w\<theta>\<^sub>t\<nu>\<^sub>t)
             also have "... = ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
               using comp_arr_dom comp_cod_arr interchange w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t \<sigma>.tab_in_hom
               by (metis \<open>dom \<theta>\<^sub>t = p\<^sub>0 \<star> w\<close> \<sigma>.tab_simps(5) arrI)
             finally have "(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) = ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
                              (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
               using assoc_naturality [of s s\<^sub>0 \<theta>\<^sub>t] w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> arrI by force
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                              (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot>
                              (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
           proof -
             have "r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
                              (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) =
                   (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                     (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
             proof -
               have "seq ((s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t))
                         (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                           \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
               proof -
                 have "seq (s \<star> \<theta>\<^sub>s)
                           ((s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                             (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
                   using \<open>\<guillemotleft>\<a>[r, s, u] \<cdot> \<omega> : dom \<omega> \<Rightarrow> r \<star> s \<star> u\<guillemotright>\<close> calculation by blast
                 thus ?thesis
                   using comp_assoc by presburger
               qed
               thus ?thesis
                 using whisker_left [of r "(s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
                                          "\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                                             (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)"]
                     w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc
                 by simp
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                              (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> ((r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r]) \<cdot>
                              (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
           proof -
             have "seq (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                       \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) (r\<^sub>0 \<star> \<nu>\<^sub>t)"
               using 1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t
               apply (intro seqI' comp_in_homI) by auto
             hence "r \<star> (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                      \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) =
                    (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                      \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> (r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t)"
               using whisker_left by simp
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                              (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
                              (((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r)) \<cdot> \<nu>\<^sub>r"
           proof -
             have "(r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] = \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> ((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t)"
               using assoc_naturality [of r r\<^sub>0 \<nu>\<^sub>t] \<nu>\<^sub>t_in_hom by auto
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = (\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t))) \<cdot>
                              (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                              (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
                              (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r) = \<rho> \<star> \<nu>\<^sub>t"
               using comp_arr_dom comp_cod_arr interchange
               by (metis \<open>dom \<nu>\<^sub>t = w\<^sub>r\<close> \<rho>.tab_simps(1) \<rho>.tab_simps(5) arrI w\<theta>\<^sub>t\<nu>\<^sub>t)
             also have "... = (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t)"
               using comp_arr_dom comp_cod_arr interchange
               by (metis \<open>cod \<nu>\<^sub>t = p\<^sub>1 \<star> w\<close> \<open>trg \<nu>\<^sub>t = src \<rho>\<close> \<rho>.T0.antipar(1) \<rho>.tab_simps(1)
                   \<rho>.tab_simps(2) \<rho>.tab_simps(4) r\<^sub>0s\<^sub>1.base_simps(2) trg.preserves_reflects_arr
                   trg_hcomp)
             finally have "((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r) = (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t)" by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> 
                              (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> ((\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot>
                              (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
                              (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) =
                   ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
             proof -
               have "seq (s \<star> \<theta>\<^sub>s) (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
                 using \<theta>\<^sub>s_in_hom \<theta>\<^sub>s_in_hhom \<theta>\<^sub>t_in_hom \<theta>\<^sub>t_in_hhom 1 calculation by blast
               moreover have "src r = trg (s \<star> \<theta>\<^sub>s)"
                 using composable hseqI by force
               ultimately
               have "\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) =
                     (\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> s \<star> \<theta>\<^sub>s)) \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
                 using whisker_left comp_assoc by simp
               also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> w\<^sub>s] \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
                 using assoc_naturality comp_assoc
                 by (metis \<open>cod \<theta>\<^sub>s = u\<close> \<open>dom \<theta>\<^sub>s = s\<^sub>0 \<star> w\<^sub>s\<close> \<open>trg \<theta>\<^sub>s = src s\<close>
                     \<rho>.base_simps(2-4) \<sigma>.base_simps(2-4) arrI assoc'_naturality composable w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
               also have "... = (((r \<star> s) \<star> \<theta>\<^sub>s) \<cdot> ((r \<star> s) \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
               proof -
                 have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> w\<^sub>s] \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) =
                       ((r \<star> s) \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
                   using arrI hseq_char assoc'_naturality [of r s "s\<^sub>0 \<star> \<theta>\<^sub>t"] \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> composable
                   by auto
                 thus ?thesis
                   using comp_assoc by auto
               qed
               also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
                 using \<theta>_def \<theta> whisker_left
                 by (metis (full_types) arrI cod_comp ide_base seqE seqI)
               finally show ?thesis by simp
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> 
                              ((r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot>
                                ((\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
                              \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] = \<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot> ((\<sigma> \<star> p\<^sub>0) \<star> w)"
               using assoc_naturality [of \<sigma> p\<^sub>0 w] by (simp add: w\<theta>\<^sub>t\<nu>\<^sub>t)
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
                              (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              ((r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]) \<cdot>
                              (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
             using r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t whisker_left comp_assoc by force
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
                              (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              (\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]) \<cdot>
                              (\<rho> \<star> p\<^sub>1 \<star> w)) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] =
                   \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
             proof -
               have 1: "(r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) =
                        \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
                 using pentagon
                 by (simp add: \<rho>.T0.antipar(1) w)
               moreover have 2: "seq \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
                 using \<rho>.T0.antipar(1) w by simp
               moreover have "inv (r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]) = r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                 using \<rho>.T0.antipar(1) w by simp
               ultimately have "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) =
                                  ((r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]) \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
                 using \<rho>.T0.antipar(1) w comp_assoc
                       invert_side_of_triangle(1)
                         [of "\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]" "r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]"
                             "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)"]
                 by simp
               hence "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] =
                      (\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
                 using \<rho>.T0.antipar(1) w
                       invert_side_of_triangle(2)
                         [of "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)"
                             "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]" "\<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"]
                 using \<open>trg w = src p\<^sub>0\<close> by simp
               thus ?thesis
                 using comp_assoc by presburger
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
                              (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                              \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w]) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w) = ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
               using assoc'_naturality [of \<rho> p\<^sub>1 w] by (simp add: \<rho>.T0.antipar(1) w\<theta>\<^sub>t\<nu>\<^sub>t)
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
                              (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> ((r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w]) \<cdot>
                              ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "(r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] = \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w] \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w)"
               using assoc_naturality [of r r\<^sub>0s\<^sub>1.\<phi> w] r\<^sub>0s\<^sub>1.cospan w\<theta>\<^sub>t\<nu>\<^sub>t by auto
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
                              (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot>
                              (((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot>
                                ((\<rho> \<star> p\<^sub>1) \<star> w)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "(r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w] =
                   \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w)"
             proof -
               have "arr w \<and> dom w = w \<and> cod w = w"
                 using ide_char w by blast
               then show ?thesis
                 using assoc_naturality [of r "\<sigma> \<star> p\<^sub>0" w] composable by auto
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
                              (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
                              (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot>
                              ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w)) \<cdot>
                              (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
           proof -
             have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) =
                   (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
               using w \<rho>.T0.antipar(1) composable whisker_right by auto
             also have "... = (((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot>
                                \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)) \<cdot>
                                (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
             proof -
               have "((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> 
                       (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) =
                     r \<star> \<sigma> \<star> p\<^sub>0"
               proof -
                 have "((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> 
                         (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) =
                       ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> ((r \<star> s \<star> s\<^sub>0 \<star> p\<^sub>0) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]))) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
                   using comp_assoc_assoc' by (simp add: composable)
                 also have "... = ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
                   using comp_cod_arr by (simp add: composable)
                 also have "... = ((r \<star> (s \<star> s\<^sub>0) \<star> p\<^sub>0)) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
                   using whisker_left comp_assoc_assoc' assoc_in_hom hseqI'
                   by (metis \<rho>.ide_base \<sigma>.base_simps(2) \<sigma>.ide_base \<sigma>.ide_leg0
                       \<sigma>.leg0_simps(2-3) \<sigma>.leg1_simps(3) r\<^sub>0s\<^sub>1.ide_leg0
                       r\<^sub>0s\<^sub>1.leg0_simps(2) r\<^sub>0s\<^sub>1.p\<^sub>0_simps hcomp_simps(1))
                 also have "... = r \<star> \<sigma> \<star> p\<^sub>0"
                   using comp_cod_arr
                   by (simp add: composable)
                 finally show ?thesis by blast
               qed
               thus ?thesis by simp
             qed
             also have "... = (r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> \<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot>
                                (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
                                (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
               using comp_assoc by presburger
             also have "... = (r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> \<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> tab \<star> w"
               using tab_def by simp
             also have "... = ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) \<cdot> (tab \<star> w)"
               using w \<rho>.T0.antipar(1) composable comp_assoc whisker_right by auto
             finally have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot>
                             ((\<rho> \<star> p\<^sub>1) \<star> w) =
                           ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) \<cdot> (tab \<star> w)"
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = (((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w])) \<cdot>
                              \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>"
           proof -
             have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
                    \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) =
                   ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w]"
             proof -
               have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
                       \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot>
                       (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) =
                     \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                       (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                       ((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> (\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>)\<rbrace>"
                 using w comp_assoc \<a>'_def \<alpha>_def composable by simp
               also have "... = \<lbrace>((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
                 using w composable
                 apply (intro E.eval_eqI) by simp_all
               also have "... = ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w]"
                 using w comp_assoc \<a>'_def \<alpha>_def composable by simp
               finally show ?thesis by simp
             qed
             thus ?thesis
               using \<nu>_def comp_assoc by simp
           qed
           also have "... = ((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>"
           proof -
             have "((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) = (r \<star> s) \<star> \<theta>"
               using \<theta>_def w whisker_left composable
               by (metis \<theta> arrI ide_base comp_assoc)
             thus ?thesis
               using comp_assoc by presburger
           qed
           finally show "((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = \<omega>"
             by simp
         qed
         thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright> \<and>
                       \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                       composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
           using w\<theta>\<^sub>t\<nu>\<^sub>t \<theta> \<nu> iso_\<nu> comp_assoc by metis
       qed
 
       show "\<And>u w w' \<theta> \<theta>' \<beta>.
               \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w' \<Rightarrow> u\<guillemotright>;
                 \<guillemotleft>\<beta> : (r\<^sub>1 \<star> p\<^sub>1) \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w'\<guillemotright>;
                 composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
               \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
       proof -
         fix u w w' \<theta> \<theta>' \<beta>
         assume w: "ide w"
         assume w': "ide w'"
         assume \<theta>: "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
         assume \<theta>': "\<guillemotleft>\<theta>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w' \<Rightarrow> u\<guillemotright>"
         assume \<beta>: "\<guillemotleft>\<beta> : (r\<^sub>1 \<star> p\<^sub>1) \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w'\<guillemotright>"
         assume eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
         interpret uw\<theta>w'\<theta>'\<beta>: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg
                               \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close> u w \<theta> w' \<theta>' \<beta>
           using w w' \<theta> \<theta>' \<beta> eq composable tab_in_hom comp_assoc
           by unfold_locales auto
         text \<open>
 $$
 \begin{array}{ll}
 \xymatrix{
   && X \ar[d]_{w'} \xtwocell[ddl]{}\omit{^{\beta}}
   \ar@/ul20pt/[dddll]_<>(0.25){w}|<>(0.33)@ {>}_<>(0.5){p_1}|<>(0.67)@ {>}_<>(0.75){r_1}
   \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta'}}\\
   && {\rm src}~\phi \ar[dl]^{p_1} \ar[dr]_{p_0} \ddtwocell\omit{^\phi} \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 \\
 \hspace{5cm}
 =
 \qquad
 \xy/50pt/
 \xymatrix{
   && X \ar[d]_{w} \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta}}\\
   && {\rm src}~\phi \ar[dl]^{p_1} \ar[dr]_{p_0} \ddtwocell\omit{^\phi} \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 \endxy
 \end{array}
 $$
         \<close>
         text \<open>
           First apply property \<open>\<rho>.T2\<close> using \<open>\<guillemotleft>\<beta>\<^sub>r : r\<^sub>1 \<star> p\<^sub>1 \<star> w \<Rightarrow> r\<^sub>1 \<star> p\<^sub>1 \<star> w'\<guillemotright>\<close>
           (obtained by composing \<open>\<beta>\<close> with associativities) and ``everything to the right'' 
           as \<open>\<theta>\<^sub>r\<close> and \<open>\<theta>\<^sub>r'\<close>.  This yields \<open>\<guillemotleft>\<gamma>\<^sub>r : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>\<close>.
           Next, apply property \<open>\<rho>.T2\<close> to obtain \<open>\<guillemotleft>\<gamma>\<^sub>s : p\<^sub>0 \<star> w \<Rightarrow> p\<^sub>0 \<star> w'\<guillemotright>\<close>.
           For this use \<open>\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>\<^sub>s' : s\<^sub>0 \<star> p\<^sub>0 \<star> w'\<guillemotright>\<close>
           obtained by composing \<open>\<theta>\<close> and \<open>\<theta>'\<close> with associativities.
           We also need \<open>\<guillemotleft>\<beta>\<^sub>s : s\<^sub>1 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>1 \<star> p\<^sub>0 \<star> w'\<guillemotright>\<close>.
           To get this, transport \<open>r\<^sub>0 \<star> \<gamma>\<^sub>r\<close> across \<open>\<phi>\<close>; we need \<open>\<phi>\<close> to be an isomorphism
           in order to do this.
           Finally, apply the biuniversal property of \<open>\<phi>\<close> to get \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>
           and verify the required equation.
         \<close>
         let ?w\<^sub>r = "p\<^sub>1 \<star> w"
         have w\<^sub>r: "ide ?w\<^sub>r" by simp
         let ?w\<^sub>r' = "p\<^sub>1 \<star> w'"
         have w\<^sub>r': "ide ?w\<^sub>r'" by simp
         define \<theta>\<^sub>r where "\<theta>\<^sub>r = (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
                                 (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
         have \<theta>\<^sub>r: "\<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> ?w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright>"
           unfolding \<theta>\<^sub>r_def
           using \<rho>.T0.antipar(1) by fastforce
         define \<theta>\<^sub>r' where "\<theta>\<^sub>r' = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                   (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']"
         have \<theta>\<^sub>r': "\<guillemotleft>\<theta>\<^sub>r' : r\<^sub>0 \<star> ?w\<^sub>r' \<Rightarrow> s \<star> u\<guillemotright>"
           unfolding \<theta>\<^sub>r'_def
           using \<rho>.T0.antipar(1) by fastforce
         define \<beta>\<^sub>r where "\<beta>\<^sub>r = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
         have \<beta>\<^sub>r: "\<guillemotleft>\<beta>\<^sub>r : r\<^sub>1 \<star> ?w\<^sub>r \<Rightarrow> r\<^sub>1 \<star> ?w\<^sub>r'\<guillemotright>"
           unfolding \<beta>\<^sub>r_def
           using \<rho>.T0.antipar(1) by force
         have eq\<^sub>r: "\<rho>.composite_cell ?w\<^sub>r \<theta>\<^sub>r = \<rho>.composite_cell ?w\<^sub>r' \<theta>\<^sub>r' \<cdot> \<beta>\<^sub>r"
         text \<open>
 $$
 \begin{array}{ll}
 \xymatrix{
   && X \ar[ddl]^{w_r'} \xtwocell[dddll]{}\omit{^<2>{\beta_r}}
   \ar@/ul20pt/[dddll]_<>(0.33){w_r}|<>(0.67)@ {>}_<>(0.75){r_1}
   \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r'}}\\
   && \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && \\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 \\
 \hspace{5cm}
 =\qquad
 \xy/50pt/
 \xymatrix{
   && X \ar[ddl]^{w_r} \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r}}\\
   && \\  
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
   && \\
   {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
 }
 \endxy
 \end{array}
 $$
         \<close>
         proof -
           have "\<rho>.composite_cell ?w\<^sub>r \<theta>\<^sub>r = \<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
             using \<theta>\<^sub>r_def technical uw\<theta>w'\<theta>'\<beta>.uw\<theta>.uw\<theta> by blast
           also have "... = \<a>[r, s, u] \<cdot> (((r \<star> s) \<star> \<theta>') \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w'] \<cdot>
                              (tab \<star> w') \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
             using eq comp_assoc by simp
           also have "... = (r \<star> \<theta>\<^sub>r') \<cdot> \<a>[r, r\<^sub>0, ?w\<^sub>r'] \<cdot> (\<rho> \<star> ?w\<^sub>r') \<cdot> \<beta>\<^sub>r"
           proof -
             have "\<a>[r, s, u] \<cdot> (composite_cell w' \<theta>' \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
                   \<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
               using comp_assoc by presburger
             also have "... = (r \<star> (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                     (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
                                     \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot>
                                 \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w'] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w') \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
             proof -
               have "\<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
                     \<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot>
                       ((\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
               proof -
                 have "(\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta> = \<beta>"
                   using comp_cod_arr \<rho>.T0.antipar(1) \<beta> comp_assoc_assoc' by simp
                 thus ?thesis by argo
               qed
               also have "... = (\<a>[r, s, u] \<cdot> ((r \<star> s) \<star> \<theta>') \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w'] \<cdot> (tab \<star> w') \<cdot>
                                  \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
                 using comp_assoc by presburger
               also have "... = ((r \<star> (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                  (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
                                  \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w'] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w')) \<cdot>
                                  \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
                 using \<theta>\<^sub>r'_def technical [of w' \<theta>' u ?w\<^sub>r' \<theta>\<^sub>r'] comp_assoc by fastforce
               finally show ?thesis
                 using comp_assoc by simp
             qed
             finally show ?thesis
               using \<theta>\<^sub>r'_def \<beta>\<^sub>r_def comp_assoc by auto
           qed
           finally show ?thesis
             using comp_assoc by presburger
         qed
         have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>"
           using eq\<^sub>r \<rho>.T2 [of ?w\<^sub>r ?w\<^sub>r' \<theta>\<^sub>r "s \<star> u" \<theta>\<^sub>r' \<beta>\<^sub>r] w\<^sub>r w\<^sub>r' \<theta>\<^sub>r \<theta>\<^sub>r' \<beta>\<^sub>r by blast
         obtain \<gamma>\<^sub>r where \<gamma>\<^sub>r: "\<guillemotleft>\<gamma>\<^sub>r : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>\<^sub>r"
           using 1 by blast
 
         let ?w\<^sub>s = "p\<^sub>0 \<star> w"
         have w\<^sub>s: "ide ?w\<^sub>s" by simp
         let ?w\<^sub>s' = "p\<^sub>0 \<star> w'"
         have w\<^sub>s': "ide ?w\<^sub>s'" by simp
         define \<theta>\<^sub>s where "\<theta>\<^sub>s = \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
         have \<theta>\<^sub>s: "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
           using \<theta>\<^sub>s_def by auto
         define \<theta>\<^sub>s' where "\<theta>\<^sub>s' = \<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']"
         have \<theta>\<^sub>s': "\<guillemotleft>\<theta>\<^sub>s' : s\<^sub>0 \<star> p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
           using \<theta>\<^sub>s'_def by auto
         define \<beta>\<^sub>s where "\<beta>\<^sub>s = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
                                 \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
         have \<beta>\<^sub>s: "\<guillemotleft>\<beta>\<^sub>s : s\<^sub>1 \<star> ?w\<^sub>s \<Rightarrow> s\<^sub>1 \<star> ?w\<^sub>s'\<guillemotright>"
           unfolding \<beta>\<^sub>s_def
           using \<gamma>\<^sub>r r\<^sub>0s\<^sub>1.\<phi>_in_hom(2) r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1)
           apply (intro comp_in_homI)
                 apply auto
           by auto
         have eq\<^sub>s: "\<sigma>.composite_cell (p\<^sub>0 \<star> w) (\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) =
                    \<sigma>.composite_cell (p\<^sub>0 \<star> w') (\<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<beta>\<^sub>s"
         text \<open>
 $$
 \begin{array}{ll}
 \xy/67pt/
 \xymatrix{
   && X \ar[d]^{w'} \ar@/l10pt/[dl]_{w} \ddltwocell\omit{^{\gamma_r}}
   \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta_s'}}\\
   & {\rm src}~\phi \ar[dr]_{p_1} \ar[d]_{p_0}
   & {\rm src}~\phi \ar[d]^{p_1} \ar[dr]_{p_0} \ddrtwocell\omit{^\phi} \xtwocell[ddl]{}\omit{^\;\;\;\;\phi^{-1}} \\  
   & {\rm src}~\sigma \ar[dr]_{s_1} & {\rm src}~\rho \ar[d]^{r_0}
   & {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   && {\rm src}~r = {\rm trg}~s && {\rm src}~s \ar[ll]^{s}
 }
 \endxy
 \\
 \hspace{5cm}=
 \xy/50pt/
 \xymatrix{
   & X \ar@/dl15pt/[ddr]_<>(0.5){w_s}
   \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta_s}}\\
   & \\  
   && {\rm src}~\sigma  \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
   & {\rm src}~r = {\rm trg}~s && {\rm src}~s \ar[ll]^{s}
 }
 \endxy
 \end{array}
 $$
         \<close>
         proof -
           have "\<sigma>.composite_cell (p\<^sub>0 \<star> w') (\<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<beta>\<^sub>s =
                 (\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
             using \<beta>\<^sub>s_def \<theta>\<^sub>r'_def whisker_left comp_assoc by simp
           also have "... = \<theta>\<^sub>r \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
             using \<gamma>\<^sub>r by simp
           also have "... = ((s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])) \<cdot> \<a>[s, s\<^sub>0, ?w\<^sub>s] \<cdot> (\<sigma> \<star> ?w\<^sub>s) \<cdot>
                               \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
                               \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
             using \<theta>\<^sub>r_def comp_assoc by simp
           also have "... = (s \<star> \<theta>) \<cdot> \<sigma>.composite_cell (p\<^sub>0 \<star> w) \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
           proof -
             have "(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot>
                     \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
                     \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] =
                   \<sigma> \<star> p\<^sub>0 \<star> w"
             proof -
               have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] = cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
                 using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) comp_assoc_assoc' by simp
               text \<open>Here the fact that \<open>\<phi>\<close> is a retraction is used.\<close>
               moreover have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = cod \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
                 using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_arr_inv' whisker_right [of w r\<^sub>0s\<^sub>1.\<phi> "inv r\<^sub>0s\<^sub>1.\<phi>"]
                 by simp
               moreover have "\<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] = dom (\<sigma> \<star> p\<^sub>0 \<star> w)"
                 using r\<^sub>0s\<^sub>1.base_simps(2) hseq_char comp_assoc_assoc' by auto
               moreover have "hseq (inv r\<^sub>0s\<^sub>1.\<phi>) w"
                 using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2)
                 by (intro hseqI, auto)
               moreover have "hseq \<sigma> (p\<^sub>0 \<star> w)"
                 by (intro hseqI, auto)
               ultimately show ?thesis
                 using comp_arr_dom comp_cod_arr by simp
             qed
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... = \<sigma>.composite_cell (p\<^sub>0 \<star> w) (\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
             using \<theta>\<^sub>s_def whisker_left
             by (metis \<sigma>.ide_base \<theta>\<^sub>s arrI comp_assoc)
           finally show ?thesis by simp
         qed
         hence 2: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>"
           using \<sigma>.T2 [of ?w\<^sub>s ?w\<^sub>s' \<theta>\<^sub>s u \<theta>\<^sub>s' \<beta>\<^sub>s] w\<^sub>s w\<^sub>s' \<theta>\<^sub>s \<theta>\<^sub>s' \<beta>\<^sub>s
           by (metis \<theta>\<^sub>s'_def \<theta>\<^sub>s_def)
         obtain \<gamma>\<^sub>s where \<gamma>\<^sub>s: "\<guillemotleft>\<gamma>\<^sub>s : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>\<^sub>s) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>\<^sub>s"
           using 2 by blast
 
         have eq\<^sub>t: "(s\<^sub>1 \<star> \<gamma>\<^sub>s) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
                    (s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
         text \<open>
 $$
 \xy/78pt/
 \xymatrix{
   & X \ar[d]^{w'} \ar@/ul15pt/[ddl]_{w_r} \xtwocell[ddl]{}\omit{^{\gamma_r}} \\
   & {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\  
   {\rm src}~\rho \ar[dr]^{r_0}
   && {\rm src}~\sigma \ar[dl]_{s_1} \\
   & {\rm src}~r = {\rm trg}~s &
 }
 \endxy
 \qquad = \qquad
 \xy/78pt/
 \xymatrix{
   & X \ar[d]^{w} \ar@/ur15pt/[ddr]^{w_s'} \xtwocell[ddr]{}\omit{^{\gamma_s}} \\
   & {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi}  \\  
   {\rm src}~\rho \ar[dr]^{r_0}
   && {\rm src}~\sigma \ar[dl]_{s_1} \\
   & {\rm src}~r = {\rm trg}~s &
 }
 \endxy
 $$
         \<close>
         proof -
           have "(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) =
                 \<beta>\<^sub>s \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
           proof -
             have "\<beta>\<^sub>s \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
                   (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
                     \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
                     \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
               using \<beta>\<^sub>s_def comp_assoc by metis
             also have "... = (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
             proof -
               have "(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
                       \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
                     r\<^sub>0 \<star> \<gamma>\<^sub>r"
               proof -
                 have "(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
                        \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
                       (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                   using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_assoc_assoc' comp_cod_arr by simp
                   (* Used here that \<phi> is a section. *)
                 also have "... = (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                   using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_inv_arr' \<rho>.T0.antipar(1)
                         whisker_right [of w "inv r\<^sub>0s\<^sub>1.\<phi>" r\<^sub>0s\<^sub>1.\<phi>] comp_cod_arr
                   by simp
                 also have "... = r\<^sub>0 \<star> \<gamma>\<^sub>r"
                 proof -
                   have "hseq r\<^sub>0 \<gamma>\<^sub>r"
                     using \<beta>\<^sub>s \<beta>\<^sub>s_def by blast
                   thus ?thesis
                     using comp_assoc_assoc' comp_arr_dom
                       by (metis (no_types) \<gamma>\<^sub>r \<rho>.ide_leg0 comp_assoc_assoc'(1) hcomp_simps(3)
                           hseq_char ide_char in_homE r\<^sub>0s\<^sub>1.ide_leg1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps w w\<^sub>r)
                 qed
                 finally show ?thesis by blast
               qed
               thus ?thesis by simp
             qed
             also have "... = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
               using comp_assoc by presburger
             also have "... = (s\<^sub>1 \<star> ?w\<^sub>s') \<cdot>
                                \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
             proof -
               have "(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] = \<a>[s\<^sub>1, p\<^sub>0, w']"
                 using comp_cod_arr by simp
               thus ?thesis
                 using comp_assoc by metis
             qed
             finally show ?thesis by simp
           qed
           also have "... = (s\<^sub>1 \<star> \<gamma>\<^sub>s) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
             using \<gamma>\<^sub>s by simp
           finally show ?thesis by simp
         qed
         have 3: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
           using w w' w\<^sub>s' w\<^sub>r \<gamma>\<^sub>r \<gamma>\<^sub>s eq\<^sub>t
                 r\<^sub>0s\<^sub>1.\<phi>_biuniversal_prop(2) [of ?w\<^sub>s' ?w\<^sub>r w w' \<gamma>\<^sub>s "p\<^sub>0 \<star> w'" \<gamma>\<^sub>r]
           by blast
         obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
           using 3 by blast
 
         show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
         proof -
           have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
           proof -
             have "\<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
             proof -
               have "\<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>) = (\<theta>\<^sub>s' \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w']) \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
                 using \<theta>\<^sub>s'_def comp_arr_dom comp_assoc comp_assoc_assoc'(2) by auto
               also have "... = (\<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>)) \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
                 using assoc_naturality [of s\<^sub>0 p\<^sub>0 \<gamma>] comp_assoc
                 by (metis \<gamma> \<gamma>\<^sub>r \<sigma>.leg0_simps(4-5) r\<^sub>0s\<^sub>1.leg0_simps(4-5)
                     r\<^sub>0s\<^sub>1.leg1_simps(3) hseqE in_homE leg0_simps(2))
               also have "... = \<theta>\<^sub>s \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
                 by (metis \<gamma> \<gamma>\<^sub>s arrI comp_ide_arr w\<^sub>s')
               also have "... = \<theta>"
                 using \<theta>\<^sub>s_def comp_assoc comp_arr_dom comp_assoc_assoc' by simp
               finally show ?thesis by simp
             qed
             moreover have "\<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>"
             proof -
               have "\<beta> = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta>\<^sub>r \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
               proof -
                 have "\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta>\<^sub>r \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w] =
                       (\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
                   using \<beta>\<^sub>r_def comp_assoc by simp
                 also have "... = \<beta>"
                   using comp_arr_dom comp_cod_arr
                   by (metis \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 comp_assoc_assoc'(2) hseqE ideD(1)
                       uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(4-5) leg1_simps(2) w w' w\<^sub>r w\<^sub>r')
                 finally show ?thesis by simp
               qed
               also have "... = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> (r\<^sub>1 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
                 using \<gamma>\<^sub>r by simp
               also have "... = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>)"
                 using assoc_naturality [of r\<^sub>1 p\<^sub>1 \<gamma>]
                 by (metis \<gamma> \<gamma>\<^sub>r \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.leg1_simps(5-6) hseqE
                     ide_char in_homE leg1_simps(2))
               also have "... = (\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>)"
                 using comp_assoc by presburger
               also have "... = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>"
                 using comp_cod_arr
                 by (metis \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 calculation comp_assoc_assoc'(2) comp_ide_arr
                     hseqE ideD(1) ide_cod local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(5)
                     w' w\<^sub>r')
               finally show ?thesis by simp
             qed
             ultimately show "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
                using \<gamma> by blast
           qed
           moreover have "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>')
                                    \<Longrightarrow> \<gamma>' = \<gamma>"
           proof -
             fix \<gamma>'
             assume \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>')"
             show "\<gamma>' = \<gamma>"
             proof -
               let ?P\<^sub>r = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>"
               let ?P\<^sub>s = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>"
               let ?\<gamma>\<^sub>r' = "p\<^sub>1 \<star> \<gamma>'"
               let ?\<gamma>\<^sub>s' = "p\<^sub>0 \<star> \<gamma>'"
               let ?P\<^sub>t = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
               have "hseq p\<^sub>0 \<gamma>'"
               proof (intro hseqI)
                 show "\<guillemotleft>\<gamma>' : src \<theta> \<rightarrow> src p\<^sub>0\<guillemotright>"
                   using \<gamma>'
                   by (metis hseqE hseqI' in_hhom_def uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) src_hcomp
                       src_vcomp leg0_simps(2) leg1_simps(3)
                       uw\<theta>w'\<theta>'\<beta>.uw\<theta>.\<theta>_simps(1) vseq_implies_hpar(1))
                 show "\<guillemotleft>p\<^sub>0 : src p\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>" by simp
               qed
               hence "hseq p\<^sub>1 \<gamma>'"
                 using hseq_char by simp
               have "\<guillemotleft>?\<gamma>\<^sub>r' : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright>"
                 using \<gamma>' by auto
               moreover have "\<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"
               proof -
                 text \<open>
                   Note that @{term \<theta>\<^sub>r} is the composite of ``everything to the right''
                   of @{term "\<rho> \<star> ?w\<^sub>r"}, and similarly for @{term \<theta>\<^sub>r'}.
                   We can factor @{term \<theta>\<^sub>r} as @{term "(s \<star> \<theta>) \<cdot> X w"}, where @{term "X w"}
                   is a composite of @{term \<sigma>} and @{term \<phi>}.  We can similarly factor @{term \<theta>\<^sub>r'}
                   as @{term "(s \<star> \<theta>') \<cdot> X w'"}.
                   Then @{term "\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r') = (s \<star> \<theta>') \<cdot> X w' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"},
                   which equals @{term "(s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> ?\<gamma>\<^sub>r') \<cdot> X w = \<theta>\<^sub>r"}.
                 \<close>
                 let ?X = "\<lambda>w. (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot>
                                 \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                 have "\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r') = (s \<star> \<theta>') \<cdot> ?X w' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"
                   using \<theta>\<^sub>r'_def comp_assoc by simp
                 also have "... = (s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> ?X w"
                 proof -
                   have "(s \<star> \<theta>') \<cdot> ((s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot>
                           \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>') =
                         (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot>
                           \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>')"
                     using comp_assoc by presburger
                   also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                      (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
                                      ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>')) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                     using assoc'_naturality [of r\<^sub>0 p\<^sub>1 \<gamma>'] comp_assoc
                     by (metis \<gamma>' \<open>\<guillemotleft>p\<^sub>1 \<star> \<gamma>' : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>\<close> \<rho>.T0.antipar(1)
                         \<rho>.leg0_in_hom(2) r\<^sub>0s\<^sub>1.leg1_simps(4-6)
                         r\<^sub>0s\<^sub>1.base_simps(2) hcomp_in_vhomE in_homE trg_hcomp)
                   also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                      (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>')) \<cdot>
                                      (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                   proof -
                     have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = r\<^sub>0s\<^sub>1.\<phi> \<star> \<gamma>'"
                       using \<gamma>' interchange [of r\<^sub>0s\<^sub>1.\<phi> "r\<^sub>0 \<star> p\<^sub>1" w' \<gamma>'] comp_arr_dom comp_cod_arr
                       by auto
                     also have "... = ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
                       using \<gamma>' interchange \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr
                       by (metis comp_arr_ide r\<^sub>0s\<^sub>1.\<phi>_simps(1,5) seqI'
                           uw\<theta>w'\<theta>'\<beta>.uw\<theta>.w_in_hom(2) w)
                     finally have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = 
                                   ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
                       by simp
                     thus ?thesis
                       using comp_assoc by presburger
                   qed
                   also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                      ((\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                                      (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                     using \<gamma>' assoc_naturality [of s\<^sub>1 p\<^sub>0 \<gamma>'] comp_assoc
                     by (metis \<sigma>.leg1_simps(2) \<sigma>.leg1_simps(3,5-6) r\<^sub>0s\<^sub>1.leg0_simps(4-5)
                         hcomp_in_vhomE hseqE in_homE uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1)
                         leg0_in_hom(2) leg1_simps(3))
                   also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
                                    ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                                    (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                   proof -
                     have "(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>') = \<sigma> \<star> p\<^sub>0 \<star> \<gamma>'"
                       using \<gamma>' interchange [of \<sigma> s\<^sub>1 "p\<^sub>0 \<star> w'" "p\<^sub>0 \<star> \<gamma>'"]
                             whisker_left \<open>hseq p\<^sub>0 \<gamma>'\<close>comp_arr_dom comp_cod_arr
                       by (metis \<sigma>.tab_simps(1) \<sigma>.tab_simps(4) hcomp_simps(4) in_homE
                           r\<^sub>0s\<^sub>1.leg0_simps(5))
                     also have "... = ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>') \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
                       using \<gamma>' interchange [of "s \<star> s\<^sub>0" \<sigma> "p\<^sub>0 \<star> \<gamma>'" "p\<^sub>0 \<star> w"]
                             whisker_left comp_arr_dom comp_cod_arr \<open>hseq p\<^sub>0 \<gamma>'\<close>
                       by (metis \<sigma>.tab_simps(1) \<sigma>.tab_simps(5) hcomp_simps(3) in_homE
                           r\<^sub>0s\<^sub>1.leg0_simps(4))
                     finally have "(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>') =
                                   ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>') \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
                       by simp
                     thus ?thesis
                       using comp_assoc by presburger
                   qed
                   also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> ((s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') \<cdot>
                                      \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                                      (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                     using \<gamma>' assoc_naturality [of s s\<^sub>0 "p\<^sub>0 \<star> \<gamma>'"] \<open>hseq p\<^sub>0 \<gamma>'\<close> by force
                   also have "... = (s \<star> \<theta>') \<cdot> ((s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot>
                                      \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                                      (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                     using comp_assoc by presburger
                   also have "... = (s \<star> \<theta>') \<cdot> ((s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])) \<cdot>
                                      \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
                                      (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                   proof -
                     have "(s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') =
                           (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
                     proof -
                       have "(s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') =
                             s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] \<cdot> (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')"
                       proof -
                         have "seq \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')"
                         proof
                           (* It seems to be too time-consuming for auto to solve these. *)
                           show "\<guillemotleft>s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>' : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0 \<star> p\<^sub>0 \<star> w'\<guillemotright>"
                             using \<gamma>'
                             by (intro hcomp_in_vhom, auto)
                           show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] : s\<^sub>0 \<star> p\<^sub>0 \<star> w' \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w'\<guillemotright>"
                             by auto
                         qed
                         thus ?thesis
                           using w w' \<gamma>' whisker_left by simp
                       qed
                       also have "... = s \<star> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
                         using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> assoc'_naturality [of s\<^sub>0 p\<^sub>0 \<gamma>'] by fastforce
                       also have "... = (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
                       proof -
                         have "seq ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
                         proof
                           (* Same here. *)
                           show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w] : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w\<guillemotright>"
                             by auto
                           show "\<guillemotleft>(s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w'\<guillemotright>"
                             using \<gamma>' by (intro hcomp_in_vhom, auto)
                         qed
                         thus ?thesis
                           using w w' \<gamma>' whisker_left by simp
                       qed
                       finally show ?thesis by blast
                     qed
                     thus ?thesis by simp
                   qed
                   also have "... = (s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> ?X w"
                     using comp_assoc by presburger
                   finally show ?thesis by simp
                 qed
                 also have "... = \<theta>\<^sub>r"
                   using \<theta>\<^sub>r_def \<gamma>' uw\<theta>w'\<theta>'\<beta>.uw\<theta>.\<theta>_simps(1) whisker_left \<sigma>.ide_base comp_assoc
                   by simp
                 finally show ?thesis by simp
               qed
               moreover have "\<beta>\<^sub>r = r\<^sub>1 \<star> ?\<gamma>\<^sub>r'"
               proof -
                 have "\<beta>\<^sub>r = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
                   using \<beta>\<^sub>r_def \<gamma>' by simp
                 also have "... = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> (r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>')"
                   using \<gamma>' assoc'_naturality
                   by (metis \<rho>.leg1_simps(5-6) r\<^sub>0s\<^sub>1.leg1_simps(5-6)
                       hcomp_in_vhomE hseqE in_homE uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) leg1_in_hom(2))
                 also have "... = (\<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w']) \<cdot> (r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>')"
                   using comp_assoc by presburger
                 also have "... = r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>'"
                   using comp_cod_arr
                   by (metis (no_types, lifting) \<beta>\<^sub>r \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 arrI calculation
                       comp_assoc_assoc'(1) comp_ide_arr ide_hcomp hseq_char'
                       ideD(1) seq_if_composable hcomp_simps(2) leg1_simps(2) w' w\<^sub>r')
                 finally show ?thesis by simp
               qed
               ultimately have P\<^sub>r': "?P\<^sub>r ?\<gamma>\<^sub>r'"
                 by simp
               have eq\<^sub>r: "\<gamma>\<^sub>r = ?\<gamma>\<^sub>r'"
                 using 1 \<gamma>\<^sub>r P\<^sub>r' by blast
               have "\<guillemotleft>?\<gamma>\<^sub>s' : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright>"
                 using \<gamma>' by auto
               moreover have "\<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> ?\<gamma>\<^sub>s')"
                 using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> \<sigma>.leg0_simps(2,4-5)  \<sigma>.leg1_simps(3) \<theta>\<^sub>s'_def \<theta>\<^sub>s_def
                       assoc'_naturality hseqE in_homE comp_assoc r\<^sub>0s\<^sub>1.leg0_simps(4-5)
                       r\<^sub>0s\<^sub>1.p\<^sub>0_simps
                 by metis
               moreover have "\<beta>\<^sub>s = s\<^sub>1 \<star> ?\<gamma>\<^sub>s'"
               proof -
                 have "\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
                         \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] =
                       \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>')) \<cdot>
                         \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
                   using eq\<^sub>r comp_assoc by simp
                 also have "... = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>')) \<cdot>
                                    \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                                    \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
                 proof -
                   have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>') = ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
                     using \<gamma>' assoc'_naturality \<open>hseq p\<^sub>1 \<gamma>'\<close>
                     by (metis \<rho>.leg0_simps(2,4-5) \<rho>.leg1_simps(3)
                         r\<^sub>0s\<^sub>1.leg1_simps(5-6) hseqE in_homE leg1_simps(2))
                   thus ?thesis
                     using comp_assoc by presburger
                 qed
                 also have "... = (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>')) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                                    \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
                                    \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
                 proof -
                   have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = r\<^sub>0s\<^sub>1.\<phi> \<star> \<gamma>'"
                     using \<gamma>' interchange [of r\<^sub>0s\<^sub>1.\<phi> "r\<^sub>0 \<star> p\<^sub>1" w' \<gamma>']
                           comp_arr_dom comp_cod_arr
                     by auto
                   also have "... = ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
                     using \<gamma>' interchange \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr
                     by (metis in_homE r\<^sub>0s\<^sub>1.\<phi>_simps(1,5))
                   finally have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') =
                                 ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
                     by simp
                   thus ?thesis
                     using comp_assoc by presburger
                 qed
                 also have "... = (s\<^sub>1 \<star> ?\<gamma>\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
                                    \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
                 proof -
                   have "\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') = (s\<^sub>1 \<star> ?\<gamma>\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w]"
                     using \<gamma>' assoc_naturality [of s\<^sub>1 p\<^sub>0 \<gamma>'] \<open>hseq p\<^sub>0 \<gamma>'\<close> by auto
                   thus ?thesis
                     using comp_assoc by presburger
                 qed
                 also have "... = s\<^sub>1 \<star> ?\<gamma>\<^sub>s'"
                 proof -
                   have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] = cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
                     using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) comp_assoc_assoc'
                     by simp
                   text \<open>Here the fact that \<open>\<phi>\<close> is a retraction is used.\<close>
                   moreover have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = cod \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
                     using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_arr_inv'
                           whisker_right [of w r\<^sub>0s\<^sub>1.\<phi> "inv r\<^sub>0s\<^sub>1.\<phi>"]
                     by simp
                   moreover have "cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = inv r\<^sub>0s\<^sub>1.\<phi> \<star> w"
                     using \<beta>\<^sub>s_def \<beta>\<^sub>s
                     by (meson arrI comp_cod_arr seqE)
                   ultimately show ?thesis
                     using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr comp_assoc_assoc'
                           whisker_left [of s\<^sub>1 "p\<^sub>0 \<star> \<gamma>'" "p\<^sub>0 \<star> w"] whisker_left [of p\<^sub>0]
                     by (metis \<sigma>.ide_leg1 assoc'_simps(1) hseqE ideD(1) in_homE r\<^sub>0s\<^sub>1.ide_leg0
                         r\<^sub>0s\<^sub>1.p\<^sub>0_simps w w\<^sub>s)
                 qed
                 finally show ?thesis
                   using \<beta>\<^sub>s_def by simp
               qed
               ultimately have P\<^sub>s': "?P\<^sub>s ?\<gamma>\<^sub>s'"
                 by simp
               have eq\<^sub>s: "\<gamma>\<^sub>s = ?\<gamma>\<^sub>s'"
                 using 2 \<gamma>\<^sub>s P\<^sub>s' by blast
               have "?P\<^sub>t \<gamma>'"
                 using \<gamma>' comp_cod_arr \<open>\<guillemotleft>p\<^sub>0 \<star> \<gamma>' : p\<^sub>0 \<star> w \<Rightarrow> p\<^sub>0 \<star> w'\<guillemotright>\<close> eq\<^sub>r eq\<^sub>s by auto
               thus "\<gamma>' = \<gamma>"
                 using 3 \<gamma> by blast
             qed
           qed
           ultimately show ?thesis by blast
         qed
       qed
     qed
 
   end
 
   sublocale composite_tabulation_in_maps \<subseteq>
               tabulation V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
     using composite_is_tabulation by simp
 
   sublocale composite_tabulation_in_maps \<subseteq>
               tabulation_in_maps V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
     using T0.is_map \<rho>.leg1_is_map \<rho>.T0.antipar(2) composable \<rho>.leg1_is_map \<rho>.T0.antipar
     apply unfold_locales
      apply simp
     apply (intro left_adjoints_compose)
     by auto
 
   subsection "The Classifying Category of Maps"
 
   text \<open>
     \sloppypar
     We intend to show that if \<open>B\<close> is a bicategory of spans, then \<open>B\<close> is biequivalent to
     \<open>Span(Maps(B))\<close>, for a specific category \<open>Maps(B)\<close> derived from \<open>B\<close>.
     The category \<open>Maps(B)\<close> is constructed in this section as the ``classifying category'' of
     maps of \<open>B\<close>, which has the same objects as \<open>B\<close> and which has as 1-cells the isomorphism classes
     of maps of \<open>B\<close>.  We show that, if \<open>B\<close> is a bicategory of spans, then \<open>Maps(B)\<close> has pullbacks.
   \<close>
 
   locale maps_category =
     B: bicategory_of_spans
   begin
 
     no_notation B.in_hhom  ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
     notation B.in_hhom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
     notation B.in_hom  ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
     notation B.isomorphic  (infix "\<cong>\<^sub>B" 50)
     notation B.iso_class  ("\<lbrakk>_\<rbrakk>\<^sub>B")
 
     text \<open>
       I attempted to modularize the construction here, by refactoring ``classifying category''
       out as a separate locale, but it ended up causing extra work because to apply it we
       first need to obtain the full sub-bicategory of 2-cells between maps, then construct its
       classifying category, and then we have to re-prove everything about it, to get rid of
       any mention of the sub-bicategory construction.  So the construction is being done
       here as a ``one-off'' special case construction, with the necessary properties proved
       just once.
      \<close>
 
      text \<open>
        The ``hom-categories'' of \<open>Maps(C)\<close> have as arrows the isomorphism classes of maps of \<open>B\<close>.
      \<close>
 
      abbreviation Hom
      where "Hom a b \<equiv> {F. \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B}"
 
      lemma in_HomD:
      assumes "F \<in> Hom a b"
      shows "F \<noteq> {}"
      and "B.is_iso_class F"
      and "f \<in> F \<Longrightarrow> B.ide f"
      and "f \<in> F \<Longrightarrow> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
      and "f \<in> F \<Longrightarrow> B.is_left_adjoint f"
      and "f \<in> F \<Longrightarrow> F = \<lbrakk>f\<rbrakk>\<^sub>B"
      proof -
        show "F \<noteq> {}"
          using assms B.ide_in_iso_class B.left_adjoint_is_ide B.iso_class_is_nonempty by auto
        show 1: "B.is_iso_class F"
          using assms B.is_iso_classI B.left_adjoint_is_ide by fastforce
        show "f \<in> F \<Longrightarrow> B.ide f"
          using assms 1 B.iso_class_memb_is_ide by blast
        obtain f' where f': "\<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f' \<and> F = \<lbrakk>f'\<rbrakk>\<^sub>B"
          using assms by auto
        show "f \<in> F \<Longrightarrow> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
          using assms f' B.iso_class_def B.isomorphic_implies_hpar by auto
        show "f \<in> F \<Longrightarrow> B.is_left_adjoint f"
          using assms f' B.iso_class_def B.left_adjoint_preserved_by_iso [of f'] by auto
        show "f \<in> F \<Longrightarrow> F = \<lbrakk>f\<rbrakk>\<^sub>B"
          by (metis B.adjoint_pair_antipar(1) f' B.ide_in_iso_class B.is_iso_classI
              B.iso_class_elems_isomorphic B.iso_class_eqI)
      qed
 
      definition Comp
      where "Comp G F \<equiv> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
                             (\<exists>f g. f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h)}"
 
      lemma in_CompI [intro]:
      assumes "B.is_iso_class F" and "B.is_iso_class G"
      and "f \<in> F" and "g \<in> G" and "g \<star> f \<cong>\<^sub>B h"
      shows "h \<in> Comp G F"
        unfolding Comp_def
        using assms by auto
 
      lemma in_CompE [elim]:
      assumes "h \<in> Comp G F"
      and "\<And>f g. \<lbrakk> B.is_iso_class F; B.is_iso_class G; f \<in> F; g \<in> G; g \<star> f \<cong>\<^sub>B h \<rbrakk> \<Longrightarrow> T"
      shows T
        using assms Comp_def by auto
 
      lemma is_iso_class_Comp:
      assumes "Comp G F \<noteq> {}"
      shows "B.is_iso_class (Comp G F)"
      proof -
        obtain h where h: "h \<in> Comp G F"
          using assms by auto
        have ide_h: "B.ide h"
          using h Comp_def B.isomorphic_implies_hpar(2) by auto
        obtain f g where fg: "B.is_iso_class F \<and> B.is_iso_class G \<and> f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
          using h Comp_def by auto
        have "Comp G F = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<and> B.ide (g \<star> f)"
        proof (intro conjI)
          show "B.ide (g \<star> f)"
            using fg B.iso_class_memb_is_ide B.isomorphic_implies_ide(1) by auto
          show "Comp G F = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
          proof
            show "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<subseteq> Comp G F"
              unfolding Comp_def B.iso_class_def
              using fg by auto
            show "Comp G F \<subseteq> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
            proof
              fix h'
              assume h': "h' \<in> Comp G F"
              obtain f' g' where f'g': "f' \<in> F \<and> g' \<in> G \<and> g' \<star> f' \<cong>\<^sub>B h'"
                using h' Comp_def by auto
              have 1: "f' \<cong>\<^sub>B f \<and> g' \<cong>\<^sub>B g"
                using f'g' fg B.iso_class_elems_isomorphic by auto
              moreover have "B.ide f \<and> B.ide f' \<and> B.ide g \<and> B.ide g'"
                using 1 B.isomorphic_implies_hpar by auto
              ultimately have "g' \<star> f' \<cong>\<^sub>B g \<star> f"
                using f'g' fg B.hcomp_isomorphic_ide B.hcomp_ide_isomorphic
                      B.isomorphic_transitive B.isomorphic_implies_hpar
                by (meson B.hseqE B.ideD(1))
              hence "h' \<cong>\<^sub>B g \<star> f"
                using f'g' B.isomorphic_symmetric B.isomorphic_transitive by blast
              thus "h' \<in> B.iso_class (g \<star> f)"
                using B.iso_class_def B.isomorphic_symmetric by simp
            qed
          qed
        qed
        thus ?thesis
          using assms B.is_iso_class_def B.ide_in_iso_class by auto
      qed
 
      lemma Comp_is_extensional:
      assumes "Comp G F \<noteq> {}"
      shows "B.is_iso_class F" and "B.is_iso_class G"
      and "F \<noteq> {}" and "G \<noteq> {}"
        using assms Comp_def by auto
 
      lemma Comp_eqI [intro]:
      assumes "h \<in> Comp G F" and "h' \<in> Comp G' F'" and "h \<cong>\<^sub>B h'"
      shows "Comp G F = Comp G' F'"
      proof -
        obtain f g where fg: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
          using assms comp_def by auto
        obtain f' g' where f'g': "f' \<in> F' \<and>  g' \<in> G' \<and> g' \<star> f' \<cong>\<^sub>B h'"
          using assms by auto
        have "h \<in> Comp G F \<inter> Comp G' F'"
          by (meson IntI assms in_CompE in_CompI B.isomorphic_symmetric B.isomorphic_transitive)
        hence "Comp G F \<inter> Comp G' F' \<noteq> {}"
          by auto
        thus ?thesis
          using assms is_iso_class_Comp
          by (metis empty_iff B.iso_class_eq)
      qed
 
      lemma Comp_eq_iso_class_memb:
      assumes "h \<in> Comp G F"
      shows "Comp G F = \<lbrakk>h\<rbrakk>\<^sub>B"
      proof
        show "Comp G F \<subseteq> \<lbrakk>h\<rbrakk>\<^sub>B"
        proof
          fix h'
          assume h': "h' \<in> Comp G F"
          obtain f g where fg: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
            using assms by auto
          obtain f' g' where f'g': "f' \<in> F \<and> g' \<in> G \<and> g' \<star> f' \<cong>\<^sub>B h'"
            using h' by auto
          have "f \<cong>\<^sub>B f' \<and> g \<cong>\<^sub>B g'"
            using assms fg f'g' in_HomD(6) B.iso_class_elems_isomorphic by auto
          moreover have "B.ide f \<and> B.ide f' \<and> B.ide g \<and> B.ide g'"
            using assms fg f'g' in_HomD [of F] in_HomD [of G]
            by (meson calculation B.isomorphic_implies_ide(1) B.isomorphic_implies_ide(2))
          moreover have "src g = trg f \<and> src g = trg f' \<and> src g' = trg f \<and> src g' = trg f'"
            using fg f'g'
            by (metis B.seq_if_composable calculation(1) B.ideD(1)
                B.isomorphic_implies_hpar(1) B.isomorphic_implies_hpar(3) B.not_arr_null)
          ultimately have "g \<star> f \<cong>\<^sub>B g' \<star> f'"
            using fg f'g' B.hcomp_ide_isomorphic B.hcomp_isomorphic_ide B.isomorphic_transitive
            by metis
          thus "h' \<in> \<lbrakk>h\<rbrakk>\<^sub>B"
            using fg f'g' B.isomorphic_symmetric B.isomorphic_transitive B.iso_class_def [of h]
            by blast
        qed
        show "\<lbrakk>h\<rbrakk>\<^sub>B \<subseteq> Comp G F"
        proof (unfold B.iso_class_def Comp_def)
          obtain f g where 1: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
            using assms in_HomD Comp_def
            by (meson in_CompE)
          show "{h'. B.isomorphic h h'} \<subseteq>
                {h. B.is_iso_class F \<and> B.is_iso_class G \<and> (\<exists>f g. f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h)}"
            using assms 1 B.isomorphic_transitive by blast
        qed
      qed
 
      interpretation concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
      proof
        show "\<And>a. a \<in> Collect B.obj \<Longrightarrow> \<lbrakk>a\<rbrakk>\<^sub>B \<in> Hom a a"
          by (metis (mono_tags, lifting) B.ide_in_hom(1) mem_Collect_eq B.objE
              B.obj_is_self_adjoint(1))
        show "\<And>a b c F G. \<lbrakk> a \<in> Collect B.obj; b \<in> Collect B.obj; c \<in> Collect B.obj;
                            F \<in> Hom a b; G \<in> Hom b c \<rbrakk> \<Longrightarrow> Comp G F \<in> Hom a c"
        proof -
          fix a b c F G
          assume a: "a \<in> Collect B.obj" and b: "b \<in> Collect B.obj" and c: "c \<in> Collect B.obj"
          and F: "F \<in> Hom a b" and G: "G \<in> Hom b c"
          obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
            using F by blast
          obtain g where g: "\<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> B.is_left_adjoint g \<and> G = \<lbrakk>g\<rbrakk>\<^sub>B"
            using G by blast
          have "{h. B.is_iso_class F \<and> B.is_iso_class G \<and>
                    (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)} =
                \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
          proof
            show "{h. B.is_iso_class F \<and> B.is_iso_class G \<and>
                      (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}
                    \<subseteq> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
            proof
              fix h
              assume "h \<in> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
                              (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}"
              hence h: "B.is_iso_class F \<and> B.is_iso_class G \<and>
                        (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)"
                by simp
              show "h \<in> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
              proof -
                obtain f' g' where f'g': "g' \<in> G \<and> f' \<in> F \<and> g' \<star> f' \<cong>\<^sub>B h"
                  using h by auto
                obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> B.iso \<phi>"
                  using f f'g' F B.iso_class_def by auto
                obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : g \<Rightarrow>\<^sub>B g'\<guillemotright> \<and> B.iso \<psi>"
                  using g f'g' G B.iso_class_def by auto
                have 1: "\<guillemotleft>\<psi> \<star> \<phi> : g \<star> f \<Rightarrow>\<^sub>B g' \<star> f'\<guillemotright>"
                  using f g \<phi> \<psi> by auto
                moreover have "B.iso (\<psi> \<star> \<phi>)"
                  using f g \<phi> \<psi> 1 B.iso_hcomp by auto
                ultimately show ?thesis
                   using f'g' B.iso_class_def B.isomorphic_def by auto
              qed
            qed
            show "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<subseteq> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
                                (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}"
              using f g B.iso_class_def B.isomorphic_reflexive B.left_adjoint_is_ide B.is_iso_classI
              by blast
          qed
          hence 1: "\<And>gf. gf \<in> B.iso_class (g \<star> f) \<Longrightarrow>
                          B.is_iso_class F \<and> B.is_iso_class G \<and>
                          (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B gf)"
            by blast
          show "Comp G F \<in> Hom a c"
          proof -
            have gf: "B.is_left_adjoint (g \<star> f)"
              by (meson f g B.hseqE B.hseqI B.left_adjoints_compose)
            obtain gf' where gf': "B.adjoint_pair (g \<star> f) gf'"
              using gf by blast
            hence "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B = Comp G F"
              using 1 Comp_eq_iso_class_memb B.ide_in_iso_class B.left_adjoint_is_ide by blast
            thus ?thesis
              using f g gf' by blast
          qed
        qed
        show "\<And>a b F. \<lbrakk> a \<in> Collect B.obj; F \<in> Hom a b \<rbrakk> \<Longrightarrow> Comp F \<lbrakk>a\<rbrakk>\<^sub>B = F"
        proof -
          fix a b F
          assume a: "a \<in> Collect B.obj"
          assume F: "F \<in> Hom a b"
          obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
            using F by auto
          have *: "\<And>f'. f' \<in> F \<Longrightarrow> \<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f' \<and> f \<cong>\<^sub>B f'"
            using f B.iso_class_def by force
          show "Comp F \<lbrakk>a\<rbrakk>\<^sub>B = F"
          proof
            show "Comp F \<lbrakk>a\<rbrakk>\<^sub>B \<subseteq> F"
            proof
              fix h
              assume "h \<in> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
              hence h: "\<exists>f' a'. f' \<in> F \<and> a' \<in> \<lbrakk>a\<rbrakk>\<^sub>B \<and> f' \<star> a' \<cong>\<^sub>B h"
                unfolding Comp_def by auto
              obtain f' a' where f'a': "f' \<in> F \<and> a' \<in> \<lbrakk>a\<rbrakk>\<^sub>B \<and> f' \<star> a' \<cong>\<^sub>B h"
                using h by auto
              have "B.isomorphic f h"
              proof -
                have "B.isomorphic f (f \<star> a)"
                  using f B.iso_runit' [of f] B.isomorphic_def B.left_adjoint_is_ide
                  by blast
                also have "f \<star> a \<cong>\<^sub>B f' \<star> a"
                  using f f'a' B.iso_class_def B.hcomp_isomorphic_ide
                  apply (elim conjE B.in_hhomE) by auto
                also have "f' \<star> a \<cong>\<^sub>B f' \<star> a'"
                  using f'a' * [of f'] B.iso_class_def B.hcomp_ide_isomorphic by auto
                also have "f' \<star> a' \<cong>\<^sub>B h"
                  using f'a' by simp
                finally show ?thesis by blast
              qed
              thus "h \<in> F"
                using f B.iso_class_def by simp
            qed
            show "F \<subseteq> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
            proof
              fix h
              assume h: "h \<in> F"
              have "f \<in> F"
                using f B.iso_class_def B.right_adjoint_determines_left_up_to_iso by auto
              moreover have "a \<in> B.iso_class a"
                using a B.iso_class_def B.isomorphic_reflexive by auto
              moreover have "f \<star> a \<cong>\<^sub>B h"
              proof -
                have "f \<star> a \<cong>\<^sub>B f"
                  using f B.iso_runit [of f] B.isomorphic_def B.left_adjoint_is_ide by blast
                also have "f \<cong>\<^sub>B h"
                  using h * by simp
                finally show ?thesis by blast
              qed
              ultimately show "h \<in> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
                unfolding Comp_def
                using a f F B.is_iso_classI B.left_adjoint_is_ide by auto
            qed
          qed
        qed
        show "\<And>a b F. \<lbrakk> b \<in> Collect B.obj; F \<in> Hom a b \<rbrakk> \<Longrightarrow> Comp \<lbrakk>b\<rbrakk>\<^sub>B F = F"
        proof -
          fix a b F
          assume b: "b \<in> Collect B.obj"
          assume F: "F \<in> Hom a b"
          obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
            using F by auto
          have *: "\<And>f'. f' \<in> F \<Longrightarrow> \<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f' \<and> f \<cong>\<^sub>B f'"
            using f B.iso_class_def by force
          show "Comp \<lbrakk>b\<rbrakk>\<^sub>B F = F"
          proof
            show "Comp \<lbrakk>b\<rbrakk>\<^sub>B F \<subseteq> F"
            proof
              fix h
              assume "h \<in> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
              hence h: "\<exists>b' f'. b' \<in> \<lbrakk>b\<rbrakk>\<^sub>B \<and> f' \<in> F \<and> b' \<star> f' \<cong>\<^sub>B h"
                unfolding Comp_def by auto
              obtain b' f' where b'f': "b' \<in> \<lbrakk>b\<rbrakk>\<^sub>B \<and> f' \<in> F \<and> b' \<star> f' \<cong>\<^sub>B h"
                using h by auto
              have "f \<cong>\<^sub>B h"
              proof -
                have "f \<cong>\<^sub>B b \<star> f"
                  using f B.iso_lunit' [of f] B.isomorphic_def B.left_adjoint_is_ide
                  by blast
                also have "... \<cong>\<^sub>B b \<star> f'"
                  using f b'f' B.iso_class_def B.hcomp_ide_isomorphic
                  by (elim conjE B.in_hhomE, auto)
                also have "... \<cong>\<^sub>B b' \<star> f'"
                  using b'f' * [of f'] B.iso_class_def B.hcomp_isomorphic_ide by auto
                also have "... \<cong>\<^sub>B h"
                  using b'f' by simp
                finally show ?thesis by blast
              qed
              thus "h \<in> F"
                using f B.iso_class_def by simp
            qed
            show "F \<subseteq> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
            proof
              fix h
              assume h: "h \<in> F"
              have "f \<in> F"
                using f B.iso_class_def B.right_adjoint_determines_left_up_to_iso by auto
              moreover have "b \<in> B.iso_class b"
                using b B.iso_class_def B.isomorphic_reflexive by auto
              moreover have "b \<star> f \<cong>\<^sub>B h"
              proof -
                have "b \<star> f \<cong>\<^sub>B f"
                  using f B.iso_lunit [of f] B.isomorphic_def B.left_adjoint_is_ide
                  by blast
                also have "f \<cong>\<^sub>B h"
                  using h * by simp
                finally show ?thesis by blast
              qed
              ultimately show "h \<in> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
                unfolding Comp_def
                using b f F B.is_iso_classI B.left_adjoint_is_ide by auto
            qed
          qed
        qed
        show "\<And>a b c d F G H.
                \<lbrakk> a \<in> Collect B.obj; b \<in> Collect B.obj; c \<in> Collect B.obj; d \<in> Collect B.obj;
                  F \<in> Hom a b; G \<in> Hom b c; H \<in> Hom c d \<rbrakk> \<Longrightarrow>
                Comp H (Comp G F) = Comp (Comp H G) F"
        proof -
          fix a b c d F G H
          assume F: "F \<in> Hom a b" and G: "G \<in> Hom b c" and H: "H \<in> Hom c d"
          show "Comp H (Comp G F) = Comp (Comp H G) F"
          proof
            show "Comp H (Comp G F) \<subseteq> Comp (Comp H G) F"
            proof
              fix x
              assume x: "x \<in> Comp H (Comp G F)"
              obtain f g h gf
              where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
                        h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> gf \<in> Comp G F \<and> g \<star> f \<cong>\<^sub>B gf \<and> h \<star> gf \<cong>\<^sub>B x"
                using x unfolding Comp_def by blast
              have hgf: "B.ide f \<and> B.ide g \<and> B.ide h"
                using 1 F G H B.isomorphic_implies_hpar in_HomD B.left_adjoint_is_ide
                by (metis (mono_tags, lifting))
              have "h \<star> g \<star> f \<cong>\<^sub>B x"
                by (metis "1" B.hcomp_ide_isomorphic B.hseqE B.ide_char'
                    B.isomorphic_implies_hpar(4) B.isomorphic_implies_ide(1)
                    B.isomorphic_transitive hgf)
              moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
                using 1 hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def
                by (metis B.hseq_char B.ideD(1-3) B.isomorphic_implies_hpar(1)
                    B.trg_hcomp calculation)
              moreover have hg: "\<guillemotleft>h \<star> g : b \<rightarrow>\<^sub>B d\<guillemotright>"
                using G H 1 in_HomD(4) by blast
              moreover have "h \<star> g \<in> Comp H G"
                unfolding Comp_def
                using 1 hgf F G H in_HomD [of F a b] in_HomD [of G b c] in_HomD [of H c d]
                      B.isomorphic_reflexive B.hcomp_ide_isomorphic B.hseqI'
                by (metis (no_types, lifting) B.hseqE B.hseqI mem_Collect_eq)
              ultimately show "x \<in> Comp (Comp H G) F"
                by (metis "1" B.isomorphic_transitive emptyE in_CompI is_iso_class_Comp)
            qed
            show "Comp (Comp H G) F \<subseteq> Comp H (Comp G F)"
            proof
              fix x
              assume x: "x \<in> Comp (Comp H G) F"
              obtain f g h hg
              where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
                        h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> hg \<in> Comp H G \<and> h \<star> g \<cong>\<^sub>B hg \<and> hg \<star> f \<cong>\<^sub>B x"
                using x unfolding Comp_def by blast
              have hgf: "B.ide f \<and> B.ide g \<and> B.ide h \<and> src h = trg g \<and> src g = trg f"
                using 1 F G H in_HomD B.left_adjoint_is_ide
                by (metis (no_types, lifting) B.hseq_char' B.ideD(1) B.ide_dom
                    B.in_homE B.isomorphic_def B.isomorphic_symmetric B.seqI'
                    B.seq_if_composable B.src_dom B.src_hcomp B.vseq_implies_hpar(1))
              have 2: "(h \<star> g) \<star> f \<cong>\<^sub>B x"
                by (meson "1" B.hcomp_isomorphic_ide B.hseqE B.ideD(1) B.isomorphic_implies_ide(1)
                    B.isomorphic_symmetric B.isomorphic_transitive hgf)
              moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
                using hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def by auto
              moreover have "g \<star> f \<in> Comp G F"
                using 1 F G hgf B.isomorphic_reflexive by blast
              ultimately show "x \<in> Comp H (Comp G F)"
                using 1 hgf is_iso_class_Comp [of G F] B.isomorphic_reflexive [of "g \<star> f"]
                apply (intro in_CompI)
                        apply auto[6]
                  apply simp
                 apply auto[1]
                by (meson B.isomorphic_symmetric B.isomorphic_transitive)
            qed
          qed
        qed
      qed
 
      lemma is_concrete_category:
      shows "concrete_category (Collect B.obj) Hom B.iso_class (\<lambda>_ _ _. Comp)"
        ..
 
      sublocale concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
        using is_concrete_category by simp
 
      abbreviation comp  (infixr "\<odot>" 55)
      where "comp \<equiv> COMP"
      notation in_hom  ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
      no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
      lemma Map_memb_in_hhom:
      assumes "\<guillemotleft>F : A \<rightarrow> B\<guillemotright>" and "f \<in> Map F"
      shows "\<guillemotleft>f : Dom A \<rightarrow>\<^sub>B Dom B\<guillemotright>"
      proof -
        have "\<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright>"
          using assms arr_char [of F] in_HomD [of "Map F" "Dom F" "Cod F"] by blast
        moreover have "Dom F = Dom A"
          using assms by auto
        moreover have "Cod F = Dom B"
          using assms by auto
        ultimately show ?thesis by simp
      qed
 
      lemma MkArr_in_hom':
      assumes "B.is_left_adjoint f" and "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
      shows "\<guillemotleft>MkArr a b \<lbrakk>f\<rbrakk>\<^sub>B : MkIde a \<rightarrow> MkIde b\<guillemotright>"
        using assms MkArr_in_hom by blast
 
      text \<open>
        The isomorphisms in \<open>Maps(B)\<close> are the isomorphism classes of equivalence maps in \<open>B\<close>.
      \<close>
 
      lemma iso_char:
      shows "iso F \<longleftrightarrow> arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
      proof
        assume F: "iso F"
        have "\<And>f. f \<in> Map F \<Longrightarrow> B.equivalence_map f"
        proof -
          fix f
          assume f: "f \<in> Map F"
          obtain G where G: "inverse_arrows F G"
            using F by auto
          obtain g where g: "g \<in> Map G"
            using G arr_char [of G] in_HomD(1) by blast
          have f: "f \<in> Map F \<and> \<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright> \<and> B.ide f \<and> B.is_left_adjoint f"
            by (metis (mono_tags, lifting) F iso_is_arr is_concrete_category
                concrete_category.arr_char f in_HomD(2,4-5) B.iso_class_memb_is_ide)
          have g: "g \<in> Map G \<and> \<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright> \<and> B.ide g \<and> B.is_left_adjoint g"
            by (metis (no_types, lifting) F G Cod_cod Cod_dom arr_inv cod_inv dom_inv
                inverse_unique iso_is_arr is_concrete_category concrete_category.Map_in_Hom
                g in_HomD(2,4-5) B.iso_class_memb_is_ide)
          have "src (g \<star> f) \<cong>\<^sub>B g \<star> f"
          proof -
            have "g \<star> f \<in> Map (G \<odot> F)"
            proof -
              have 1: "f \<in> Map F \<and> g \<in> Map G \<and> g \<star> f \<cong>\<^sub>B g \<star> f"
                using F G f g B.isomorphic_reflexive by force
              have 2: "Dom G = Cod F \<and> Cod G = Dom F"
                using F G arr_char
                by (metis (no_types, lifting) Cod.simps(1) Cod_dom arr_inv
                    cod_char comp_inv_arr dom_inv inverse_unique
                    iso_is_arr is_concrete_category concrete_category.Cod_comp)
              have "g \<star> f \<in> Comp (Map G) (Map F)"
                using 1 F iso_is_arr Map_in_Hom [of F] in_HomD(2)
                apply (intro in_CompI, auto)
              proof -
                show "B.is_iso_class (Map G)"
                  using G iso_is_arr Map_in_Hom [of G] in_HomD(2) [of "Map G"] by blast
              qed
              thus ?thesis
                using F G f g comp_char [of G F] by auto
            qed
            moreover have "Dom F \<in> Map (G \<odot> F)"
              by (metis (no_types, lifting) F G Map_dom comp_inv_arr iso_is_arr
                  g B.ide_in_iso_class B.in_hhomE B.objE)
            moreover have "Map (G \<odot> F) = \<lbrakk>Dom F\<rbrakk>\<^sub>B"
              by (simp add: F G comp_inv_arr iso_is_arr)
            moreover have "Dom F = src (g \<star> f)"
              using f g by fastforce
            ultimately show ?thesis
              using f g B.iso_class_elems_isomorphic B.is_iso_classI
              by (metis B.hseqI B.ide_src)
          qed
          moreover have "f \<star> g \<cong>\<^sub>B trg f"
          proof -
            have "f \<star> g \<in> Map (F \<odot> G)"
            proof -
              have 1: "f \<in> Map F \<and> g \<in> Map G \<and> f \<star> g \<cong>\<^sub>B f \<star> g"
                using F G f g B.isomorphic_reflexive by force
              have 2: "Dom G = Cod F \<and> Cod G = Dom F"
                using F G arr_char
                by (metis (no_types, lifting) Cod.simps(1) Cod_dom arr_inv
                    cod_char comp_inv_arr dom_inv inverse_unique
                    iso_is_arr is_concrete_category concrete_category.Cod_comp)
              hence "f \<star> g \<in> Comp (Map F) (Map G)"
                using 1 F iso_is_arr Map_in_Hom [of F] in_HomD(2)
                apply (intro in_CompI, auto)
              proof -
                show "B.is_iso_class (Map G)"
                  using G iso_is_arr Map_in_Hom [of G] in_HomD(2) [of "Map G"] by blast
              qed
              thus ?thesis
                using F G f g comp_char [of F G] by auto
            qed
            moreover have "Cod F \<in> Map (F \<odot> G)"
              by (metis (no_types, lifting) F G Map_cod comp_arr_inv dom_inv
                  inverse_unique iso_is_arr g B.ide_in_iso_class B.in_hhomE B.src.preserves_ide)
            moreover have "Map (F \<odot> G) = \<lbrakk>Cod F\<rbrakk>\<^sub>B"
              by (metis (no_types, lifting) F G Map_cod comp_arr_inv dom_inv
                  inverse_unique iso_is_arr)
            moreover have "Cod F = trg (f \<star> g)"
              using f g by fastforce
            ultimately show ?thesis
              using B.iso_class_elems_isomorphic
              by (metis f g B.is_iso_classI B.in_hhomE B.src.preserves_ide)
          qed
          ultimately show "B.equivalence_map f"
            using f g B.equivalence_mapI B.quasi_inversesI [of f g] by fastforce
        qed
        thus "arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
          using F by blast
        next
        assume F: "arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
        show "iso F"
        proof -
          obtain f where f: "f \<in> Map F"
            using F arr_char in_HomD(1) by blast
          have f_in_hhom: "\<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright>"
            using f F arr_char in_HomD(4) [of "Map F" "Dom F" "Cod F" f] by simp
          have "Map F = B.iso_class f"
            using f F arr_char in_HomD(6) [of "Map F" "Dom F" "Cod F" f] by simp
          obtain g \<eta> \<epsilon>' where \<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
            using f F B.equivalence_map_def by auto
          interpret \<epsilon>': equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
            using \<epsilon>' by auto
          obtain \<epsilon> where \<epsilon>: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
            using f F \<epsilon>'.ide_right \<epsilon>'.antipar \<epsilon>'.unit_in_hom \<epsilon>'.unit_is_iso B.equivalence_map_def
                  B.equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
            by auto
          interpret \<epsilon>: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
            using \<epsilon> by simp
          have g_in_hhom: "\<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright>"
            using \<epsilon>.ide_right \<epsilon>.antipar f_in_hhom by auto
          have fg: "B.quasi_inverses f g"
            using B.quasi_inverses_def \<epsilon>.equivalence_in_bicategory_axioms by auto
          have g: "\<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright> \<and> B.is_left_adjoint g \<and> \<lbrakk>g\<rbrakk>\<^sub>B = \<lbrakk>g\<rbrakk>\<^sub>B"
            using \<epsilon>'.dual_equivalence B.equivalence_is_left_adjoint B.equivalence_map_def
                  g_in_hhom
            by blast
          have F_as_MkArr: "F = MkArr (Dom F) (Cod F) \<lbrakk>f\<rbrakk>\<^sub>B"
            using F MkArr_Map \<open>Map F = B.iso_class f\<close> by fastforce
          have F_in_hom: "in_hom F (MkIde (Dom F)) (MkIde (Cod F))"
            using F arr_char dom_char cod_char
            by (intro in_homI, auto)
          let ?G = "MkArr (Cod F) (Dom F) \<lbrakk>g\<rbrakk>\<^sub>B"
          have "arr ?G"
            using MkArr_in_hom' g by blast
          hence G_in_hom: "\<guillemotleft>?G : MkIde (Cod F) \<rightarrow> MkIde (Dom F)\<guillemotright>"
            using arr_char MkArr_in_hom by simp
          have "inverse_arrows F ?G"
          proof
            show "ide (?G \<odot> F)"
            proof -
              have "?G \<odot> F = dom F"
              proof (intro arr_eqI)
                show 1: "seq ?G F"
                  using F_in_hom G_in_hom by blast
                show "arr (dom F)"
                  using F_in_hom ide_dom by fastforce
                show "Dom (?G \<odot> F) = Dom (dom F)"
                  using F_in_hom G_in_hom 1 comp_char by auto
                show "Cod (?G \<odot> F) = Cod (dom F)"
                  using F_in_hom G_in_hom 1 comp_char by auto
                show "Map (?G \<odot> F) = Map (dom F)"
                proof -
                  have "Map (?G \<odot> F) = Comp \<lbrakk>g\<rbrakk>\<^sub>B \<lbrakk>f\<rbrakk>\<^sub>B"
                    using 1 comp_char [of ?G F] \<open>Map F = B.iso_class f\<close> by simp
                  also have "... = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
                  proof -
                    have "g \<star> f \<in> Comp \<lbrakk>g\<rbrakk>\<^sub>B \<lbrakk>f\<rbrakk>\<^sub>B"
                      by (metis \<epsilon>.ide_left \<epsilon>.ide_right \<epsilon>.unit_in_vhom \<epsilon>.unit_simps(3) B.arrI
                          B.ide_cod B.ide_in_iso_class in_CompI B.is_iso_classI
                          B.isomorphic_reflexive)
                    thus ?thesis
                      using Comp_eq_iso_class_memb F_in_hom G_in_hom arr_char arr_char
                            \<open>Map F = B.iso_class f\<close>
                      by auto
                  qed
                  also have "... = \<lbrakk>src f\<rbrakk>\<^sub>B"
                    using \<epsilon>.unit_in_hom \<epsilon>.unit_is_iso B.isomorphic_def B.iso_class_def
                          B.isomorphic_symmetric
                    by (intro B.iso_class_eqI, blast)
                  also have "... = \<lbrakk>Dom F\<rbrakk>\<^sub>B"
                    using \<epsilon>.ide_left f_in_hhom B.ide_in_iso_class B.in_hhomE B.src.preserves_ide
                          B.isomorphic_reflexive
                    by (intro B.iso_class_eqI, fastforce)
                  also have "... = Map (dom F)"
                    using F_in_hom dom_char by auto
                  finally show ?thesis by blast
                qed
              qed
              thus ?thesis
                using F by simp
            qed
            show "ide (F \<odot> ?G)"
            proof -
              have "F \<odot> ?G = cod F"
              proof (intro arr_eqI)
                show 1: "seq F ?G"
                  using F_in_hom G_in_hom by blast
                show "arr (cod F)"
                  using F_in_hom ide_cod by fastforce
                show "Dom (F \<odot> ?G) = Dom (cod F)"
                  using F_in_hom G_in_hom 1 comp_char by auto
                show "Cod (F \<odot> ?G) = Cod (cod F)"
                  using F_in_hom G_in_hom 1 comp_char by auto
                show "Map (F \<odot> ?G) = Map (cod F)"
                proof -
                  have "Map (F \<odot> ?G) = Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
                    using 1 comp_char [of F ?G] \<open>Map F = \<lbrakk>f\<rbrakk>\<^sub>B\<close> by simp
                  also have "... = \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
                  proof -
                    have "f \<star> g \<in> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
                      by (metis \<epsilon>.antipar(1) \<epsilon>.ide_left \<epsilon>.ide_right B.ide_hcomp
                          B.ide_in_iso_class in_CompI B.is_iso_classI B.isomorphic_reflexive)
                    thus ?thesis
                      using Comp_eq_iso_class_memb F_in_hom G_in_hom arr_char arr_char
                            \<open>Map F = \<lbrakk>f\<rbrakk>\<^sub>B\<close>
                      by auto
                  qed
                  also have "... = \<lbrakk>trg f\<rbrakk>\<^sub>B"
                  proof -
                    have "trg f \<in> \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
                      using \<epsilon>.counit_in_hom \<epsilon>.counit_is_iso B.isomorphic_def B.iso_class_def
                            B.isomorphic_symmetric
                      by blast
                    thus ?thesis
                      using B.iso_class_eqI
                      by (metis \<epsilon>.antipar(1) \<epsilon>.ide_left \<epsilon>.ide_right B.ide_hcomp
                          B.ide_in_iso_class B.is_iso_classI B.iso_class_elems_isomorphic)
                  qed
                  also have "... = \<lbrakk>Cod F\<rbrakk>\<^sub>B"
                    using f_in_hhom by auto
                  also have "... = Map (cod F)"
                    using F_in_hom dom_char by auto
                  finally show ?thesis by blast
                qed
              qed
              thus ?thesis
                using F by simp
            qed
          qed
          thus ?thesis by auto
        qed
      qed
 
      lemma iso_char':
      shows "iso F \<longleftrightarrow> arr F \<and> (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
      proof -
        have "arr F \<Longrightarrow> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f) \<longleftrightarrow>
                        (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
        proof
          assume F: "arr F"
          show "(\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f) \<Longrightarrow>
                (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
            using F arr_char in_HomD(1) by blast
          show "(\<exists>f. f \<in> Map F \<and> B.equivalence_map f) \<Longrightarrow>
                (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
            by (metis (no_types, lifting) F is_concrete_category concrete_category.arr_char
                B.equivalence_map_preserved_by_iso in_HomD(2) B.iso_class_elems_isomorphic)
        qed
        thus ?thesis
          using iso_char by blast
      qed
 
      text \<open>
        The following mapping takes a map in \<open>B\<close> to the corresponding arrow of \<open>Maps(B)\<close>.
      \<close>
 
      abbreviation CLS  ("\<lbrakk>\<lbrakk>_\<rbrakk>\<rbrakk>")
      where "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<equiv> MkArr (src f) (trg f) \<lbrakk>f\<rbrakk>\<^sub>B"
 
      lemma ide_CLS_obj:
      assumes "B.obj a"
      shows "ide \<lbrakk>\<lbrakk>a\<rbrakk>\<rbrakk>"
        by (simp add: assms B.obj_simps)
 
      lemma CLS_in_hom:
      assumes "B.is_left_adjoint f"
      shows "\<guillemotleft>\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> : \<lbrakk>\<lbrakk>src f\<rbrakk>\<rbrakk> \<rightarrow> \<lbrakk>\<lbrakk>trg f\<rbrakk>\<rbrakk>\<guillemotright>"
        using assms B.left_adjoint_is_ide MkArr_in_hom MkArr_in_hom' by simp
 
      lemma CLS_eqI:
      assumes "B.ide f"
      shows "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> \<longleftrightarrow> f \<cong>\<^sub>B g"
        by (metis arr.inject assms B.ide_in_iso_class B.iso_class_def B.iso_class_eqI
            B.isomorphic_implies_hpar(3) B.isomorphic_implies_hpar(4) B.isomorphic_symmetric
            mem_Collect_eq)
 
      lemma CLS_hcomp:
      assumes "B.ide f" and "B.ide g" and "src f = trg g"
      shows "\<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) (Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B)"
      proof -
        have "\<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
          using assms B.left_adjoint_is_ide by simp
        moreover have "\<lbrakk>f \<star> g\<rbrakk>\<^sub>B = Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
        proof
          show "\<lbrakk>f \<star> g\<rbrakk>\<^sub>B \<subseteq> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
            by (metis assms(1-2) B.ide_in_iso_class in_CompI B.is_iso_classI
                B.iso_class_def mem_Collect_eq subsetI)
          show "Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B \<subseteq> \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
            by (metis Comp_eq_iso_class_memb \<open>\<lbrakk>f \<star> g\<rbrakk>\<^sub>B \<subseteq> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B\<close>
                assms(1-3) B.ide_hcomp B.ide_in_iso_class subset_iff)
        qed
        ultimately show ?thesis by simp
      qed
 
      lemma comp_CLS:
      assumes "B.is_left_adjoint f" and "B.is_left_adjoint g" and "f \<star> g \<cong>\<^sub>B h"
      shows "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h\<rbrakk>\<rbrakk>"
      proof -
        have hseq_fg: "B.hseq f g"
          using assms B.isomorphic_implies_hpar(1) by simp
        have "seq \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk>"
          using assms hseq_fg CLS_in_hom [of f] CLS_in_hom [of g]  
          apply (elim B.hseqE) by auto
        hence "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) (Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B)"
          using comp_char [of "CLS f" "CLS g"] by simp
        also have "... = \<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk>"
          using assms hseq_fg CLS_hcomp
          apply (elim B.hseqE)
          using B.adjoint_pair_antipar(1) by auto
        also have "... = \<lbrakk>\<lbrakk>h\<rbrakk>\<rbrakk>"
          using assms B.isomorphic_symmetric
          by (simp add: assms(3) B.iso_class_eqI B.isomorphic_implies_hpar(3)
              B.isomorphic_implies_hpar(4))
        finally show ?thesis by simp
      qed
 
      text \<open>
        The following mapping that takes an arrow of \<open>Maps(B)\<close> and chooses some
        representative map in \<open>B\<close>.
      \<close>
 
      definition REP
      where "REP F \<equiv> if arr F then SOME f. f \<in> Map F else B.null"
 
      lemma REP_in_Map:
      assumes "arr A"
      shows "REP A \<in> Map A"
      proof -
        have "Map A \<noteq> {}"
          using assms arr_char in_HomD(1) by blast
        thus ?thesis
          using assms REP_def someI_ex [of "\<lambda>f. f \<in> Map A"] by auto
      qed
 
      lemma REP_in_hhom [intro]:
      assumes "in_hom F A B"
      shows "\<guillemotleft>REP F : src (REP A) \<rightarrow>\<^sub>B src (REP B)\<guillemotright>"
      and "B.is_left_adjoint (REP F)"
      proof -
        have "Map F \<noteq> {}"
          using assms in_hom_char arr_char null_char in_HomD(1) [of "Map F" "Dom F" "Cod F"]
          by blast
        hence 1: "REP F \<in> Map F"
          using assms REP_def someI_ex [of "\<lambda>f. f \<in> Map F"] by auto
        hence 2: "B.arr (REP F)"
          using assms 1 in_hom_char [of F A B] B.iso_class_def Map_memb_in_hhom B.in_hhom_def
          by blast
        hence "\<guillemotleft>REP F : Dom A \<rightarrow>\<^sub>B Dom B\<guillemotright>"
          using assms 1 in_hom_char [of F A B] Map_memb_in_hhom by auto
        thus "\<guillemotleft>REP F : src (REP A) \<rightarrow>\<^sub>B src (REP B)\<guillemotright>"
          using assms
          by (metis (no_types, lifting) Map_memb_in_hhom ideD(1)
              in_homI in_hom_char REP_in_Map B.in_hhom_def)
        have "REP F \<in> \<lbrakk>REP F\<rbrakk>\<^sub>B"
          using assms 1 2 arr_char [of F] in_HomD(6) B.ide_in_iso_class B.iso_class_memb_is_ide
                in_hom_char
          by blast
        thus "B.is_left_adjoint (REP F)"
          using assms 1 2 arr_char in_HomD(5) [of "Map F" "Dom F" "Cod F" "REP F"]
          by auto
      qed
 
      lemma ide_REP:
      assumes "arr A"
      shows "B.ide (REP A)"
        using assms REP_in_hhom(2) B.adjoint_pair_antipar(1) by blast
 
      lemma REP_simps [simp]:
      assumes "arr A"
      shows "B.ide (REP A)"
      and "src (REP A) = Dom A" and "trg (REP A) = Cod A"
      and "B.dom (REP A) = REP A" and "B.cod (REP A) = REP A"
      proof -
        show "B.ide (REP A)"
          using assms ide_REP by blast
        show "src (REP A) = Dom A"
          using assms REP_in_hhom
          by (metis (no_types, lifting) Map_memb_in_hhom Dom_dom in_homI
              REP_in_Map B.in_hhom_def)
        show "trg (REP A) = Cod A"
          using assms REP_in_hhom
          by (metis (no_types, lifting) Map_memb_in_hhom Dom_cod in_homI
              REP_in_Map B.in_hhom_def)
        show "B.dom (REP A) = REP A"
          using assms in_homI REP_in_hhom(2) B.adjoint_pair_antipar(1) B.ideD(2)
          by blast
        show "B.cod (REP A) = REP A"
          using assms in_homI REP_in_hhom(2) B.adjoint_pair_antipar(1) B.ideD(3)
          by blast
      qed
 
      lemma isomorphic_REP_src:
      assumes "ide A"
      shows "REP A \<cong>\<^sub>B src (REP A)"
        using assms
-       by (metis (no_types, lifting) ideD(1) ide_char REP_in_Map ide_REP
+       by (metis (no_types, lifting) ideD(1) ide_char\<^sub>C\<^sub>C REP_in_Map ide_REP
            REP_simps(2) B.is_iso_classI B.ide_in_iso_class B.iso_class_elems_isomorphic
            B.src.preserves_ide)
 
      lemma isomorphic_REP_trg:
      assumes "ide A"
      shows "REP A \<cong>\<^sub>B trg (REP A)"
-       using assms ide_char isomorphic_REP_src by auto
+       using assms ide_char\<^sub>C\<^sub>C isomorphic_REP_src by auto
 
      lemma CLS_REP:
      assumes "arr F"
      shows "\<lbrakk>\<lbrakk>REP F\<rbrakk>\<rbrakk> = F"
        by (metis (mono_tags, lifting) MkArr_Map
            is_concrete_category REP_in_Map REP_simps(2) REP_simps(3) assms
            concrete_category.Map_in_Hom in_HomD(6))
 
      lemma REP_CLS:
      assumes "B.is_left_adjoint f"
      shows "REP \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<cong>\<^sub>B f"
        by (metis (mono_tags, lifting) CLS_in_hom Map.simps(1) in_homE REP_in_Map
            assms B.iso_class_def B.isomorphic_symmetric mem_Collect_eq)
 
      lemma isomorphic_hcomp_REP:
      assumes "seq F G"
      shows "REP F \<star> REP G \<cong>\<^sub>B REP (F \<odot> G)"
      proof -
        have 1: "Dom F = Cod G"
          using assms seq_char by simp
        have 2: "Map F = B.iso_class (REP F)"
          using assms seq_char arr_char REP_in_Map in_HomD(6) by meson
        have 3: "Map G = B.iso_class (REP G)"
          using assms seq_char arr_char REP_in_Map
                in_HomD(6) [of "Map G" "Dom G" "Cod G" "REP G"]
          by auto
        have "Map (F \<odot> G) = Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
          using assms seq_char null_char
          by (metis (no_types, lifting) CLS_REP Map.simps(1) Map_comp)
        have "Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B = \<lbrakk>REP F \<star> REP G\<rbrakk>\<^sub>B"
        proof -
          have "REP F \<star> REP G \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
          proof -
            have "REP F \<in> Map F \<and> REP G \<in> Map G"
              using assms seq_char REP_in_Map by auto
            moreover have "REP F \<star> REP G \<cong>\<^sub>B REP F \<star> REP G"
              using assms seq_char 2 B.isomorphic_reflexive by auto                   
            ultimately show ?thesis
              using assms 1 2 3 B.iso_class_def B.is_iso_class_def
              by (intro in_CompI, auto)
          qed
          moreover have "\<lbrakk>REP F\<rbrakk>\<^sub>B \<in> Hom (Cod G) (Cod F)"
            using assms 1 2 arr_char [of F] by auto
          moreover have "\<lbrakk>REP G\<rbrakk>\<^sub>B \<in> Hom (Dom G) (Cod G)"
            using assms 1 3 arr_char [of G] by auto
          ultimately show ?thesis
            using Comp_eq_iso_class_memb assms arr_char arr_char REP_in_Map
            by (simp add: Comp_def)
        qed
        moreover have "REP (F \<odot> G) \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
        proof -
          have "Map (F \<odot> G) = Comp (Map F) (Map G)"
            using assms 1 comp_char [of F G] by simp
          thus ?thesis
            using assms 1 2 3 REP_in_Map [of "F \<odot> G"] by simp
        qed
        ultimately show ?thesis
          using B.iso_class_def by simp
      qed
 
      text \<open>
        We now show that \<open>Maps(B)\<close> has pullbacks.  For this we need to exhibit
        functions \<open>PRJ\<^sub>0\<close> and \<open>PRJ\<^sub>1\<close> that produce the legs of the pullback of a cospan \<open>(H, K)\<close>
        and verify that they have the required universal property.  These are obtained by
        choosing representatives \<open>h\<close> and \<open>k\<close> of \<open>H\<close> and \<open>K\<close>, respectively, and then taking
        \<open>PRJ\<^sub>0 = CLS (tab\<^sub>0 (k\<^sup>* \<star> h))\<close> and \<open>PRJ\<^sub>1 = CLS (tab\<^sub>1 (k\<^sup>* \<star> h))\<close>.  That these constitute a
        pullback in \<open>Maps(B)\<close> follows from the fact that \<open>tab\<^sub>0 (k\<^sup>* \<star> h)\<close> and \<open>tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
        form a pseudo-pullback of \<open>(h, k)\<close> in the underlying bicategory.
 
        For our purposes here, it is not sufficient simply to show that \<open>Maps(B)\<close> has pullbacks
        and then to treat it as an abstract ``category with pullbacks'' where the pullbacks
        are chosen arbitrarily.  Instead, we have to retain the connection between a pullback
        in Maps and the tabulation of \<open>k\<^sup>* \<star> h\<close> that is ultimately used to obtain it.  If we don't
        do this, then it becomes problematic to define the compositor of a pseudofunctor from
        the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>, because the components will go from the
        apex of a composite span (obtained by pullback) to the apex of a tabulation (chosen
        arbitrarily using \<open>BS2\<close>) and these need not be in agreement with each other.
      \<close>
 
      definition PRJ\<^sub>0
      where "PRJ\<^sub>0 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>0 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
      definition PRJ\<^sub>1
      where "PRJ\<^sub>1 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>1 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
 
      interpretation elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
      proof
        show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>0 K H = null"
          unfolding PRJ\<^sub>0_def by auto
        show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>1 K H = null"
          unfolding PRJ\<^sub>1_def by auto
        show "\<And>H K. cospan K H \<Longrightarrow> commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
        proof -
          fix H K
          assume HK: "cospan K H"
          define h where "h = REP H"
          define k where "k = REP K"
          have h: "h \<in> Map H"
            using h_def HK REP_in_Map by blast
          have k: "k \<in> Map K"
            using k_def HK REP_in_Map by blast
          have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
            using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
                  in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
                  in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
            apply auto
            by (metis (no_types, lifting) HK Dom_cod)
          interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
            using 1 by unfold_locales auto
          interpret k: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg k
            using 1 by unfold_locales auto
          interpret hk: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h k
            using 1 by unfold_locales auto
          let ?f = "B.tab\<^sub>0 (k\<^sup>* \<star> h)"
          let ?g = "B.tab\<^sub>1 (k\<^sup>* \<star> h)"
          have span: "span \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
            using dom_char CLS_in_hom [of ?f] CLS_in_hom [of ?g] by auto
          have seq: "seq H \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
            using HK seq_char hk.leg0_is_map CLS_in_hom h_def hk.p\<^sub>0_simps hk.satisfies_T0
            by fastforce
          have seq': "seq K \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
            using HK k arr_char dom_char cod_char in_HomD(5) hk.leg1_is_map CLS_in_hom
            by (metis (no_types, lifting) Cod.simps(1) seq_char REP_simps(2)
                hk.p\<^sub>1_simps k_def span)
          show "commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
          proof
            show "cospan K H"
              using HK by simp
            show "dom K = cod (PRJ\<^sub>1 K H)"
              using seq' PRJ\<^sub>1_def HK h_def k_def by auto
            show "span (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
              unfolding PRJ\<^sub>0_def PRJ\<^sub>1_def using HK span h_def k_def by simp
            show "K \<odot> PRJ\<^sub>1 K H = H \<odot> PRJ\<^sub>0 K H"
            proof -
              have iso: "h \<star> ?f \<cong>\<^sub>B k \<star> ?g"
                using hk.\<phi>_uniqueness B.isomorphic_symmetric B.isomorphic_def by blast
              have *: "Comp (Map H) \<lbrakk>?f\<rbrakk>\<^sub>B = Comp (Map K) \<lbrakk>?g\<rbrakk>\<^sub>B"
              proof (intro Comp_eqI)
                show "h \<star> ?f \<in> Comp (Map H) \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
                proof (unfold Comp_def)
                  have "B.is_iso_class \<lbrakk>?f\<rbrakk>\<^sub>B"
                    by (simp add: B.is_iso_classI)
                  moreover have "B.is_iso_class (Map H)"
                    using CLS_REP HK Map.simps(1) B.is_iso_classI h.ide_left h_def
                    by (metis (no_types, lifting))
                  moreover have "?f \<in> \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
                    by (simp add: B.ide_in_iso_class(1))
                  moreover have "\<guillemotleft>?f : src (B.tab\<^sub>0 (k\<^sup>* \<star> h)) \<rightarrow>\<^sub>B Dom H\<guillemotright>"
                    using seq seq_char by simp
                  moreover have "h \<in> Map H"
                    by fact
                  moreover have "\<guillemotleft>h : Dom H \<rightarrow>\<^sub>B Cod H\<guillemotright>"
                    by (simp add: HK h_def)
                  moreover have "h \<star> ?f \<cong>\<^sub>B h \<star> ?f"
                    using B.isomorphic_reflexive by auto
                  ultimately show "h \<star> B.tab\<^sub>0 (k\<^sup>* \<star> h)
                                     \<in> {h'. B.is_iso_class \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
                                            B.is_iso_class (Map H) \<and>
                                            (\<exists>f g. f \<in> \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
                                                   g \<in> Map H \<and> g \<star> f \<cong>\<^sub>B h')}"
                    by auto
                qed
                show "k \<star> ?g \<in> Comp (Map K) \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
                proof (unfold Comp_def)
                  have "B.is_iso_class \<lbrakk>?g\<rbrakk>\<^sub>B"
                    by (simp add: B.is_iso_classI)
                  moreover have "B.is_iso_class (Map K)"
                    by (metis (no_types, lifting) CLS_REP HK Map.simps(1)
                        B.is_iso_classI k.ide_left k_def)
                  moreover have "?g \<in> \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
                    by (simp add: B.ide_in_iso_class(1))
                  moreover have "\<guillemotleft>?g : src (B.tab\<^sub>1 (k\<^sup>* \<star> h)) \<rightarrow>\<^sub>B Dom K\<guillemotright>"
                    using seq seq_char B.in_hhom_def seq' by auto
                  moreover have "k \<in> Map K"
                    by fact
                  moreover have "\<guillemotleft>k : Dom K \<rightarrow>\<^sub>B Cod K\<guillemotright>"
                    by (simp add: HK k_def)
                  moreover have "k \<star> ?g \<cong>\<^sub>B k \<star> ?g"
                    using B.isomorphic_reflexive iso B.isomorphic_implies_hpar(2) by auto
                  ultimately show "k \<star> B.tab\<^sub>1 (k\<^sup>* \<star> h)
                                     \<in> {h'. B.is_iso_class \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
                                            B.is_iso_class (Map K) \<and>
                                            (\<exists>f g. f \<in> \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
                                                   g \<in> Map K \<and> g \<star> f \<cong>\<^sub>B h')}"
                    by auto
                qed
                show "h \<star> ?f \<cong>\<^sub>B k \<star> ?g"
                  using iso by simp
              qed
              have "K \<odot> PRJ\<^sub>1 K H = K \<odot> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
                unfolding PRJ\<^sub>1_def using HK h_def k_def by simp
              also have "... = MkArr (src ?g) (Cod K) (Comp (Map K) \<lbrakk>?g\<rbrakk>\<^sub>B)"
                using seq' comp_char [of K "\<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"] by simp
              also have "... = MkArr (src ?f) (Cod H) (Comp (Map H) \<lbrakk>?f\<rbrakk>\<^sub>B)"
                using * HK cod_char by auto
              also have "... = comp H \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
                using seq comp_char [of H "\<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"] by simp
              also have "... = comp H (PRJ\<^sub>0 K H)"
                unfolding PRJ\<^sub>0_def using HK h_def k_def by simp
              finally show ?thesis by simp
            qed
          qed
        qed
        show "\<And>H K U V. commutative_square K H V U \<Longrightarrow>
                         \<exists>!E. comp (PRJ\<^sub>1 K H) E = V \<and> comp (PRJ\<^sub>0 K H) E = U"
        proof -
          fix H K U V
          assume cs: "commutative_square K H V U"
          have HK: "cospan K H"
            using cs by auto
          (* TODO: Is there any way to avoid this repetition? *)
          define h where "h = REP H"
          define k where "k = REP K"
          have h: "h \<in> Map H"
            using h_def HK REP_in_Map by blast
          have k: "k \<in> Map K"
            using k_def HK REP_in_Map by blast
          have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
            using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
                  in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
                  in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
            apply auto
            by (metis (no_types, lifting) HK Dom_cod)
          interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
            using 1 by unfold_locales auto
          interpret k: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg k
            using 1 by unfold_locales auto
          interpret hk: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h k
            using 1 by unfold_locales auto
          let ?f = "B.tab\<^sub>0 (k\<^sup>* \<star> h)"
          let ?g = "B.tab\<^sub>1 (k\<^sup>* \<star> h)"
          have seq_HU: "seq H U"
            using cs by auto 
          have seq_KV: "seq K V"
            using cs by auto 
          let ?u = "REP U"
          let ?v = "REP V"
          have u: "B.ide ?u"
            using ide_REP seq_HU by auto
          have v: "B.ide ?v"
            using ide_REP seq_KV by auto
          have u_is_map: "B.is_left_adjoint ?u"
            using u seq_HU REP_in_Map arr_char [of U]
                  in_HomD(5) [of "Map U" "Dom U" "Cod U" ?u]
            by auto
          have v_is_map: "B.is_left_adjoint ?v"
            using v seq_KV REP_in_Map arr_char [of V]
                  in_HomD(5) [of "Map V" "Dom V" "Cod V" ?v]
            by auto
          have *: "h \<star> ?u \<cong>\<^sub>B k \<star> ?v"
          proof -
            have "h \<star> ?u \<cong>\<^sub>B REP (H \<odot> U)"
            proof -
              have "h \<star> ?u \<cong>\<^sub>B REP H \<star> ?u"
              proof -
                have "h \<cong>\<^sub>B REP H"
                  using h h_def HK arr_char REP_in_Map B.iso_class_elems_isomorphic
                        in_HomD(5) [of "Map H" "Dom H" "Cod H" h] B.isomorphic_reflexive
                  by auto
                thus ?thesis
                  using h_def seq_HU B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
                  by (simp add: seq_char)
              qed
              also have "...  \<cong>\<^sub>B REP (H \<odot> U)"
                using seq_HU isomorphic_hcomp_REP isomorphic_def by blast
              finally show ?thesis by blast
            qed
            also have "... \<cong>\<^sub>B REP (K \<odot> V)"
              using seq_HU cs B.isomorphic_reflexive by auto
            also have "... \<cong>\<^sub>B (k \<star> ?v)"
            proof -
              have "... \<cong>\<^sub>B REP K \<star> ?v"
                using seq_KV isomorphic_hcomp_REP B.isomorphic_def B.isomorphic_symmetric
                by blast
              also have "... \<cong>\<^sub>B k \<star> ?v"
              proof -
                have "k \<cong>\<^sub>B REP K"
                  using k k_def HK arr_char REP_in_Map B.iso_class_elems_isomorphic
                        in_HomD(5) [of "Map K" "Dom K" "Cod K" k] B.isomorphic_reflexive
                  by auto
                thus ?thesis
                  using k_def seq_KV B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
                  by (simp add: seq_char)
              qed 
              finally show ?thesis by blast
            qed
            finally show ?thesis by blast
          qed
          have hseq_hu: "src h = trg ?u"
            using * B.isomorphic_implies_hpar
            by (meson B.hseqE B.ideD(1))
          have hseq_kv: "src k = trg ?v"
            using * B.isomorphic_implies_hpar
            by (meson B.hseqE B.ideD(1))
 
          obtain w where w: "B.is_left_adjoint w \<and> ?f \<star> w \<cong>\<^sub>B ?u \<and> ?v \<cong>\<^sub>B (?g \<star> w)"
            using * u_is_map v_is_map hk.has_pseudo_pullback [of ?u ?v] B.isomorphic_symmetric
            by blast
          have w_in_hom: "\<guillemotleft>w : src ?u \<rightarrow>\<^sub>B src ?f\<guillemotright> \<and> B.ide w"
            using w B.left_adjoint_is_ide B.src_cod B.trg_cod B.isomorphic_def
            by (metis B.hseqE B.ideD(1) B.in_hhom_def B.isomorphic_implies_hpar(3)
                B.isomorphic_implies_ide(1) B.src_hcomp)
          let ?W = "CLS w"
          have W: "\<guillemotleft>?W : dom U \<rightarrow> dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>\<guillemotright>"
          proof
            show "arr ?W"
              using w CLS_in_hom by blast
            thus "dom ?W = dom U"
              using w_in_hom dom_char REP_in_hhom(1) CLS_in_hom
              by (metis (no_types, lifting) Dom.simps(1) commutative_squareE
                  dom_char REP_simps(2) cs B.in_hhomE)
            show "cod ?W = dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
            proof -
              have "src ?f = trg w"
                by (metis (lifting) B.in_hhomE w_in_hom)
              thus ?thesis
                using CLS_in_hom [of ?f] CLS_in_hom [of w] hk.satisfies_T0 w by fastforce
            qed
          qed
          show "\<exists>!E. PRJ\<^sub>1 K H \<odot> E = V \<and> PRJ\<^sub>0 K H \<odot> E = U"
          proof -
            have "PRJ\<^sub>1 K H \<odot> ?W = V \<and> PRJ\<^sub>0 K H \<odot> ?W = U"
            proof -
              have "\<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<odot> ?W = U"
                using w w_in_hom u CLS_in_hom comp_CLS
                      B.isomorphic_symmetric CLS_REP hk.leg0_is_map
                by (metis (mono_tags, lifting) commutative_square_def cs)
              moreover have "\<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<odot> ?W = V"
                using w w_in_hom v CLS_in_hom comp_CLS
                      B.isomorphic_symmetric CLS_REP hk.leg1_is_map
                by (metis (mono_tags, lifting) commutative_square_def cs)
              ultimately show ?thesis
                using HK h_def k_def PRJ\<^sub>0_def PRJ\<^sub>1_def by auto
            qed
            moreover have
              "\<And>W'. PRJ\<^sub>1 K H \<odot> W' = V \<and> PRJ\<^sub>0 K H \<odot> W' = U \<Longrightarrow> W' = ?W"
            proof -
               fix W'
               assume "PRJ\<^sub>1 K H \<odot> W' = V \<and> PRJ\<^sub>0 K H \<odot> W' = U"
               hence W': "\<guillemotleft>W' : dom U \<rightarrow> dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>\<guillemotright> \<and> \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<odot> W' = U \<and> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<odot> W' = V"
                 using PRJ\<^sub>0_def PRJ\<^sub>1_def HK h_def k_def apply simp
                 using cs arr_iff_in_hom by blast
               let ?w' = "REP W'"
               have w': "B.ide ?w'"
                 using W' ide_REP by auto
 
               have fw'_iso_u: "?f \<star> ?w' \<cong>\<^sub>B ?u"
               proof -
                 have "?f \<star> ?w' \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<star> ?w'"
                   by (metis (no_types, lifting) Cod.simps(1) in_hom_char
                       REP_CLS REP_simps(3) W W' B.hcomp_isomorphic_ide hk.satisfies_T0
                       B.in_hhomE B.isomorphic_symmetric w' w_in_hom)
                 also have "REP \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<star> ?w' \<cong>\<^sub>B ?u"
                    using W' isomorphic_hcomp_REP cs by blast
                 finally show ?thesis by blast
               qed
 
               have gw'_iso_v: "?g \<star> ?w' \<cong>\<^sub>B ?v"
               proof -
                 have "?g \<star> ?w' \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<star> ?w'"
                 proof -
                   have "?g \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
                     using REP_CLS B.isomorphic_symmetric hk.leg1_is_map by blast
                   moreover have "B.ide (REP W')"
                     using W' by auto
                   moreover have "src ?f = trg ?w'"
                     using w_in_hom W W' in_hom_char arr_char B.in_hhom_def
                     by (meson fw'_iso_u B.hseqE B.ideD(1) B.isomorphic_implies_ide(1))
                   ultimately show ?thesis
                     using B.hcomp_isomorphic_ide by simp
                 qed
                 also have "... \<cong>\<^sub>B ?v"
                    using W' isomorphic_hcomp_REP cs by blast
                 finally show ?thesis by blast
               qed
 
               show "W' = ?W"
               proof -
                 have "W' = \<lbrakk>\<lbrakk>?w'\<rbrakk>\<rbrakk>"
                   using w' W' CLS_REP by auto
                 also have "... = ?W"
                 proof -
                   have "?w' \<cong>\<^sub>B w"
                     using * w W' hk.has_pseudo_pullback(2) u_is_map v_is_map
                           B.isomorphic_symmetric fw'_iso_u gw'_iso_v
                     by blast
                   thus ?thesis
                     using CLS_eqI B.iso_class_eqI w' by blast
                 qed
                 finally show ?thesis by blast
               qed
             qed
             ultimately show ?thesis by auto
           qed
         qed
       qed
 
     lemma is_elementary_category_with_pullbacks:
     shows "elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1"
        ..
 
     lemma is_category_with_pullbacks:
     shows "category_with_pullbacks comp"
       ..
 
     sublocale elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
       using is_elementary_category_with_pullbacks by simp
 
   end
 
   text \<open>
     Here we relate the projections of the chosen pullbacks in \<open>Maps(B)\<close> to the
     projections associated with the chosen tabulations in \<open>B\<close>.
   \<close>
 
   context composite_tabulation_in_maps
   begin
 
     interpretation Maps: maps_category V H \<a> \<i> src trg
       ..
 
     interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0
       using \<rho>.leg0_is_map \<sigma>.leg1_is_map composable by unfold_locales auto
 
     lemma prj_char:
     shows "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
     and "Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
     proof -
       have "Maps.arr (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
         using \<sigma>.leg1_in_hom Maps.CLS_in_hom \<sigma>.leg1_is_map Maps.arr_char by auto
       moreover have "Maps.arr (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
         using Maps.CLS_in_hom composable r\<^sub>0s\<^sub>1.k_is_map by fastforce
       moreover have "Maps.cod (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>) =
                      Maps.cod (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
         unfolding Maps.arr_char
         using \<sigma>.leg1_in_hom \<rho>.leg0_in_hom
         by (simp add: Maps.cod_char calculation(1) calculation(2))
       ultimately have "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> =
                        \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
                               Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk> \<and>
                        Maps.PRJ\<^sub>1 (Maps.CLS r\<^sub>0) (Maps.CLS s\<^sub>1) =
                        \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
                               Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk>"
         unfolding Maps.PRJ\<^sub>0_def Maps.PRJ\<^sub>1_def
         using Maps.CLS_in_hom \<sigma>.leg1_is_map \<rho>.leg0_is_map composable by simp
       moreover have "r\<^sub>0\<^sup>* \<star> s\<^sub>1 \<cong> (Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
                                 Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
       proof -
         have "r\<^sub>0 \<cong> Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
           using Maps.REP_CLS composable isomorphic_symmetric r\<^sub>0s\<^sub>1.k_is_map by fastforce
         hence 3: "isomorphic r\<^sub>0\<^sup>* (Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>*"
           using \<rho>.leg0_is_map
           by (simp add: isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint)
         moreover have 4: "s\<^sub>1 \<cong> Maps.REP (Maps.MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
           using Maps.REP_CLS isomorphic_symmetric r\<^sub>0s\<^sub>1.h_is_map by fastforce
         ultimately show ?thesis
         proof -
           have 1: "src r\<^sub>0\<^sup>* = trg s\<^sub>1"
             using \<rho>.T0.antipar(2) r\<^sub>0s\<^sub>1.cospan by argo
           have 2: "ide s\<^sub>1"
             by simp
           have "src (Maps.REP (Maps.MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* = trg s\<^sub>1"
             by (metis 3 \<rho>.T0.antipar(2) isomorphic_implies_hpar(3) r\<^sub>0s\<^sub>1.cospan)
           thus ?thesis
             using 1 2
             by (meson 3 4 hcomp_ide_isomorphic hcomp_isomorphic_ide isomorphic_implies_ide(2)
                 isomorphic_transitive)
         qed
       qed
       ultimately have 1: "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk> \<and>
                           Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
         using r\<^sub>0s\<^sub>1.isomorphic_implies_same_tab by simp
       show "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
         using 1 by simp
       show "Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
         using 1 by simp
     qed
 
   end
 
   context identity_in_bicategory_of_spans
   begin
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     notation isomorphic (infix "\<cong>" 50)
 
     text \<open>
       A 1-cell \<open>r\<close> in a bicategory of spans is a map if and only if the ``input leg''
       \<open>tab\<^sub>0 r\<close> of the chosen tabulation of \<open>r\<close> is an equivalence map.
       Since a tabulation of \<open>r\<close> is unique up to equivalence, and equivalence maps compose,
       the result actually holds if ``chosen tabulation'' is replaced by ``any tabulation''.
     \<close>
 
     lemma is_map_iff_tab\<^sub>0_is_equivalence:
     shows "is_left_adjoint r \<longleftrightarrow> equivalence_map (tab\<^sub>0 r)"
     proof
       assume 1: "equivalence_map (tab\<^sub>0 r)"
       have 2: "quasi_inverses (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>*"
       proof -
         obtain g' \<eta>' \<epsilon>' where \<eta>'\<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) g' \<eta>' \<epsilon>'"
           using 1 equivalence_map_def by auto
         have "adjoint_pair (tab\<^sub>0 r) g'"
           using \<eta>'\<epsilon>' quasi_inverses_def quasi_inverses_are_adjoint_pair by blast
         moreover have "adjoint_pair (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>*"
           using T0.adjunction_in_bicategory_axioms adjoint_pair_def by auto
         ultimately have "g' \<cong> (tab\<^sub>0 r)\<^sup>*"
           using left_adjoint_determines_right_up_to_iso by simp
         thus ?thesis
           using \<eta>'\<epsilon>' quasi_inverses_def quasi_inverses_isomorphic_right by blast
       qed
       obtain \<eta>' \<epsilon>' where \<eta>'\<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>* \<eta>' \<epsilon>'"
         using 2 quasi_inverses_def by auto
       interpret \<eta>'\<epsilon>': equivalence_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close> \<open>(tab\<^sub>0 r)\<^sup>*\<close> \<eta>' \<epsilon>'
         using \<eta>'\<epsilon>' by auto
       have "is_left_adjoint (tab\<^sub>0 r)\<^sup>*"
         using 2 quasi_inverses_are_adjoint_pair quasi_inverses_symmetric by blast
       hence "is_left_adjoint (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*)"
         using left_adjoints_compose by simp
       thus "is_left_adjoint r"
         using yields_isomorphic_representation isomorphic_def left_adjoint_preserved_by_iso'
         by meson
       next
       assume 1: "is_left_adjoint r"
       have 2: "is_left_adjoint (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*)"
         using 1 yields_isomorphic_representation left_adjoint_preserved_by_iso'
               isomorphic_symmetric isomorphic_def
         by meson
       hence "is_left_adjoint (tab\<^sub>0 r)\<^sup>*"
         using is_ide BS4 [of "tab\<^sub>1 r" "(tab\<^sub>0 r)\<^sup>*"] by auto
       hence "is_left_adjoint ((tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>0 r) \<and> is_left_adjoint (tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
         using left_adjoints_compose T0.antipar by simp
       hence 3: "iso \<eta> \<and> iso \<epsilon>"
         using BS3 [of "src (tab\<^sub>0 r)" "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>0 r" \<eta> \<eta>]
               BS3 [of "tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*" "trg (tab\<^sub>0 r)" \<epsilon> \<epsilon>]
               T0.unit_in_hom T0.counit_in_hom obj_is_self_adjoint
         by auto
       hence "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>* \<eta> \<epsilon>"
         apply unfold_locales by auto
       thus "equivalence_map (tab\<^sub>0 r)"
         using equivalence_map_def by blast
     qed
 
     text \<open>
       The chosen tabulation (and indeed, any other tabulation, which is equivalent)
       of an object is symmetric in the sense that its two legs are isomorphic.
     \<close>
 
     lemma obj_has_symmetric_tab:
     assumes "obj r"
     shows "tab\<^sub>0 r \<cong> tab\<^sub>1 r"
     proof -
       have "tab\<^sub>0 r \<cong> r \<star> tab\<^sub>0 r"
       proof -
         have "trg (tab\<^sub>0 r) = r"
           using assms by auto
         moreover have "\<guillemotleft>\<l>\<^sup>-\<^sup>1[tab\<^sub>0 r] : tab\<^sub>0 r \<Rightarrow> trg (tab\<^sub>0 r) \<star> tab\<^sub>0 r\<guillemotright> \<and> iso \<l>\<^sup>-\<^sup>1[tab\<^sub>0 r]"
           using assms by simp
         ultimately show ?thesis
           unfolding isomorphic_def by metis
       qed
       also have "... \<cong> tab\<^sub>1 r"
       proof -
         have "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
           using tab_in_hom by simp
         moreover have "is_left_adjoint (r \<star> tab\<^sub>0 r)"
           using assms left_adjoints_compose obj_is_self_adjoint by simp
         ultimately show ?thesis
           using BS3 [of "tab\<^sub>1 r" "r \<star> tab\<^sub>0 r" tab tab] isomorphic_symmetric isomorphic_def
           by auto
       qed
       finally show ?thesis by simp
     qed
 
     text \<open>
       The chosen tabulation of \<open>r\<close> determines a span in \<open>Maps(B)\<close>.
     \<close>
 
     lemma determines_span:
     assumes "ide r"
     shows "span_in_category Maps.comp \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>\<rparr>"
       using assms Maps.CLS_in_hom [of "tab\<^sub>0 r"] Maps.CLS_in_hom [of "tab\<^sub>1 r"]
             tab\<^sub>0_in_hom tab\<^sub>1_in_hom
       apply unfold_locales by fastforce
 
   end
 
   subsection "Arrows of Tabulations in Maps"
 
   text \<open>
     Here we consider the situation of two tabulations: a tabulation \<open>\<rho>\<close> of \<open>r\<close>
     and a tabulation \<open>\<sigma>\<close> of \<open>s\<close>, both ``legs'' of each tabulation being maps,
     together  with an arbitrary 2-cell \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close>.
     The 2-cell \<open>\<mu>\<close> at the base composes with the tabulation \<open>\<rho>\<close> to yield a 2-cell
     \<open>\<Delta> = (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>\<close> ``over'' s.  By property \<open>T1\<close> of tabulation \<open>\<sigma>\<close>, this induces a map
     from the apex of \<open>\<rho>\<close> to the apex of \<open>\<sigma>\<close>, which together with the other data
     forms a triangular prism whose sides commute up to (unique) isomorphism.
   \<close>
   text \<open>
 $$
 \xymatrix{
   && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^<-1>\sigma} & \\
   &{\rm trg}~s && {\rm src}~s \ar[ll]^{s} \\
   & \rrtwocell\omit{^\mu} &&\\
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar@ {.>}[uuur]^<>(0.3){{\rm chine}} \dtwocell\omit{^\rho}& \\
   {\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r \ar[ll]^{r} \ar@ {=}[uuur]
 }
 $$
   \<close>
 
   locale arrow_of_tabulations_in_maps =
     bicategory_of_spans V H \<a> \<i> src trg +
     \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
     \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r :: 'a
   and \<rho> :: 'a
   and r\<^sub>0 :: 'a
   and r\<^sub>1 :: 'a
   and s :: 'a
   and \<sigma> :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a
   and \<mu> :: 'a +
   assumes in_hom: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
   begin
 
     abbreviation (input) \<Delta>
     where "\<Delta> \<equiv> (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>"
 
     lemma \<Delta>_in_hom [intro]:
     shows "\<guillemotleft>\<Delta> : src \<rho> \<rightarrow> trg \<sigma>\<guillemotright>"
     and "\<guillemotleft>\<Delta> : r\<^sub>1 \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>"
     proof -
       show "\<guillemotleft>\<Delta> : r\<^sub>1 \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>"
         using in_hom \<rho>.leg0_in_hom(2) \<rho>.tab_in_vhom' by auto
       thus "\<guillemotleft>\<Delta> : src \<rho> \<rightarrow> trg \<sigma>\<guillemotright>"
         by (metis \<rho>.tab_simps(3) \<rho>.base_in_hom(2) \<sigma>.tab_simps(3) \<sigma>.base_in_hom(2) arrI in_hom
             seqI' vcomp_in_hhom vseq_implies_hpar(1-2))
     qed
 
     lemma \<Delta>_simps [simp]:
     shows "arr \<Delta>"
     and "src \<Delta> = src \<rho>" and "trg \<Delta> = trg \<sigma>"
     and "dom \<Delta> = r\<^sub>1" and "cod \<Delta> = s \<star> r\<^sub>0"
       using \<Delta>_in_hom by auto
 
     abbreviation is_induced_map
     where "is_induced_map w \<equiv> \<sigma>.is_induced_by_cell w r\<^sub>0 \<Delta>"
 
     text \<open>
       The following is an equivalent restatement, in elementary terms, of the conditions
       for being an induced map.
     \<close>
 
     abbreviation (input) is_induced_map'
     where "is_induced_map' w \<equiv>
            ide w \<and>
            (\<exists>\<nu> \<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                   \<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>)"
 
     lemma is_induced_map_iff:
     shows "is_induced_map w \<longleftrightarrow> is_induced_map' w"
     proof
       assume w: "is_induced_map' w"
       show "is_induced_map w"
       proof
         have 1: "dom \<Delta> = r\<^sub>1"
           by auto
         interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg
                        r\<^sub>0 \<open>dom \<Delta>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w
         proof -
           have "arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w"
             using w apply unfold_locales by auto
           thus "arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s \<sigma> s\<^sub>0 s\<^sub>1 w"
             using 1 by simp
         qed
         show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s\<^sub>0 s\<^sub>1 w"
           using w.arrow_of_spans_of_maps_axioms by auto
         show "\<sigma>.composite_cell w w.the_\<theta> \<cdot> w.the_\<nu> = \<Delta>"
         proof -
           obtain \<theta> \<nu>
           where \<theta>\<nu>: "\<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                      \<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>"
             using w w.the_\<theta>_props(1) by auto
           have "(s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu> = \<Delta>"
             using \<theta>\<nu> by argo
           moreover have "\<theta> = w.the_\<theta> \<and> \<nu> = w.the_\<nu>"
             using \<theta>\<nu> 1 w.the_\<nu>_props(1) w.leg0_uniquely_isomorphic w.leg1_uniquely_isomorphic
             by auto
           ultimately show ?thesis
             using comp_assoc by simp
         qed
       qed
       next
       assume w: "is_induced_map w"
       show "is_induced_map' w"
       proof -
         interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w
           using w in_hom by auto
         interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w
           ..
         have "dom \<Delta> = r\<^sub>1" by auto
         thus ?thesis
           using w comp_assoc w.the_\<nu>_props(1) w.the_\<nu>_props(2) w.uw\<theta> by metis
       qed
     qed
 
     lemma exists_induced_map:
     shows "\<exists>w. is_induced_map w"
     proof -
       obtain w \<theta> \<nu>
       where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                   \<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>"
         using \<Delta>_in_hom \<rho>.ide_leg0 \<sigma>.T1 comp_assoc
         by (metis in_homE)
       thus ?thesis
         using is_induced_map_iff by blast
     qed
 
     lemma induced_map_unique:
     assumes "is_induced_map w" and "is_induced_map w'"
     shows "w \<cong> w'"
       using assms \<sigma>.induced_map_unique by blast
 
     definition chine
     where "chine \<equiv> SOME w. is_induced_map w"
 
     lemma chine_is_induced_map:
     shows "is_induced_map chine"
       unfolding chine_def
       using exists_induced_map someI_ex [of is_induced_map] by simp
 
     lemma chine_in_hom [intro]:
     shows "\<guillemotleft>chine : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>"
     and "\<guillemotleft>chine: chine \<Rightarrow> chine\<guillemotright>"
     proof -
       show "\<guillemotleft>chine : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>"
         using chine_is_induced_map
         by (metis \<Delta>_simps(1) \<Delta>_simps(4) \<rho>.leg1_simps(3) \<sigma>.ide_base \<sigma>.ide_leg0 \<sigma>.leg0_simps(3)
             \<sigma>.tab_simps(2) arrow_of_spans_of_maps.is_ide arrow_of_spans_of_maps.the_\<nu>_simps(2)
             assoc_simps(2) hseqE in_hhom_def seqE src_vcomp vseq_implies_hpar(1))
       show "\<guillemotleft>chine: chine \<Rightarrow> chine\<guillemotright>"
         using chine_is_induced_map
         by (meson arrow_of_spans_of_maps.is_ide ide_in_hom(2))
     qed
 
     lemma chine_simps [simp]:
     shows "arr chine" and "ide chine"
     and "src chine = src r\<^sub>0" and "trg chine = src s\<^sub>0"
     and "dom chine = chine" and "cod chine = chine"
       using chine_in_hom apply auto
       by (meson arrow_of_spans_of_maps.is_ide chine_is_induced_map)
 
   end
 
   sublocale arrow_of_tabulations_in_maps \<subseteq>
             arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 chine
       using chine_is_induced_map is_induced_map_iff
       by unfold_locales auto
 
   sublocale arrow_of_tabulations_in_maps \<subseteq>
             arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 chine
       ..
 
   context arrow_of_tabulations_in_maps
   begin
 
     text \<open>
       The two factorizations of the composite 2-cell \<open>\<Delta>\<close> amount to a naturality condition.
     \<close>
 
     lemma \<Delta>_naturality:
     shows "(\<mu> \<star> r\<^sub>0) \<cdot> \<rho> = (s \<star> the_\<theta>) \<cdot> \<a>[s, s\<^sub>0, chine] \<cdot> (\<sigma> \<star> chine) \<cdot> the_\<nu>"
       using chine_is_induced_map is_induced_map_iff
       by (metis leg0_uniquely_isomorphic(2) leg1_uniquely_isomorphic(2) the_\<nu>_props(1) uw\<theta>)
 
     lemma induced_map_preserved_by_iso:
     assumes "is_induced_map w" and "isomorphic w w'"
     shows "is_induced_map w'"
     proof -
       interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w
         using assms in_hom by auto
       interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w
         ..
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow> w'\<guillemotright> \<and> iso \<phi>"
         using assms(2) isomorphic_def by auto
       show ?thesis
       proof
         interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<Delta>\<close> s\<^sub>0 s\<^sub>1 w'
         proof
           show "is_left_adjoint r\<^sub>0"
             by (simp add: \<rho>.satisfies_T0)
           show "is_left_adjoint (dom \<Delta>)"
             by (simp add: \<rho>.leg1_is_map)
           show "ide w'" using assms by force
           show "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
             using \<phi> w.the_\<theta>_props \<sigma>.leg0_in_hom(2) assms(2) comp_in_homI hcomp_in_vhom
                   inv_in_hom isomorphic_implies_hpar(4) w.the_\<theta>_simps(4) w.w_simps(4)
             by metis
           have "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
           proof (intro conjI)
             show "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
               using \<phi> w.the_\<nu>_props
               by (intro comp_in_homI, auto)
             thus "iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
               using \<phi> w.the_\<nu>_props
               by (meson \<sigma>.ide_leg1 arrI iso_hcomp hseqE ide_is_iso isos_compose seqE)
           qed
           hence "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>"
             by auto
           thus "\<exists>\<nu>. \<guillemotleft>\<nu> : dom \<Delta> \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>"
             by auto
         qed
         interpret w': arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg
                         r\<^sub>0 \<open>dom \<Delta>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w'
           ..
         show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s\<^sub>0 s\<^sub>1 w'"
           using w'.arrow_of_spans_of_maps_axioms by auto
         show "\<sigma>.composite_cell w' w'.the_\<theta> \<cdot> w'.the_\<nu> = \<Delta>"
         proof -
           have 1: "w'.the_\<theta> = w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)" 
           proof -
             have "\<guillemotleft>w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>) : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
               using w.the_\<theta>_props \<phi>
               by (intro comp_in_homI, auto)
             moreover have "\<guillemotleft>w'.the_\<theta> : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
               using w'.the_\<theta>_props by simp
             ultimately show ?thesis
               using w'.leg0_uniquely_isomorphic(2) by blast
           qed
           moreover have "w'.the_\<nu> = (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
           proof -
             have "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : dom \<Delta> \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
               using w.the_\<nu>_props \<phi>
               by (intro comp_in_homI, auto)
             moreover have "iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
               using w.the_\<nu>_props \<phi> iso_hcomp
               by (meson \<sigma>.ide_leg1 arrI calculation hseqE ide_is_iso isos_compose seqE)
             ultimately show ?thesis
               using w'.the_\<nu>_props w'.leg1_uniquely_isomorphic(2) by blast
           qed
           ultimately have "\<sigma>.composite_cell w' w'.the_\<theta> \<cdot> w'.the_\<nu> =
                            \<sigma>.composite_cell w' (w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)) \<cdot> (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
             by simp
           also have "... = (s \<star> w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot>
                              (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
             using comp_assoc by presburger
           also have "... = (s \<star> w.the_\<theta>) \<cdot> ((s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot>
                              (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>)) \<cdot> w.the_\<nu>"
             using 1 comp_assoc w'.the_\<theta>_simps(1) whisker_left
             by auto
           also have "... = (s \<star> w.the_\<theta>) \<cdot> (\<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)) \<cdot> w.the_\<nu>"
           proof -
             have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) =
                   \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)"
             proof -
               have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) =
                     \<a>[s, s\<^sub>0, w] \<cdot> ((s \<star> s\<^sub>0) \<star> inv \<phi>) \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>)"
               proof -
                 have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] = \<a>[s, s\<^sub>0, w] \<cdot> ((s \<star> s\<^sub>0) \<star> inv \<phi>)"
                   using assms \<phi> assoc_naturality [of s s\<^sub>0 "inv \<phi>"] w.w_simps(4)
                   by (metis \<sigma>.leg0_simps(2-5) \<sigma>.base_simps(2-4) arr_inv cod_inv dom_inv
                       in_homE trg_cod)
                 thus ?thesis using comp_assoc by metis
               qed
               also have "... = \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>)"
               proof -
                 have "((s \<star> s\<^sub>0) \<star> inv \<phi>) \<cdot> (\<sigma> \<star> w') = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>)"
                   using \<phi> comp_arr_dom comp_cod_arr in_hhom_def
                         interchange [of "s \<star> s\<^sub>0" \<sigma> "inv \<phi>" w']
                         interchange [of \<sigma> s\<^sub>1 w "inv \<phi>"]
                   by auto
                thus ?thesis
                   using comp_assoc by metis
               qed
               also have "... = \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)"
               proof -
                 have "(\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>) = \<sigma> \<star> w"
                 proof -
                   have "(\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>) = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi> \<cdot> \<phi>)"
                     using \<phi> whisker_left in_hhom_def by auto
                   also have "... = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> w)"
                     using \<phi> comp_inv_arr' by auto
                   also have "... = \<sigma> \<star> w"
                     using whisker_right [of w \<sigma> s\<^sub>1] comp_arr_dom in_hhom_def by auto
                   finally show ?thesis by blast
                 qed
                 thus ?thesis by simp
               qed
               finally show ?thesis by simp
             qed
             thus ?thesis by simp
           qed
           also have "... = \<Delta>"
             using assms(1) comp_assoc w.is_ide w.the_\<nu>_props(1) w.the_\<theta>_props(1) by simp
           finally show ?thesis
             using comp_assoc by auto
         qed
       qed
     qed
 
   end
 
   text \<open>
     In the special case that \<open>\<mu>\<close> is an identity 2-cell, the induced map from the apex of \<open>\<rho>\<close>
     to the apex of \<open>\<sigma>\<close> is an equivalence map.
   \<close>
 
   locale identity_arrow_of_tabulations_in_maps =
     arrow_of_tabulations_in_maps +
   assumes is_ide: "ide \<mu>"
   begin
 
     lemma r_eq_s:
     shows "r = s"
       using is_ide by (metis ide_char in_hom in_homE)
 
     lemma \<Delta>_eq_\<rho>:
     shows "\<Delta> = \<rho>"
       by (meson \<Delta>_simps(1) comp_ide_arr ide_hcomp hseq_char' ide_u is_ide seqE
           seq_if_composable)
 
     lemma chine_is_equivalence:
     shows "equivalence_map chine"
     proof -
       obtain w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
         where e: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
                   \<guillemotleft>w : src s\<^sub>0 \<rightarrow> src r\<^sub>0\<guillemotright> \<and> \<guillemotleft>w' : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright> \<and>
                   \<guillemotleft>\<theta> : r\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : s\<^sub>1 \<Rightarrow> r\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                   \<sigma> = (s \<star> \<theta>) \<cdot> \<a>[s, r\<^sub>0, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> \<and>
                   \<guillemotleft>\<theta>' : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu>' : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
                   \<rho> = (s \<star> \<theta>') \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> \<nu>'"
         using r_eq_s \<sigma>.apex_unique_up_to_equivalence [of \<rho> r\<^sub>0 r\<^sub>1] \<rho>.tabulation_axioms by blast
       have w': "equivalence_map w'"
         using e equivalence_map_def by auto
       hence "is_induced_map w'"
         using e r_eq_s \<Delta>_eq_\<rho> is_induced_map_iff comp_assoc equivalence_map_is_ide by metis
       hence "isomorphic chine w'"
         using induced_map_unique chine_is_induced_map by simp
       thus ?thesis
         using w' equivalence_map_preserved_by_iso isomorphic_symmetric by blast
     qed
 
   end
 
   text \<open>
     The following gives an interpretation of @{locale arrow_of_tabulations_in_maps}
     in the special case that the tabulations are those that we have chosen for the
     domain and codomain of the underlying 2-cell \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close>.
     In this case, we can recover \<open>\<mu>\<close> from \<open>\<Delta>\<close> via adjoint transpose.
   \<close>
 
   locale arrow_in_bicategory_of_spans =
     bicategory_of_spans V H \<a> \<i> src trg +
     r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r +
     s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r :: 'a
   and s :: 'a
   and \<mu> :: 'a +
   assumes in_hom: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
   begin
 
     abbreviation (input) r\<^sub>0 where "r\<^sub>0 \<equiv> tab\<^sub>0 r"
     abbreviation (input) r\<^sub>1 where "r\<^sub>1 \<equiv> tab\<^sub>1 r"
     abbreviation (input) s\<^sub>0 where "s\<^sub>0 \<equiv> tab\<^sub>0 s"
     abbreviation (input) s\<^sub>1 where "s\<^sub>1 \<equiv> tab\<^sub>1 s"
 
     lemma is_arrow_of_tabulations_in_maps:
     shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 s s.tab s\<^sub>0 s\<^sub>1 \<mu>"
       using in_hom by unfold_locales auto
 
   end
 
   sublocale identity_in_bicategory_of_spans \<subseteq> arrow_in_bicategory_of_spans V H \<a> \<i> src trg r r r
     apply unfold_locales using is_ide by auto
 
   context arrow_in_bicategory_of_spans
   begin
 
     interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 s s.tab s\<^sub>0 s\<^sub>1 \<mu>
       using is_arrow_of_tabulations_in_maps by simp
     interpretation r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 r r.tab r\<^sub>0 r\<^sub>1 r
       using r.is_arrow_of_tabulations_in_maps by simp
 
     lemma \<mu>_in_terms_of_\<Delta>:
     shows "\<mu> = r.T0.trnr\<^sub>\<epsilon> (cod \<mu>) \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
     proof -
       have \<mu>: "arr \<mu>"
         using in_hom by auto
       have "\<mu> \<cdot> r.T0.trnr\<^sub>\<epsilon> r r.tab = r.T0.trnr\<^sub>\<epsilon> s \<Delta>"
       proof -
         have "\<mu> \<cdot> r.T0.trnr\<^sub>\<epsilon> r r.tab =
               (\<mu> \<cdot> \<r>[r]) \<cdot> (r \<star> r.\<epsilon>) \<cdot> \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
           unfolding r.T0.trnr\<^sub>\<epsilon>_def using comp_assoc by presburger
         also have "... = \<r>[s] \<cdot> ((\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>)) \<cdot>
                            \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
           using \<mu> runit_naturality comp_assoc
           by (metis in_hom in_homE)
         also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> ((\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot>
                            \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*]) \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
         proof -
           have "(\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>) = \<mu> \<star> r.\<epsilon>"
             using \<mu> interchange comp_arr_dom comp_cod_arr
             by (metis in_hom in_homE r.T0.counit_simps(1) r.T0.counit_simps(3) r.u_simps(3)
                 src_dom)
           also have "... = (s \<star> r.\<epsilon>) \<cdot> (\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
             using in_hom interchange [of s \<mu> r.\<epsilon> "tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*"]
                   comp_arr_dom comp_cod_arr r.T0.counit_simps(1) r.T0.counit_simps(2)
             by auto
           finally have "(\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>) = (s \<star> r.\<epsilon>) \<cdot> (\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
             by blast
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot>
                            ((\<mu> \<star> tab\<^sub>0 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
         proof -
           have "(\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot> \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] =
                 \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot> ((\<mu> \<star> tab\<^sub>0 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
             using \<mu> assoc_naturality [of \<mu> "tab\<^sub>0 r" "(tab\<^sub>0 r)\<^sup>*"]
             by (metis ide_char in_hom in_homE r.T0.antipar(1) r.T0.ide_right r.u_simps(3)
                 src_dom u_simps(2) u_simps(4-5))
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot>
                            ((\<mu> \<star> tab\<^sub>0 r) \<cdot> r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
           using \<mu> whisker_right \<Delta>_simps(1) by auto
         also have "... = r.T0.trnr\<^sub>\<epsilon> s \<Delta>"
           unfolding r.T0.trnr\<^sub>\<epsilon>_def by simp
         finally show ?thesis by blast
       qed
       thus ?thesis
         using \<mu> r.yields_isomorphic_representation invert_side_of_triangle(2)
         by (metis in_hom in_homE seqI')
     qed
 
   end
 
   subsubsection "Vertical Composite"
 
   locale vertical_composite_of_arrows_of_tabulations_in_maps =
     bicategory_of_spans V H \<a> \<i> src trg +
     \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
     \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 +
     \<tau>: tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 +
     \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 \<mu> +
     \<pi>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<pi>
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r :: 'a
   and \<rho> :: 'a
   and r\<^sub>0 :: 'a
   and r\<^sub>1 :: 'a
   and s :: 'a
   and \<sigma> :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a
   and t :: 'a
   and \<tau> :: 'a
   and t\<^sub>0 :: 'a
   and t\<^sub>1 :: 'a
   and \<mu> :: 'a
   and \<pi> :: 'a
   begin
 
     text \<open>
 $$
 \xymatrix{
   &&& {\rm src}~\tau \ar[dl]_{t_1} \ar[dr]^{t_0} \dtwocell\omit{^<-1>\tau} & \\
   &&{\rm trg}~t && {\rm src}~t \ar[ll]^{s} \\
   && \rrtwocell\omit{^\pi} && \\
   && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \ar[uuur]^<>(0.3){\pi.{\rm chine}} \dtwocell\omit{^<-1>\sigma} & \\
   &{\rm trg}~s \ar@ {=}[uuur] && {\rm src}~s \ar[ll]^{s} \ar@ {=}[uuur] \\
   & \rrtwocell\omit{^\mu} &&\\
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar[uuur]^<>(0.3){\mu.{\rm chine}} \dtwocell\omit{^\rho} & \\
   {\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r \ar[ll]^{r} \ar@ {=}[uuur]
 }
 $$
     \<close>
 
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<open>\<pi> \<cdot> \<mu>\<close>
       using \<mu>.in_hom \<pi>.in_hom by (unfold_locales, blast)
 
     lemma is_arrow_of_tabulations_in_maps:
     shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 (\<pi> \<cdot> \<mu>)"
       ..
 
     lemma chine_char:
     shows "chine \<cong> \<pi>.chine \<star> \<mu>.chine"
     proof -
       have "is_induced_map (\<pi>.chine \<star> \<mu>.chine)"
       proof -
         let ?f = "\<mu>.chine"
         have f: "\<guillemotleft>?f : src \<rho> \<rightarrow> src \<sigma>\<guillemotright> \<and> is_left_adjoint ?f \<and> ide ?f \<and> \<mu>.is_induced_map ?f"
           using \<mu>.chine_is_induced_map \<mu>.is_map by auto
         let ?g = "\<pi>.chine"
         have g: "\<guillemotleft>?g : src \<sigma> \<rightarrow> src \<tau>\<guillemotright> \<and> is_left_adjoint ?g \<and> ide ?g \<and> \<pi>.is_induced_map ?g"
           using \<pi>.chine_is_induced_map \<pi>.is_map by auto
         let ?\<theta> = "\<mu>.the_\<theta> \<cdot> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
         let ?\<nu> = "\<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
         have \<theta>: "\<guillemotleft>?\<theta> : t\<^sub>0 \<star> ?g \<star> ?f \<Rightarrow> r\<^sub>0\<guillemotright>"
           using f g \<pi>.the_\<theta>_props \<mu>.the_\<theta>_props
           by (intro comp_in_homI hcomp_in_vhom, auto+)
         have \<nu>: "\<guillemotleft>?\<nu> : r\<^sub>1 \<Rightarrow> t\<^sub>1 \<star> ?g \<star> ?f\<guillemotright>"
           using f g \<pi>.the_\<theta>_props \<mu>.the_\<theta>_props
           by (intro comp_in_homI hcomp_in_vhom, auto)
         interpret gf: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 t\<^sub>0 t\<^sub>1 \<open>?g \<star> ?f\<close>
         proof
           show "ide (?g \<star> ?f)" by simp
           show "\<exists>\<theta>. \<guillemotleft>\<theta> : t\<^sub>0 \<star> ?g \<star> ?f \<Rightarrow> r\<^sub>0\<guillemotright>"
             using \<theta> by blast
           show "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> t\<^sub>1 \<star> ?g \<star> ?f\<guillemotright> \<and> iso \<nu>"
             using \<nu> \<mu>.the_\<nu>_props \<mu>.the_\<theta>_props \<pi>.the_\<nu>_props \<pi>.the_\<theta>_props
                   isos_compose [of "\<mu>.the_\<nu>" "\<pi>.the_\<nu>"] \<mu>.is_ide \<nu> \<open>ide (\<pi>.chine \<star> \<mu>.chine)\<close>
                   \<pi>.uw\<theta> \<pi>.w_simps(4) \<tau>.ide_leg1 \<tau>.leg1_simps(3) arrI hseq_char ideD(1)
                   ide_is_iso iso_assoc iso_hcomp isos_compose seqE
             by metis
         qed
         show ?thesis
         proof (intro conjI)
           have \<theta>_eq: "?\<theta> = gf.the_\<theta>"
             using \<theta> gf.the_\<theta>_props gf.leg0_uniquely_isomorphic by auto
           have \<nu>_eq: "?\<nu> = gf.the_\<nu>"
             using \<nu> gf.the_\<nu>_props gf.leg1_uniquely_isomorphic by auto
           have A: "src ?g = trg ?f"
             using f g by fastforce
           show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) t\<^sub>0 t\<^sub>1 (?g \<star> ?f)"
             using gf.arrow_of_spans_of_maps_axioms by simp
           have "((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot> gf.the_\<nu> = \<Delta>"
           proof -
             have "\<Delta> = (\<pi> \<star> r\<^sub>0) \<cdot> (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>"
               using whisker_right comp_assoc
               by (metis \<Delta>_simps(1) hseqE ide_u seqE)
             also have "... = ((\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>)) \<cdot> \<a>[s, s\<^sub>0, ?f] \<cdot> (\<sigma> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
               using \<mu>.\<Delta>_naturality comp_assoc by simp
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> ((\<pi> \<star> s\<^sub>0 \<star> ?f) \<cdot> \<a>[s, s\<^sub>0, ?f]) \<cdot> (\<sigma> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
             proof -
               have "(\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>) = \<pi> \<star> \<mu>.the_\<theta>"
                 using f comp_arr_dom comp_cod_arr \<mu>.the_\<theta>_props \<pi>.in_hom
                       interchange [of \<pi> s r\<^sub>0 \<mu>.the_\<theta>]
                 by (metis in_homE)
               also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<pi> \<star> s\<^sub>0 \<star> ?f)"
                 using f comp_arr_dom comp_cod_arr \<mu>.the_\<theta>_props \<pi>.in_hom
                       interchange [of t \<pi> \<mu>.the_\<theta> "s\<^sub>0 \<star> ?f"]
                 by (metis in_homE)
               finally have "(\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>) = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<pi> \<star> s\<^sub>0 \<star> ?f)"
                 by simp
               thus ?thesis
                 using comp_assoc by presburger
             qed
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot> (((\<pi> \<star> s\<^sub>0) \<star> ?f) \<cdot> (\<sigma> \<star> ?f)) \<cdot> \<mu>.the_\<nu>"
             proof -
               have "(\<pi> \<star> s\<^sub>0 \<star> ?f) \<cdot> \<a>[s, s\<^sub>0, ?f] = \<a>[t, s\<^sub>0, ?f] \<cdot> ((\<pi> \<star> s\<^sub>0) \<star> ?f)"
                 using f assoc_naturality [of \<pi> s\<^sub>0 ?f] \<pi>.in_hom by auto
               thus ?thesis
                 using comp_assoc by presburger
             qed
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot> (\<pi>.\<Delta> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
               using whisker_right comp_assoc by simp
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot>
                                ((t \<star> \<pi>.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g] \<cdot> (\<tau> \<star> ?g) \<cdot> \<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
               using \<pi>.\<Delta>_naturality by simp
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot>
                                (((t \<star> \<pi>.the_\<theta>) \<star> ?f) \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) \<cdot> ((\<tau> \<star> ?g) \<star> ?f) \<cdot>
                                (\<pi>.the_\<nu> \<star> ?f)) \<cdot> \<mu>.the_\<nu>"
               using f g \<pi>.the_\<theta>_props \<pi>.the_\<nu>_props whisker_right
               by (metis \<pi>.\<Delta>_simps(1) \<pi>.\<Delta>_naturality seqE)
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<a>[t, s\<^sub>0, ?f] \<cdot>
                                ((t \<star> \<pi>.the_\<theta>) \<star> ?f)) \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) \<cdot> ((\<tau> \<star> ?g) \<star> ?f) \<cdot>
                                (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
               using comp_assoc by presburger
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot>
                                (\<a>[t, t\<^sub>0 \<star> ?g, ?f] \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f)) \<cdot>
                                ((\<tau> \<star> ?g) \<star> ?f) \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
               using f \<pi>.the_\<theta>_props assoc_naturality [of t "\<pi>.the_\<theta>" ?f] \<pi>.\<theta>_simps(3) comp_assoc
               by auto
             also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot>
                                (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<a>[t \<star> t\<^sub>0, ?g, ?f] \<cdot>
                                ((\<tau> \<star> ?g) \<star> ?f)) \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
             proof -
               have "seq \<a>[t, t\<^sub>0, ?g \<star> ?f] \<a>[t \<star> t\<^sub>0, ?g, ?f]"
                 using f g by fastforce
               moreover have "inv (t \<star> \<a>[t\<^sub>0, ?g, ?f]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
                 using f g by simp
               moreover have "iso (t \<star> \<a>[t\<^sub>0, ?g, ?f])"
                 using f g by simp
               have "\<a>[t, t\<^sub>0 \<star> ?g, ?f] \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) =
                       (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> \<a>[t \<star> t\<^sub>0, ?g, ?f]"
               proof -
                 have "seq \<a>[t, t\<^sub>0, ?g \<star> ?f] \<a>[t \<star> t\<^sub>0, ?g, ?f]"
                   using f g by fastforce
                 moreover have "inv (t \<star> \<a>[t\<^sub>0, ?g, ?f]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
                   using f g by simp
                 moreover have "iso (t \<star> \<a>[t\<^sub>0, ?g, ?f])"
                   using f g by simp
                 ultimately show ?thesis
                   using A f g pentagon invert_side_of_triangle(1)
                   by (metis \<pi>.w_simps(4) \<tau>.ide_base \<tau>.ide_leg0 \<tau>.leg0_simps(3))
               qed
               thus ?thesis
                 using comp_assoc by presburger
             qed
             also have "... = ((t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f)) \<cdot>
                                (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f) \<cdot> 
                                \<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
               using f g assoc_naturality [of \<tau> ?g ?f] comp_assoc by simp
             also have "... = (t \<star> \<mu>.the_\<theta> \<cdot> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot>
                                \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot>
                                (\<tau> \<star> ?g \<star> ?f) \<cdot> \<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
             proof -
               have 1: "seq \<mu>.the_\<theta> ((\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f])"
                 using \<theta>_eq by auto
               hence "t \<star> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f] =
                      (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f])"
                 using whisker_left \<tau>.ide_base by blast
               thus ?thesis
                 using 1 whisker_left \<tau>.ide_base comp_assoc by presburger
             qed
             also have "... = ((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot> gf.the_\<nu>"
               using \<theta>_eq \<nu>_eq by (simp add: comp_assoc)
             finally show ?thesis
               using comp_assoc by presburger
           qed
           thus "((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot>
                   arrow_of_spans_of_maps.the_\<nu> (\<cdot>) (\<star>) (dom ((\<pi> \<cdot> \<mu> \<star> r\<^sub>0) \<cdot> \<rho>)) t\<^sub>1 (?g \<star> ?f) =
                 \<Delta>"
             by simp
         qed
       qed
       thus ?thesis
         using chine_is_induced_map induced_map_unique by simp
     qed
 
   end
 
   sublocale vertical_composite_of_arrows_of_tabulations_in_maps \<subseteq>
             arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 "\<pi> \<cdot> \<mu>"
     using is_arrow_of_tabulations_in_maps by simp
 
   subsubsection "Horizontal Composite"
 
   locale horizontal_composite_of_arrows_of_tabulations_in_maps =
     bicategory_of_spans V H \<a> \<i> src trg +
     \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
     \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 +
     \<tau>: tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 +
     \<mu>: tabulation_in_maps V H \<a> \<i> src trg u \<mu> u\<^sub>0 u\<^sub>1 +
     \<rho>\<sigma>: composite_tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 +
     \<tau>\<mu>: composite_tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 u \<mu> u\<^sub>0 u\<^sub>1 +
     \<omega>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<omega> +
     \<chi>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 u \<mu> u\<^sub>0 u\<^sub>1 \<chi>
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r :: 'a
   and \<rho> :: 'a
   and r\<^sub>0 :: 'a
   and r\<^sub>1 :: 'a
   and s :: 'a
   and \<sigma> :: 'a
   and s\<^sub>0 :: 'a
   and s\<^sub>1 :: 'a
   and t :: 'a
   and \<tau> :: 'a
   and t\<^sub>0 :: 'a
   and t\<^sub>1 :: 'a
   and u :: 'a
   and \<mu> :: 'a
   and u\<^sub>0 :: 'a
   and u\<^sub>1 :: 'a
   and \<omega> :: 'a
   and \<chi> :: 'a
   begin
 
     text \<open>
 $$
 \xymatrix{
   &&& {\rm src}~t_0u_1.\phi \ar[dl]_{\tau\mu.p_1} \ar[dr]^{\tau\mu.p_0} \ddtwocell\omit{^{t_0u_1.\phi}} \\
   && {\rm src}~\tau \ar[dl]_{t_1} \ar[dr]^<>(0.4){t_0} \dtwocell\omit{^<-1>\tau}
   && {\rm src}~\mu \ar[dl]_{u_1} \ar[dr]^{u_0} \dtwocell\omit{^<-1>\mu} & \\
   & {\rm trg}~t && {\rm src}~t = {\rm trg}~u \ar[ll]^{t}
   && {\rm src}~u \ar[ll]^{u} \\
   & \xtwocell[r]{}\omit{^\omega}
   & {\rm src}~r_0s_1.\phi \ar[uuur]_<>(0.2){{\rm chine}}
     \ar[dl]^{\rho\sigma.p_1} \ar[dr]_{\rho\sigma.p_0\hspace{20pt}} \ddtwocell\omit{^{r_0s_1.\phi}}
   & \rrtwocell\omit{^\chi} && \\
   & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar[uuur]^<>(0.4){\omega.{\rm chine}} \dtwocell\omit{^\rho}
   && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \ar[uuur]^<>(0.4){\chi.{\rm chine}} \dtwocell\omit{^<-1>\sigma} & \\
   {\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} \ar@ {=}[uuur]
   && {\rm src}~s \ar[ll]^{s} \ar@ {=}[uuur] \\
 }
 $$
     \<close>
 
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      \<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<close>
                      \<open>t \<star> u\<close> \<tau>\<mu>.tab \<open>u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0\<close> \<open>t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1\<close> \<open>\<omega> \<star> \<chi>\<close>
       using \<rho>\<sigma>.composable \<omega>.in_hom \<chi>.in_hom
       by unfold_locales auto
 
     lemma is_arrow_of_tabulations_in_maps:
     shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
              (r \<star> s) \<rho>\<sigma>.tab (s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1)
              (t \<star> u) \<tau>\<mu>.tab (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) (\<omega> \<star> \<chi>)"
       ..
 
     sublocale arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                 \<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<close>
                 \<open>t \<star> u\<close> \<tau>\<mu>.tab \<open>u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0\<close> \<open>t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1\<close> \<open>\<omega> \<star> \<chi>\<close>
       using is_arrow_of_tabulations_in_maps by simp
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     notation Maps.comp  (infixr "\<odot>" 55)
 
     interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg s\<^sub>1 r\<^sub>0
       using \<rho>.leg0_is_map \<sigma>.leg1_is_map \<rho>\<sigma>.composable apply unfold_locales by auto
     interpretation r\<^sub>0s\<^sub>1: arrow_of_tabulations_in_maps \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
                            \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close> r\<^sub>0s\<^sub>1.tab r\<^sub>0s\<^sub>1.p\<^sub>0 r\<^sub>0s\<^sub>1.p\<^sub>1
                            \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close> r\<^sub>0s\<^sub>1.tab r\<^sub>0s\<^sub>1.p\<^sub>0 r\<^sub>0s\<^sub>1.p\<^sub>1
                            \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>
       using r\<^sub>0s\<^sub>1.is_arrow_of_tabulations_in_maps by simp
     interpretation t\<^sub>0u\<^sub>1: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg u\<^sub>1 t\<^sub>0
       using \<tau>.leg0_is_map \<mu>.leg1_is_map \<tau>\<mu>.composable apply unfold_locales by auto
     interpretation t\<^sub>0u\<^sub>1: arrow_of_tabulations_in_maps \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
                            \<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close> t\<^sub>0u\<^sub>1.tab t\<^sub>0u\<^sub>1.p\<^sub>0 t\<^sub>0u\<^sub>1.p\<^sub>1
                            \<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close> t\<^sub>0u\<^sub>1.tab t\<^sub>0u\<^sub>1.p\<^sub>0 t\<^sub>0u\<^sub>1.p\<^sub>1
                            \<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close>
       using t\<^sub>0u\<^sub>1.is_arrow_of_tabulations_in_maps by simp
 
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     text \<open>
       The following lemma states that the rectangular faces of the ``top prism'' commute
       up to isomorphism.  This was not already proved in @{locale composite_tabulation_in_maps},
       because there we did not consider any composite structure of the ``source'' 2-cell.
       There are common elements, though to the proof that the composite of tabulations is
       a tabulation and the present lemma.
       The proof idea is to use property \<open>T2\<close> of the ``base'' tabulations to establish the
       existence of the desired isomorphisms.  The proofs have to be carried out in
       sequence, starting from the ``output'' side, because the arrow \<open>\<beta>\<close> required in the
       hypotheses of \<open>T2\<close> depends, for the ``input'' tabulation, on the isomorphism constructed
       for the ``output'' tabulation.
     \<close>
 
     lemma prj_chine:
     shows "\<tau>\<mu>.p\<^sub>0 \<star> chine \<cong> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
     and "\<tau>\<mu>.p\<^sub>1 \<star> chine \<cong> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
     proof -
       have 1: "arrow_of_spans_of_maps V H \<a> \<i> src trg
                  (s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1) (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) chine \<and>
                (((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<tau>\<mu>.tab \<star> chine)) \<cdot> the_\<nu> =
                ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab"
         using chine_is_induced_map by simp
       let ?u\<^sub>\<tau> = "u \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
       let ?w\<^sub>\<tau> = "\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
       let ?w\<^sub>\<tau>' = "\<tau>\<mu>.p\<^sub>1 \<star> chine"
       have u\<^sub>\<tau>: "ide ?u\<^sub>\<tau>"
         using \<chi>.u_simps(3) by auto
       have w\<^sub>\<tau>: "ide ?w\<^sub>\<tau> \<and> is_left_adjoint ?w\<^sub>\<tau>"
         by (simp add: \<omega>.is_map \<rho>.T0.antipar(1) left_adjoints_compose)
       have w\<^sub>\<tau>': "ide ?w\<^sub>\<tau>' \<and> is_left_adjoint ?w\<^sub>\<tau>'"
         by (simp add: is_map left_adjoints_compose)
       let ?\<theta>\<^sub>\<tau> = "\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot> (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                    \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
       let ?\<theta>\<^sub>\<tau>' = "(u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                    ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
       let ?\<beta>\<^sub>\<tau> = "\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
       have \<theta>\<^sub>\<tau>: "\<guillemotleft>?\<theta>\<^sub>\<tau> : t\<^sub>0 \<star> ?w\<^sub>\<tau> \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
         using \<rho>.T0.antipar(1) \<omega>.the_\<theta>_in_hom \<chi>.u_simps(3)
         by (intro comp_in_homI, auto)
       have \<theta>\<^sub>\<tau>': "\<guillemotleft>?\<theta>\<^sub>\<tau>' : t\<^sub>0 \<star> ?w\<^sub>\<tau>' \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
       proof (intro comp_in_homI)
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] : t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine \<Rightarrow> (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
           using t\<^sub>0u\<^sub>1.p\<^sub>1_simps assoc'_in_hom by simp
         show "\<guillemotleft>t\<^sub>0u\<^sub>1.\<phi> \<star> chine : (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
           using \<tau>.T0.antipar(1)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>(\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine : (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine : ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> (u \<star> u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
           using assoc_in_hom by auto
         show "\<guillemotleft>\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] : (u \<star> u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> u \<star> (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
           by auto
         show "\<guillemotleft>u \<star> the_\<theta> : u \<star> (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
           by (intro hcomp_in_vhom, auto)
       qed
       have \<beta>\<^sub>\<tau>: "\<guillemotleft>?\<beta>\<^sub>\<tau> : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
       proof (intro comp_in_homI)
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> (t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
           using \<rho>.T0.antipar(1) by auto
         show "\<guillemotleft>inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1 : (t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
           using \<omega>.the_\<nu>_props \<rho>.T0.antipar(1)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>the_\<nu> : r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
           using the_\<nu>_in_hom(2) by simp
         show "\<guillemotleft>\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] : (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
           using t\<^sub>0u\<^sub>1.p\<^sub>1_simps assoc_in_hom by simp
       qed
       define LHS where "LHS = (t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)"
       have LHS: "\<guillemotleft>LHS : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
       proof (unfold LHS_def, intro comp_in_homI)
         show "\<guillemotleft>\<tau> \<star> ?w\<^sub>\<tau> : t\<^sub>1 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t \<star> t\<^sub>0) \<star> ?w\<^sub>\<tau>\<guillemotright>"
           using \<rho>.T0.antipar(1)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>\<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] : (t \<star> t\<^sub>0) \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>\<guillemotright>"
           using \<rho>.T0.antipar(1) by auto
         show "\<guillemotleft>t \<star> ?\<theta>\<^sub>\<tau> : t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
         proof -
           have "src t = trg (t\<^sub>0 \<star> \<omega>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>1)"
             by (metis \<chi>.u_simps(3) \<mu>.ide_base \<sigma>.ide_leg0 \<sigma>.leg1_simps(3) \<tau>\<mu>.composable
                 \<theta>\<^sub>\<tau> arrI assoc_simps(3) r\<^sub>0s\<^sub>1.ide_u r\<^sub>0s\<^sub>1.p\<^sub>0_simps trg_vcomp vconn_implies_hpar(2))
           thus ?thesis
             using \<theta>\<^sub>\<tau> by blast
         qed
       qed
       define RHS where "RHS = ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> ?\<beta>\<^sub>\<tau>"
       have RHS: "\<guillemotleft>RHS : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
         unfolding RHS_def
       proof
         show "\<guillemotleft>?\<beta>\<^sub>\<tau> : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
           using \<beta>\<^sub>\<tau> by simp
         show "\<guillemotleft>(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') : t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
         proof
           show "\<guillemotleft>\<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') : t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
             using \<tau>.T0.antipar(1) by fastforce
           show "\<guillemotleft>t \<star> ?\<theta>\<^sub>\<tau>' : t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
             using w\<^sub>\<tau>' \<theta>\<^sub>\<tau>' \<tau>.leg0_simps(2) \<tau>.leg0_simps(3) hseqI' ideD(1) t\<^sub>0u\<^sub>1.p\<^sub>1_simps
                   trg_hcomp \<tau>.base_in_hom(2) hcomp_in_vhom
             by presburger
         qed
       qed
       have eq: "LHS = RHS"
       proof -
         have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) = \<Delta>"
         proof -
           text \<open>
             Here we use \<open>\<omega>.\<Delta>_naturality\<close> to replace @{term \<omega>.chine}
             in favor of @{term \<omega>}.
             We have to bring @{term \<omega>.the_\<nu>}, @{term \<tau>}, and @{term \<omega>.the_\<theta>} together, 
             with @{term \<rho>\<sigma>.p\<^sub>1} on the right.
           \<close>
           have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
                 \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                   (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                        (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
                   \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot>
                   (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
             unfolding LHS_def
             using comp_assoc by presburger
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              (t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
                              \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                              \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                        (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
                   (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                        (t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1])"
               using whisker_left \<tau>.ide_base \<theta>\<^sub>\<tau> arrI seqE
               by (metis (full_types))
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              (t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
                              \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
                              ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "(\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
                   \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1)"
               using assoc_naturality
               by (metis \<omega>.w_simps(2-6) \<rho>.leg1_simps(3) \<rho>\<sigma>.leg1_simps(2) \<tau>.tab_simps(1)
                   \<tau>.tab_simps(2,4-5) hseqE r\<^sub>0s\<^sub>1.leg1_simps(5) r\<^sub>0s\<^sub>1.leg1_simps(6))
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              ((t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
                              (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                              (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot>
                     \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
                   \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1)"
             proof -
               have "seq \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
                 by (simp add: \<rho>.T0.antipar(1))
               moreover have "inv (t \<star> \<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
                 using \<rho>.T0.antipar(1) by simp
               ultimately show ?thesis
                 using pentagon \<rho>.T0.antipar(1) iso_hcomp
                       invert_side_of_triangle(1)
                         [of "\<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
                             "t \<star> \<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
                             "\<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1)"]
                 by simp
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (((t \<star> \<omega>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                              (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot>
                              (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "(t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
                   \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((t \<star> \<omega>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>1)"
               using assoc_naturality [of t \<omega>.the_\<theta> \<rho>\<sigma>.p\<^sub>1] \<omega>.\<theta>_simps(3) \<rho>\<sigma>.leg1_simps(2) hseq_char
               by auto
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
             using whisker_right \<rho>.T0.antipar(1) \<omega>.\<Delta>_simps(1) \<omega>.\<Delta>_naturality comp_assoc
             by fastforce
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> ((t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0 = (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)"
               using whisker_left whisker_right \<rho>.T0.antipar(1)
               by (metis (full_types) \<chi>.\<Delta>_simps(1) \<tau>.ide_base \<theta>\<^sub>\<tau> arrI r\<^sub>0s\<^sub>1.ide_u seqE)
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "(t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0) =
                   t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0)"
               using \<chi>.in_hom whisker_left by auto
             also have "... = t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]"
               using assoc_naturality [of \<chi> s\<^sub>0 \<rho>\<sigma>.p\<^sub>0] \<chi>.in_hom by auto
             also have "... = (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0])"
             proof -
               have "seq (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]"
                 using \<chi>.in_hom
                 apply (intro seqI hseqI)
                    apply auto
               proof -
                 show "\<guillemotleft>\<chi> : src u \<rightarrow> trg \<chi>\<guillemotright>"
                   by (metis \<chi>.\<Delta>_simps(1) \<chi>.u_simps(3) hseqE in_hhom_def seqE)
                 show "dom (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) = s \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
                   by (metis \<Delta>_simps(1) \<chi>.in_hom hcomp_simps(1,3) hseq_char in_homE seqE
                       u_simps(4))
               qed
               thus ?thesis
                 using whisker_left by simp
             qed
             finally show ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              (\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
             using whisker_right comp_assoc by simp
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
                              (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
             using assoc_naturality [of \<omega> r\<^sub>0 \<rho>\<sigma>.p\<^sub>1] \<omega>.in_hom \<rho>.T0.antipar(1) comp_assoc
             by fastforce
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> ((t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "(t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1) = \<omega> \<star> r\<^sub>0s\<^sub>1.\<phi>"
               using comp_cod_arr comp_arr_dom \<omega>.in_hom interchange comp_ide_arr
               by (metis \<tau>.base_in_hom(2) \<tau>.ide_base r\<^sub>0s\<^sub>1.\<phi>_simps(1) r\<^sub>0s\<^sub>1.\<phi>_simps(4) seqI')
             also have "... = (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>)"
               using r\<^sub>0s\<^sub>1.\<phi>_in_hom comp_cod_arr comp_arr_dom \<omega>.in_hom interchange
               by (metis in_homE)
             finally have "(t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1) = (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>)"
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              ((t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
                              (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
                              (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
             using whisker_left \<rho>.T0.antipar(1) \<rho>\<sigma>.composable \<chi>.in_hom comp_assoc by auto
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
                              (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "(t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) =
                    \<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)"
             proof -
               have "\<guillemotleft>(\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) : s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> u \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
                 using \<omega>.in_hom \<chi>.in_hom by force
               thus ?thesis
                   by (metis (no_types) \<omega>.in_hom comp_arr_dom comp_cod_arr in_homE
                       interchange)
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = (\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
                              (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) =
                   (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0))"
             proof -
               have "seq (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (\<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0))"
                 using \<chi>.in_hom by force
               thus ?thesis
                using comp_arr_dom comp_cod_arr \<omega>.in_hom \<chi>.in_hom interchange
                by (metis in_homE)
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
                              (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
           proof -
             have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) =
                   ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0]"
               using assoc_naturality \<omega>.in_hom \<chi>.in_hom
               by (metis \<rho>\<sigma>.leg0_simps(3) assoc'_naturality hcomp_in_vhomE in_hom in_homE
                   u_simps(2) u_simps(4) u_simps(5))
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<Delta>"
             using whisker_left \<rho>\<sigma>.tab_def comp_assoc by simp
           finally show ?thesis by auto
         qed
         also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
         proof -
           text \<open>Now cancel @{term \<omega>.the_\<nu>} and its inverse.\<close>
           have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
                 \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                   (t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                          (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                          (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                     \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
                     \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                     ((\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
             unfolding RHS_def
             using comp_assoc by presburger
           also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                                      (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                                      (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                                \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
                                \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu>"
           proof -
             have "the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                     ((\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
                   the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                     ((t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
               using comp_inv_arr \<rho>.T0.antipar(1) comp_assoc_assoc' by simp
             also have "... = the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
               using comp_cod_arr \<rho>.T0.antipar(1) by simp
             also have "... = the_\<nu> \<cdot> (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1)"
               using whisker_right [of \<rho>\<sigma>.p\<^sub>1] r\<^sub>0s\<^sub>1.ide_leg1 \<omega>.the_\<nu>_props(2) \<omega>.the_\<nu>_simps(4)
                     \<rho>.leg1_simps(2) comp_inv_arr'
               by metis
             also have "... = the_\<nu>"
               using comp_arr_dom by simp
             finally show ?thesis
               using comp_assoc by simp
           qed
           text \<open>
             Now reassociate to move @{term the_\<theta>} to the left and get other terms composed
             with @{term chine}, where they can be reduced to @{term \<tau>\<mu>.tab}.
           \<close>
           also have "... = (\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (t \<star> u \<star> the_\<theta>)) \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                              (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                              \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
                              \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu>"
           proof -
             have "arr ((u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                        ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
               using \<theta>\<^sub>\<tau>' by blast
             moreover have "arr (\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                                  ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
               using calculation by blast
             moreover have "arr ((\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                                  ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
               using calculation by blast
             moreover have "arr (((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
               using calculation by blast
             moreover have "arr ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
               using calculation by blast
             ultimately
             have "t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                     ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] =
                   (t \<star> u \<star> the_\<theta>) \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
                     (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                     (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
               using whisker_left \<rho>.T0.antipar(1) \<tau>.ide_base by presburger
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                              (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
                              ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot> \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> the_\<nu>"
             using assoc'_naturality [of t u the_\<theta>] \<tau>\<mu>.composable \<theta>_simps(3) comp_assoc by auto
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                              (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              ((t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
                              \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "(\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot> \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] =
                   \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine)"
               using assoc_naturality
               by (metis \<tau>.leg1_simps(3) \<tau>.tab_simps(1,2,4) \<tau>.tab_simps(5) \<tau>\<mu>.leg0_simps(2)
                   \<tau>\<mu>.leg1_simps(2) hseqE src_hcomp t\<^sub>0u\<^sub>1.leg1_simps(3,5-6) w_simps(2)
                   w_simps(4-6))
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
                              ((t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
                     \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] =
                   \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine)"
               using pentagon t\<^sub>0u\<^sub>1.p\<^sub>1_simps uw\<theta> \<tau>.T0.antipar(1) iso_hcomp
                     comp_assoc_assoc'
                     invert_side_of_triangle(1)
                       [of "\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
                           "t \<star> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
                           "\<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine)"]
               by auto
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              ((t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
                              ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot> 
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] =
                   \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine)"
               using assoc_naturality [of t t\<^sub>0u\<^sub>1.\<phi> chine] t\<^sub>0u\<^sub>1.cospan by auto
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                              ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot> 
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "(t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine] =
                   \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> ((t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0)) \<star> chine)"
               using assoc_naturality [of t "\<mu> \<star> \<tau>\<mu>.p\<^sub>0" chine]
               by (simp add: \<tau>\<mu>.composable)
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                              ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
                              ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot> 
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "(((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
                     ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) =
                   ((t \<star> ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0)) \<star> chine) \<cdot> ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine)"
               using whisker_right whisker_left [of t "\<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]" "\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]"]
                     \<tau>\<mu>.composable comp_assoc_assoc'
               by simp
             also have "... = (t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine"
               using comp_cod_arr \<tau>\<mu>.composable by simp
             finally have "(((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
                             ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) =
                           (t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine"
               by simp
             thus ?thesis
               using comp_assoc by metis
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                              ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (((\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              (\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot> 
                              ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot> 
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "((\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot>
                     ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) =
                   ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)"
               using comp_inv_arr' comp_cod_arr \<tau>\<mu>.composable comp_assoc_assoc'
                     whisker_right [of chine "\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0]" "\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0]"]
               by simp
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                              ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              ((\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> 
                              ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot> 
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine)) \<cdot> the_\<nu>"
             using comp_assoc by presburger
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot>
                              (\<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
                              (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                              ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot>
                              (\<tau>\<mu>.tab \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "(\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> 
                              ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot> 
                              (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) =
                   \<tau>\<mu>.tab \<star> chine"
               using uw\<theta> whisker_right [of chine]
               by (metis \<tau>\<mu>.tab_def \<tau>\<mu>.tab_in_vhom' arrI seqE)
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<tau>\<mu>.tab \<star> chine) \<cdot> the_\<nu>"
           proof -
             have "\<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
                     (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
                     ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) =
                   \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, \<^bold>\<langle>u\<^bold>\<rangle>, (\<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                    (\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, (\<^bold>\<langle>u\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                    ((\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>) \<^bold>\<cdot>
                    (\<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, \<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>)\<rbrace>"
               using \<a>'_def \<alpha>_def \<tau>\<mu>.composable by simp
             also have "... = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using \<tau>\<mu>.composable
               apply (intro E.eval_eqI) by simp_all
             also have "... = \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]"
               using \<a>'_def \<alpha>_def \<tau>\<mu>.composable by simp
             finally show ?thesis by simp
           qed
           also have "... = \<Delta>"
             using \<Delta>_naturality by simp
           finally show ?thesis by simp
         qed
         finally have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
                       \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
           by blast
         (*
          * TODO: This is common enough that there should be "cancel_iso_left" and
          * "cancel_iso_right" rules for doing it.
          *)
         hence "(LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
                (RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
           using u\<^sub>\<tau> r\<^sub>0s\<^sub>1.ide_u LHS RHS iso_is_section [of "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0]"] section_is_mono
                 monoE \<tau>\<mu>.composable comp_assoc
           by (metis (no_types, lifting) \<Delta>_simps(1) \<mu>.ide_base
               \<open>\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, r\<^sub>0s\<^sub>1.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> r\<^sub>0s\<^sub>1.p\<^sub>1) =
                ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab\<close>
               \<tau>.ide_base hseq_char ideD(1) ide_u iso_assoc')
         hence 1: "LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] = RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
           using epiE LHS RHS iso_is_retraction retraction_is_epi \<tau>\<mu>.composable
                 \<omega>.the_\<nu>_props iso_hcomp
           by (metis \<Delta>_simps(1) \<omega>.the_\<nu>_simps(2)
               \<open>((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab =
                \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, r\<^sub>0s\<^sub>1.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> r\<^sub>0s\<^sub>1.p\<^sub>1)\<close>
               \<rho>.leg1_simps(3) ide_is_iso local.comp_assoc r\<^sub>0s\<^sub>1.ide_leg1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps seqE)
         show "LHS = RHS"
         proof -
           have "epi \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
             using iso_is_retraction retraction_is_epi \<rho>.T0.antipar(1) by simp
           moreover have "seq LHS \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
             using LHS \<rho>.T0.antipar(1) by auto
           moreover have "seq RHS \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
             using RHS \<rho>.T0.antipar(1) by auto
           ultimately show ?thesis
             using epiE 1 by blast
         qed
       qed
       have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)"
         using LHS_def RHS_def u\<^sub>\<tau> w\<^sub>\<tau> w\<^sub>\<tau>' \<beta>\<^sub>\<tau> \<theta>\<^sub>\<tau> \<theta>\<^sub>\<tau>' eq \<tau>.T2 [of ?w\<^sub>\<tau> ?w\<^sub>\<tau>' ?\<theta>\<^sub>\<tau> ?u\<^sub>\<tau> ?\<theta>\<^sub>\<tau>' ?\<beta>\<^sub>\<tau>]
         by fastforce
       obtain \<gamma>\<^sub>\<tau> where \<gamma>\<^sub>\<tau>: "\<guillemotleft>\<gamma>\<^sub>\<tau> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
         using 1 by auto
       text \<open>
         At this point we could show that @{term \<gamma>\<^sub>\<tau>} is invertible using \<open>BS3\<close>,
         but we want to avoid using \<open>BS3\<close> if possible and we also want to
         establish a characterization of @{term "inv \<gamma>\<^sub>\<tau>"}.  So we show the invertibility of
         @{term \<gamma>\<^sub>\<tau>} directly, using a few more applications of \<open>T2\<close>.
       \<close>
       have iso_\<beta>\<^sub>\<tau>: "iso ?\<beta>\<^sub>\<tau>"
         using uw\<theta> \<beta>\<^sub>\<tau> the_\<nu>_props \<omega>.the_\<nu>_props hseqI' iso_assoc' \<omega>.hseq_leg\<^sub>0
         apply (intro isos_compose)
               apply (metis \<omega>.is_ide \<rho>\<sigma>.leg1_simps(2) \<tau>.ide_leg1 \<tau>.leg1_simps(2)
                            \<tau>.leg1_simps(3) hseqE r\<^sub>0s\<^sub>1.ide_leg1 hcomp_simps(1) vconn_implies_hpar(3))
              apply (metis \<rho>\<sigma>.leg1_simps(2) hseqE ide_is_iso r\<^sub>0s\<^sub>1.ide_leg1 src_inv iso_inv_iso
                           iso_hcomp vconn_implies_hpar(1))
             apply blast
            apply blast
           apply blast
          apply (metis \<tau>.ide_leg1 \<tau>.leg1_simps(3) hseqE ide_char iso_assoc t\<^sub>0u\<^sub>1.ide_leg1
                       t\<^sub>0u\<^sub>1.p\<^sub>1_simps w\<^sub>\<tau>')
         by blast
       hence eq': "((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) =
                   ((t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)) \<cdot> inv ?\<beta>\<^sub>\<tau>"
       proof -
         have "seq ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) ?\<beta>\<^sub>\<tau>"
           using LHS RHS_def eq by blast
         hence "(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') =
                (((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> ?\<beta>\<^sub>\<tau>) \<cdot> inv ?\<beta>\<^sub>\<tau>"
           by (meson invert_side_of_triangle(2) iso_\<beta>\<^sub>\<tau>)
         thus ?thesis
           using LHS_def RHS_def eq by argo
       qed
       have 2: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> inv ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>)"
         using u\<^sub>\<tau> w\<^sub>\<tau> w\<^sub>\<tau>' \<beta>\<^sub>\<tau> \<theta>\<^sub>\<tau> \<theta>\<^sub>\<tau>' eq' \<tau>.T2 [of ?w\<^sub>\<tau>' ?w\<^sub>\<tau> ?\<theta>\<^sub>\<tau>'?u\<^sub>\<tau> ?\<theta>\<^sub>\<tau> "inv ?\<beta>\<^sub>\<tau>"] iso_\<beta>\<^sub>\<tau> comp_assoc
         by blast
       obtain \<gamma>\<^sub>\<tau>' where
         \<gamma>\<^sub>\<tau>': "\<guillemotleft>\<gamma>\<^sub>\<tau>' : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> inv ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
         using 2 by auto
       have "inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'"
       proof
         have "\<guillemotleft>\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright>"
           using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' by auto
         moreover have "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> = t\<^sub>1 \<star> ?w\<^sub>\<tau>"
           using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left \<beta>\<^sub>\<tau> iso_\<beta>\<^sub>\<tau> comp_inv_arr'
           by (metis (no_types, lifting) \<tau>.ide_leg1 calculation in_homE)
         moreover have "?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
         proof -
           have "?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
             using \<gamma>\<^sub>\<tau> by simp
           also have "... = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>') \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
             using \<gamma>\<^sub>\<tau>' comp_assoc by simp
           also have "... = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
             using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left
             by (metis (full_types) \<tau>.ide_leg0 seqI')
           finally show ?thesis by simp
         qed
         moreover have
           "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>) \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>"
         proof -
           have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> ?w\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>)"
           proof -
             have "(t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>) =
                   ((t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)) \<cdot> (t\<^sub>1 \<star> ?w\<^sub>\<tau>)"
               by (metis LHS LHS_def comp_arr_dom in_homE)
             thus ?thesis
               using w\<^sub>\<tau> \<theta>\<^sub>\<tau> \<omega>.w_simps(4) \<tau>.leg1_in_hom(2) \<tau>.leg1_simps(3) hcomp_in_vhom ideD(1)
                     trg_hcomp ide_in_hom(2) \<tau>.T2
               by presburger
           qed
           thus "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>) \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>"
             by (metis \<theta>\<^sub>\<tau> comp_arr_dom ide_in_hom(2) in_homE w\<^sub>\<tau>)
         qed
         ultimately have "\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> = ?w\<^sub>\<tau>"
           by simp
         thus "ide (\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
           using w\<^sub>\<tau> by simp
         have "\<guillemotleft>\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright>"
           using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' by auto
         moreover have "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = t\<^sub>1 \<star> ?w\<^sub>\<tau>'"
           by (metis \<beta>\<^sub>\<tau> \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' \<tau>.ide_leg1 calculation comp_arr_inv' in_homE iso_\<beta>\<^sub>\<tau> whisker_left)
         moreover have "?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
         proof -
           have "?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
             using \<gamma>\<^sub>\<tau>' by simp
           also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>) \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
             using \<gamma>\<^sub>\<tau> comp_assoc by simp
           also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
             using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left \<tau>.ide_leg0 by fastforce
           finally show ?thesis by simp
         qed
         moreover have "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)
                               \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>'"
         proof -
           have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> ?w\<^sub>\<tau>' = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)"
           proof -
             have "(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') =
                   ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> (t\<^sub>1 \<star> ?w\<^sub>\<tau>')"
             proof -
               have 1: "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>')"
                 by (meson \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' \<tau>.ide_leg1 seqI' whisker_left)
               have "((LHS \<cdot> inv ?\<beta>\<^sub>\<tau>) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>)) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>') = LHS \<cdot> inv ?\<beta>\<^sub>\<tau>"
                 using LHS_def RHS_def \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' eq eq' by argo
               thus ?thesis
                 unfolding LHS_def
                 using 1 by (simp add: calculation(2) eq' comp_assoc)
             qed
             thus ?thesis
               using w\<^sub>\<tau>' \<theta>\<^sub>\<tau>' \<omega>.w_simps(4) \<tau>.leg1_in_hom(2) \<tau>.leg1_simps(3) hcomp_in_vhom ideD(1)
                     trg_hcomp ide_in_hom(2) \<tau>.T2 \<tau>.T0.antipar(1) t\<^sub>0u\<^sub>1.base_simps(2)
                     t\<^sub>0u\<^sub>1.leg1_simps(4)
               by presburger
           qed
           thus "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)
                          \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>'"
             by (metis \<theta>\<^sub>\<tau>' comp_arr_dom ide_in_hom(2) in_homE w\<^sub>\<tau>')
         qed
         ultimately have "\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = ?w\<^sub>\<tau>'"
           by simp
         thus "ide (\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
           using w\<^sub>\<tau>' by simp
       qed
       thus "\<tau>\<mu>.p\<^sub>1 \<star> chine \<cong> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
         using w\<^sub>\<tau> w\<^sub>\<tau>' \<gamma>\<^sub>\<tau> isomorphic_symmetric isomorphic_def by blast
       have iso_\<gamma>\<^sub>\<tau>: "iso \<gamma>\<^sub>\<tau>"
         using \<open>inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'\<close> by auto
       have \<gamma>\<^sub>\<tau>'_eq: "\<gamma>\<^sub>\<tau>' = inv \<gamma>\<^sub>\<tau>"
         using \<open>inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'\<close> inverse_unique by blast
 
       let ?w\<^sub>\<mu> = "\<tau>\<mu>.p\<^sub>0 \<star> chine"
       let ?w\<^sub>\<mu>' = "\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
       let ?u\<^sub>\<mu> = "s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
       let ?\<theta>\<^sub>\<mu> = "the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"
       let ?\<theta>\<^sub>\<mu>' = "(\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
       let ?\<beta>\<^sub>\<mu> = "\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot> (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
                   \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot>
                   (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
       have w\<^sub>\<mu>: "ide ?w\<^sub>\<mu> \<and> is_left_adjoint ?w\<^sub>\<mu>"
         using is_map left_adjoints_compose by simp
       have w\<^sub>\<mu>': "ide ?w\<^sub>\<mu>' \<and> is_left_adjoint ?w\<^sub>\<mu>'"
         using \<chi>.is_map left_adjoints_compose
         by (simp add: is_map left_adjoints_compose)
       have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>)"
       proof -
         have \<theta>\<^sub>\<mu>: "\<guillemotleft>?\<theta>\<^sub>\<mu> : u\<^sub>0 \<star> ?w\<^sub>\<mu> \<Rightarrow> ?u\<^sub>\<mu>\<guillemotright>"
           by auto
         have \<theta>\<^sub>\<mu>': "\<guillemotleft>?\<theta>\<^sub>\<mu>' : u\<^sub>0 \<star> ?w\<^sub>\<mu>' \<Rightarrow> ?u\<^sub>\<mu>\<guillemotright>"
           by fastforce
         have \<beta>\<^sub>\<mu>: "\<guillemotleft>?\<beta>\<^sub>\<mu> : u\<^sub>1 \<star> ?w\<^sub>\<mu> \<Rightarrow> u\<^sub>1 \<star> ?w\<^sub>\<mu>'\<guillemotright>"
         proof (intro comp_in_homI)
           show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] : u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0 \<star> chine \<Rightarrow> (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
             by auto
           show "\<guillemotleft>inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine : (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
             using t\<^sub>0u\<^sub>1.\<phi>_uniqueness(2) hcomp_in_vhom
             by (simp add: t\<^sub>0u\<^sub>1.\<phi>_in_hom(2) w_in_hom(2))
           show "\<guillemotleft>\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] : (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine\<guillemotright>"
             using \<tau>.T0.antipar(1) by auto
           show "\<guillemotleft>t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau> : t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine \<Rightarrow> t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
             using \<gamma>\<^sub>\<tau> iso_\<gamma>\<^sub>\<tau> using \<tau>.T0.antipar(1) by auto
           show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] : t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
             using \<rho>.T0.antipar(1) by auto
           show "\<guillemotleft>\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1 : (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
             using \<rho>.T0.antipar(1) by auto
           show "\<guillemotleft>r\<^sub>0s\<^sub>1.\<phi> : r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
             by auto
           show "\<guillemotleft>\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0 : s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
             by auto
           show "\<guillemotleft>\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] : (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
             by auto
         qed
         text \<open>
           The proof of the equation below needs to make use of the equation
           \<open>\<theta>\<^sub>\<tau>' = \<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')\<close> from the previous section.  So the overall strategy is to
           work toward an expression of the form \<open>\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')\<close> and perform the replacement
           to eliminate \<open>\<gamma>\<^sub>\<tau>'\<close>.
         \<close>
         have eq\<^sub>\<mu>: "(u \<star> ?\<theta>\<^sub>\<mu>) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>) =
                    ((u \<star> ?\<theta>\<^sub>\<mu>') \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>'] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>')) \<cdot> ?\<beta>\<^sub>\<mu>"
         proof -
           let ?LHS = "(u \<star> ?\<theta>\<^sub>\<mu>) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
           let ?RHS = "((u \<star> ?\<theta>\<^sub>\<mu>') \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>'] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>')) \<cdot> ?\<beta>\<^sub>\<mu>"
           have "?RHS = (u \<star> (\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                          \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                          \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                          (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                          \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
             using comp_assoc by presburger
           also have "... = (u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0]) \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "u \<star> (\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] =
                   (u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])"
               using whisker_left \<mu>.ide_base \<theta>\<^sub>\<mu>' by blast
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = ((u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "seq (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])
                       (\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0))"
               by auto
             moreover have "src u = trg \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
               by simp
             moreover have "inv (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) = u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
               by simp
             moreover have "iso (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])"
               by simp
             moreover have "iso \<a>[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
               by simp
             ultimately have "(u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0] =
                              \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                                \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
               using pentagon hseqI' comp_assoc
                     invert_opposite_sides_of_square
                       [of "u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
                           "\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0)"
                           "\<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0]" "\<a>[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"]
                     inv_hcomp \<chi>.is_ide \<chi>.w_simps(3) \<chi>.w_simps(4) \<mu>.base_simps(2) \<mu>.ide_base
                     \<mu>.ide_leg0 \<mu>.leg0_simps(2) \<mu>.leg0_simps(3) \<sigma>.leg1_simps(3)
                     assoc'_eq_inv_assoc ide_hcomp r\<^sub>0s\<^sub>1.ide_u r\<^sub>0s\<^sub>1.p\<^sub>0_simps hcomp_simps(1)
               by presburger
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
                              \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "(u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] =
                   \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0)"
               using assoc_naturality [of u \<chi>.the_\<theta> \<rho>\<sigma>.p\<^sub>0] \<chi>.\<theta>_simps(3) by auto
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
                              (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) =
                   ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
               using assoc'_naturality [of \<mu> \<chi>.chine \<rho>\<sigma>.p\<^sub>0] by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              ((\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
                              (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
             using comp_assoc by metis
           also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                              (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "(\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
                   \<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0"
               using comp_inv_arr' comp_cod_arr by auto
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... = (\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
                              (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "arr ((u \<star> \<chi>.the_\<theta>) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine] \<cdot> (\<mu> \<star> \<chi>.chine) \<cdot> \<chi>.the_\<nu>)"
               using \<chi>.\<theta>_simps(3) by simp
             hence "((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                      ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
                    (u \<star> \<chi>.the_\<theta>) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine] \<cdot> (\<mu> \<star> \<chi>.chine) \<cdot> \<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0"
               using whisker_right by simp
             also have "... = (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0"
               using \<chi>.\<Delta>_naturality by simp
             finally have "((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
                             ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
                           (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0"
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = (?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>)) \<cdot>
                              \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
             using comp_assoc by presburger
           also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
             using \<gamma>\<^sub>\<tau>' \<gamma>\<^sub>\<tau>'_eq by simp
           also have "... = (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
                              ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                              (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
             using comp_assoc by presburger
           also have "... = (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
           proof -
             have "((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                     (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] =
                   \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
             proof -
               have "((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
                       (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] =
                     ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot>
                       (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
                 using comp_inv_arr' \<tau>.T0.antipar(1) by auto
               also have "... = ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
                 using comp_cod_arr t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
               also have "... = (t\<^sub>0u\<^sub>1.\<phi> \<cdot> inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
                 using whisker_right t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
               also have "... = ((u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
                 using comp_arr_inv' \<tau>.T0.antipar(1) t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
               also have "... = \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
                 using comp_cod_arr \<tau>.T0.antipar(1) by simp
               finally show ?thesis by simp
             qed
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... = (u \<star> the_\<theta>) \<cdot> (\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
             using assoc'_naturality [of \<mu> \<tau>\<mu>.p\<^sub>0 chine] comp_assoc by auto
           also have "... = ((u \<star> the_\<theta>) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine])) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
             using uw\<theta> pentagon comp_assoc
                   invert_opposite_sides_of_square
                     [of "u \<star> \<a>[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"
                         "\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine)" "\<a>[u, u\<^sub>0, ?w\<^sub>\<mu>]"
                         "\<a>[u \<star> u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"]
                   \<mu>.base_simps(2) \<mu>.ide_base \<mu>.ide_leg0 \<mu>.leg0_simps(2) assoc'_eq_inv_assoc
                   ide_hcomp hcomp_simps(1) t\<^sub>0u\<^sub>1.ide_u
             by force
           also have "... = (u \<star> the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
             using whisker_left comp_assoc by simp
           finally show ?thesis by simp
         qed
         show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>)"
           using w\<^sub>\<mu> w\<^sub>\<mu>' \<theta>\<^sub>\<mu> \<theta>\<^sub>\<mu>' \<beta>\<^sub>\<mu> eq\<^sub>\<mu> \<mu>.T2 [of ?w\<^sub>\<mu> ?w\<^sub>\<mu>' ?\<theta>\<^sub>\<mu> ?u\<^sub>\<mu> ?\<theta>\<^sub>\<mu>' ?\<beta>\<^sub>\<mu>] by fast
       qed
       obtain \<gamma>\<^sub>\<mu> where \<gamma>\<^sub>\<mu>: "\<guillemotleft>\<gamma>\<^sub>\<mu> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma>\<^sub>\<mu> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>\<^sub>\<mu>)"
         using 1 by auto
       show "?w\<^sub>\<mu> \<cong> ?w\<^sub>\<mu>'"
         using w\<^sub>\<mu> w\<^sub>\<mu>' \<gamma>\<^sub>\<mu> BS3 [of ?w\<^sub>\<mu> ?w\<^sub>\<mu>' \<gamma>\<^sub>\<mu> \<gamma>\<^sub>\<mu>] isomorphic_def by auto
     qed
 
     lemma comp_L:
     shows "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> =
          Maps.MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
     proof -
       show "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "is_left_adjoint (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)"
           using \<omega>.is_map r\<^sub>0s\<^sub>1.leg1_is_map left_adjoints_compose r\<^sub>0s\<^sub>1.p\<^sub>1_simps by auto
         thus ?thesis
           using Maps.CLS_in_hom r\<^sub>0s\<^sub>1.leg1_is_map
           apply (intro Maps.seqI')
            apply blast
           using Maps.CLS_in_hom [of t\<^sub>0] \<tau>.leg0_is_map \<rho>\<sigma>.leg1_in_hom by auto
       qed
       thus "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> =
             Maps.MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
         using Maps.comp_char by auto
     qed
 
     lemma comp_R:
     shows "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
     and "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> =
          Maps.MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
     proof -
       show "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
       proof -
         have "is_left_adjoint (\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0)"
           using \<chi>.is_map r\<^sub>0s\<^sub>1.leg0_is_map left_adjoints_compose [of \<chi>.chine \<rho>\<sigma>.p\<^sub>0] by simp
         thus ?thesis
           using Maps.CLS_in_hom \<mu>.leg1_is_map
           apply (intro Maps.seqI')
            apply blast
           using Maps.CLS_in_hom [of u\<^sub>1] \<mu>.leg1_is_map by simp
       qed
       thus "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> =
             Maps.MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
         using Maps.comp_char by auto
     qed
 
     lemma comp_L_eq_comp_R:
     shows "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
     proof (intro Maps.arr_eqI)
       show "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
         using comp_L(1) by simp
       show "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
         using comp_R(1) by simp
       show "Maps.Dom (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Dom (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
         by (metis (no_types, lifting) Maps.Dom.simps(1) \<omega>.w_simps(2) \<omega>.w_simps(3)
             \<rho>.leg1_simps(3) \<rho>\<sigma>.leg1_in_hom(2) comp_L(2) comp_R(2) hcomp_in_vhomE hseqI'
             r\<^sub>0s\<^sub>1.leg1_simps(3) hcomp_simps(1))
       show "Maps.Cod (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Cod (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
         by (metis Maps.Cod.simps(1) \<tau>\<mu>.composable comp_L(2) comp_R(2))
       have A: "Maps.Map (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
         using comp_L(1) Maps.comp_char by auto
       have B: "Maps.Map (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>) = Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
         using comp_R(1) Maps.comp_char by auto
       have C: "Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk> = Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
       proof (intro Maps.Comp_eqI)
         show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<in> Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
         proof (intro Maps.in_CompI)
           show "is_iso_class \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
             using prj_chine(2) is_iso_classI isomorphic_implies_hpar(2) by blast
           show "is_iso_class \<lbrakk>t\<^sub>0\<rbrakk>"
             using is_iso_classI by auto
           show "\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<in> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
             using ide_in_iso_class prj_chine(2) isomorphic_implies_hpar(2) by blast
           show "t\<^sub>0 \<in> \<lbrakk>t\<^sub>0\<rbrakk>"
             using ide_in_iso_class by simp
           show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
             using isomorphic_reflexive prj_chine(2) isomorphic_implies_hpar(2) by auto
         qed
         show "u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<in> Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
         proof (intro Maps.in_CompI)
           show "is_iso_class \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
             using is_iso_classI by simp
           show "is_iso_class \<lbrakk>u\<^sub>1\<rbrakk>"
             using is_iso_classI by simp
           show "\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<in> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
             using ide_in_iso_class by simp
           show "u\<^sub>1 \<in> iso_class u\<^sub>1"
             using ide_in_iso_class by simp
           show "u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
             using isomorphic_reflexive isomorphic_implies_hpar(2) by auto
         qed
         show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
         proof -
           have "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1"
             using assoc'_in_hom [of t\<^sub>0 \<omega>.chine \<rho>\<sigma>.p\<^sub>1] iso_assoc' isomorphic_def r\<^sub>0s\<^sub>1.p\<^sub>1_simps
             by auto
           also have "... \<cong> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1"
             using \<omega>.leg0_uniquely_isomorphic hcomp_isomorphic_ide
             by (simp add: \<rho>.T0.antipar(1))
           also have "... \<cong> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0"
             using isomorphic_def r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) by blast
           also have "... \<cong> (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0"
             using \<chi>.leg1_uniquely_isomorphic hcomp_isomorphic_ide by auto
           also have "... \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
             using assoc_in_hom [of u\<^sub>1 \<chi>.chine \<rho>\<sigma>.p\<^sub>0] iso_assoc isomorphic_def by auto
           finally show ?thesis by simp
         qed
       qed
       show "Maps.Map (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Map (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
         using A B C by simp
     qed
 
     lemma csq:
     shows "Maps.commutative_square \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
     proof
       show "Maps.cospan \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>"
         using comp_L(1) comp_R(1) comp_L_eq_comp_R
         by (metis (no_types, lifting) Maps.cod_comp Maps.seq_char)
       show "Maps.span \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
         using comp_L(1) comp_R(1) comp_L_eq_comp_R
         by (metis (no_types, lifting) Maps.dom_comp Maps.seq_char)
       show "Maps.dom \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> = Maps.cod \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
         using comp_L(1) by auto
       show "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
         using comp_L_eq_comp_R by simp
     qed
 
     lemma CLS_chine:
     shows "\<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = Maps.tuple \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
     proof -
       let ?T = "Maps.tuple \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
       have "\<exists>!l. \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> l = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and> \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> l = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
         using csq \<tau>\<mu>.prj_char
               Maps.universal [of "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"]
         by simp
       moreover have "\<lbrakk>\<lbrakk>\<tau>\<mu>.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> ?T = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and>
                      \<lbrakk>\<lbrakk>\<tau>\<mu>.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> ?T = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
         using csq \<tau>\<mu>.prj_char
               Maps.prj_tuple [of "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"]
         by simp
       moreover have "\<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and>
                      \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
         using prj_chine \<tau>\<mu>.leg0_is_map \<tau>\<mu>.leg1_is_map is_map t\<^sub>0u\<^sub>1.leg1_is_map
               t\<^sub>0u\<^sub>1.satisfies_T0 Maps.comp_CLS
         by blast
       ultimately show "\<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = ?T" by auto
     qed
 
   end
 
   subsection "Equivalence of B and Span(Maps(B))"
 
   subsubsection "The Functor SPN"
  
   text \<open>
     We now define a function \<open>SPN\<close> on arrows and will ultimately show that it extends to a
     biequivalence from the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>.
     The idea is that \<open>SPN\<close> takes \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close> to the isomorphism class of an induced arrow
     of spans from the chosen tabulation of \<open>r\<close> to the chosen tabulation of \<open>s\<close>.
     To obtain this, we first use isomorphisms \<open>r.tab\<^sub>1 \<star> r.tab\<^sub>0\<^sup>* \<cong> r\<close> and \<open>s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>* \<cong> s\<close>
     to transform \<open>\<mu>\<close> to \<open>\<guillemotleft>\<mu>' : r.tab\<^sub>1 \<star> r.tab\<^sub>0\<^sup>* \<Rightarrow> s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>*\<guillemotright>\<close>.
     We then take the adjoint transpose of \<open>\<mu>'\<close> to obtain
     \<open>\<guillemotleft>\<omega> : r.tab\<^sub>1 \<Rightarrow> (s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>*) \<star> r.tab\<^sub>0\<guillemotright>\<close>.  The 2-cell \<open>\<omega>\<close> induces a map \<open>w\<close>
     which is an arrow of spans from \<open>(r.tab\<^sub>0, r.tab\<^sub>1)\<close> to \<open>(s.tab\<^sub>0, s.tab\<^sub>1)\<close>.
     We take the arrow of \<open>Span(Maps(B))\<close> defined by \<open>w\<close> as the value of \<open>SPN \<mu>\<close>.
 
     Ensuring that \<open>SPN\<close> is functorial is a somewhat delicate point, which requires that all
     the underlying definitions that have been set up are ``just so'', with no extra choices
     other than those that are forced, and with the tabulation assigned to each 1-cell \<open>r\<close> in
     the proper relationship with the canonical tabulation assigned to its chosen factorization
     \<open>r = g \<star> f\<^sup>*\<close>.
   \<close>
 
   context bicategory_of_spans
   begin
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp  (infixr "\<odot>" 55)
     notation isomorphic (infix "\<cong>" 50)
 
     definition spn
     where "spn \<mu> \<equiv>
            arrow_of_tabulations_in_maps.chine V H \<a> \<i> src trg
              (tab_of_ide (dom \<mu>)) (tab\<^sub>0 (dom \<mu>)) (cod \<mu>)
              (tab_of_ide (cod \<mu>)) (tab\<^sub>0 (cod \<mu>)) (tab\<^sub>1 (cod \<mu>)) \<mu>"
 
     lemma is_induced_map_spn:
     assumes "arr \<mu>"
     shows "arrow_of_tabulations_in_maps.is_induced_map V H \<a> \<i> src trg
              (tab_of_ide (dom \<mu>)) (tab\<^sub>0 (dom \<mu>)) (cod \<mu>)
              (tab_of_ide (cod \<mu>)) (tab\<^sub>0 (cod \<mu>)) (tab\<^sub>1 (cod \<mu>))
              \<mu> (spn \<mu>)"
     proof -
       interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
         using assms by unfold_locales auto
       interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
                      \<open>cod \<mu>\<close> \<mu>.s.tab \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
                      \<mu>
         using \<mu>.is_arrow_of_tabulations_in_maps by simp
       show ?thesis
         unfolding spn_def
         using \<mu>.chine_is_induced_map by blast
     qed
 
     lemma spn_props:
     assumes "arr \<mu>"
     shows "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
     and "is_left_adjoint (spn \<mu>)"
     and "tab\<^sub>0 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>0 (dom \<mu>)"
     and "tab\<^sub>1 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>1 (dom \<mu>)"
     proof -
       interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
         using assms by unfold_locales auto
       interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
                      \<open>cod \<mu>\<close> \<mu>.s.tab \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
                      \<mu>
         using \<mu>.is_arrow_of_tabulations_in_maps by simp
       show "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
         using spn_def by simp
       show "is_left_adjoint (spn \<mu>)"
         using spn_def by (simp add: \<mu>.is_map)
       show "tab\<^sub>0 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>0 (dom \<mu>)"
         using spn_def isomorphic_def \<mu>.leg0_uniquely_isomorphic(1) by auto
       show "tab\<^sub>1 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>1 (dom \<mu>)"
         using spn_def isomorphic_def isomorphic_symmetric
               \<mu>.leg1_uniquely_isomorphic(1)
         by auto
     qed
 
     lemma spn_in_hom [intro]:
     assumes "arr \<mu>"
     shows "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
     and "\<guillemotleft>spn \<mu> : spn \<mu> \<Rightarrow> spn \<mu>\<guillemotright>"
       using assms spn_props left_adjoint_is_ide by auto
 
     lemma spn_simps [simp]:
     assumes "arr \<mu>"
     shows "is_left_adjoint (spn \<mu>)"
     and "ide (spn \<mu>)"
     and "src (spn \<mu>) = src (tab\<^sub>0 (dom \<mu>))"
     and "trg (spn \<mu>) = src (tab\<^sub>0 (cod \<mu>))"
       using assms spn_props left_adjoint_is_ide by auto
 
     text \<open>
       We need the next result to show that \<open>SPN\<close> is functorial; in particular,
       that it takes \<open>\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>\<close> in the underlying bicategory to a 1-cell
       in \<open>Span(Maps(B))\<close>.  The 1-cells in \<open>Span(Maps(B))\<close> have objects of \<open>Maps(B)\<close>
       as their chines, and objects of \<open>Maps(B)\<close> are isomorphism classes of objects in the
       underlying bicategory \<open>B\<close>. So we need the induced map associated with \<open>r\<close> to be isomorphic
       to an object.
     \<close>
 
     lemma spn_ide:
     assumes "ide r"
     shows "spn r \<cong> src (tab\<^sub>0 r)"
     proof -
       interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r
         using assms by unfold_locales auto
       interpret r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> r
         using r.is_arrow_of_tabulations_in_maps by simp
       interpret tab: tabulation V H \<a> \<i> src trg r \<open>r.tab\<close> \<open>tab\<^sub>0 r\<close> \<open>dom r.tab\<close>
         using assms r.tab_is_tabulation by simp
       interpret tab: tabulation_in_maps V H \<a> \<i> src trg r \<open>r.tab\<close> \<open>tab\<^sub>0 r\<close> \<open>dom r.tab\<close>
         by (unfold_locales, simp_all)
       have "tab.is_induced_by_cell (spn r) (tab\<^sub>0 r) r.tab"
         using spn_def comp_ide_arr r.chine_is_induced_map by auto
       thus ?thesis
         using tab.induced_map_unique [of "tab\<^sub>0 r" "r.tab" "spn r" "src r.s\<^sub>0"]
               tab.apex_is_induced_by_cell
         by (simp add: comp_assoc)
     qed
 
     text \<open>
       The other key result we need to show that \<open>SPN\<close> is functorial is to show
       that the induced map of a composite is isomorphic to the composite of
       induced maps.
     \<close>
 
     lemma spn_hcomp:
     assumes "seq \<tau> \<mu>" and "g \<cong> spn \<tau>" and "f \<cong> spn \<mu>"
     shows "spn (\<tau> \<cdot> \<mu>) \<cong> g \<star> f"
     proof -
       interpret \<tau>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<tau>\<close> \<open>cod \<tau>\<close> \<tau>
         using assms by unfold_locales auto
       interpret \<tau>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      \<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
                      \<open>cod \<tau>\<close> \<tau>.s.tab \<open>tab\<^sub>0 (cod \<tau>)\<close> \<open>tab\<^sub>1 (cod \<tau>)\<close>
                      \<tau>
         using \<tau>.is_arrow_of_tabulations_in_maps by simp
       interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>dom \<tau>\<close> \<mu>
         using assms apply unfold_locales
          apply auto[1]
         by (elim seqE, auto)
       interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
                      \<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
                      \<mu>
         using \<mu>.is_arrow_of_tabulations_in_maps by simp
       interpret \<tau>\<mu>: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
                       \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
                       \<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
                       \<open>cod \<tau>\<close> \<tau>.s.tab \<open>tab\<^sub>0 (cod \<tau>)\<close> \<open>tab\<^sub>1 (cod \<tau>)\<close>
                       \<mu> \<tau>
         ..
       have "g \<cong> \<tau>.chine"
         using assms(2) spn_def by auto
       moreover have "f \<cong> \<mu>.chine"
         using assms(1) assms(3) spn_def by auto
       moreover have "src g = trg f"
         using calculation(1-2) isomorphic_implies_hpar(3-4) by auto
       moreover have "src g = trg \<mu>.chine"
         using calculation(1) isomorphic_implies_hpar(3) by auto
       ultimately have "g \<star> f \<cong> \<tau>.chine \<star> \<mu>.chine"
         using hcomp_ide_isomorphic hcomp_isomorphic_ide isomorphic_transitive
         by (meson \<mu>.is_ide isomorphic_implies_ide(1))
       also have "... \<cong> spn (\<tau> \<cdot> \<mu>)"
         using spn_def \<tau>\<mu>.chine_char isomorphic_symmetric
         by (metis \<tau>\<mu>.in_hom in_homE)
       finally show ?thesis
         using isomorphic_symmetric by simp
     qed
 
     abbreviation (input) SPN\<^sub>0
     where "SPN\<^sub>0 r \<equiv> Span.mkIde \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
 
     definition SPN
     where "SPN \<mu> \<equiv> if arr \<mu> then
                       \<lparr>Chn = \<lbrakk>\<lbrakk>spn \<mu>\<rbrakk>\<rbrakk>,
                        Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>,
                        Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<rparr>
                     else Span.null"
 
     lemma Dom_SPN [simp]:
     assumes "arr \<mu>"
     shows "Dom (SPN \<mu>) = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>"
       using assms SPN_def by simp
 
     lemma Cod_SPN [simp]:
     assumes "arr \<mu>"
     shows "Cod (SPN \<mu>) = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>"
       using assms SPN_def by simp
 
     text \<open>Now we have to show this does the right thing for us.\<close>
 
     lemma SPN_in_hom:
     assumes "arr \<mu>"
     shows "Span.in_hom (SPN \<mu>) (SPN\<^sub>0 (dom \<mu>)) (SPN\<^sub>0 (cod \<mu>))"
     proof
       interpret Dom: span_in_category Maps.comp \<open>Dom (SPN \<mu>)\<close>
       proof
         interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close>
           using assms by unfold_locales auto
         show "Maps.span (Leg0 (Dom (SPN \<mu>))) (Leg1 (Dom (SPN \<mu>)))"
           using assms Maps.CLS_in_hom SPN_def
           by (metis (no_types, lifting) Maps.in_homE bicategory_of_spans.Dom_SPN
               bicategory_of_spans_axioms r.leg1_is_map r.leg1_simps(3) r.satisfies_T0
               span_data.simps(1) span_data.simps(2))
       qed
       interpret Dom': span_in_category Maps.comp 
                         \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<close>
         using assms Dom.span_in_category_axioms SPN_def by simp
       interpret Cod: span_in_category Maps.comp \<open>Cod (SPN \<mu>)\<close>
       proof
         interpret s: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod \<mu>\<close>
           using assms by unfold_locales auto
         show "Maps.span (Leg0 (Cod (SPN \<mu>))) (Leg1 (Cod (SPN \<mu>)))"
           using assms Maps.CLS_in_hom SPN_def
           by (metis (no_types, lifting) bicategory_of_spans.Cod_SPN bicategory_of_spans_axioms
               ide_dom s.base_simps(2) s.base_simps(3) s.determines_span span_in_category.is_span)
       qed
       interpret Cod': span_in_category Maps.comp 
                         \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<close>
         using assms Cod.span_in_category_axioms SPN_def by simp
       show 1: "Span.arr (SPN \<mu>)"
       proof (unfold Span.arr_char)
         show "arrow_of_spans Maps.comp (SPN \<mu>)"
         proof (unfold_locales)
           show "Maps.in_hom (Chn (SPN \<mu>)) Dom.apex Cod.apex"
             unfolding SPN_def Maps.in_hom_char
             using assms Dom'.apex_def Cod'.apex_def Dom'.is_span Cod'.is_span Maps.arr_char
             by auto
           show "Cod.leg0 \<odot> Chn (SPN \<mu>) = Dom.leg0"
             unfolding SPN_def
             using assms spn_props [of \<mu>] Maps.comp_CLS [of "tab\<^sub>0 (cod \<mu>)" "spn \<mu>"] by simp
           show "Cod.leg1 \<odot> Chn (SPN \<mu>) = Dom.leg1"
             unfolding SPN_def
             using assms spn_props [of \<mu>] Maps.comp_CLS [of "tab\<^sub>1 (cod \<mu>)" "spn \<mu>"] by simp
         qed
       qed
       show "Span.dom (SPN \<mu>) = SPN\<^sub>0 (dom \<mu>)"
         using assms 1 Span.dom_char Dom'.apex_def SPN_def by simp
       show "Span.cod (SPN \<mu>) = SPN\<^sub>0 (cod \<mu>)"
         using assms 1 Span.cod_char Cod'.apex_def SPN_def by simp
     qed
 
     interpretation SPN: "functor" V Span.vcomp SPN
     proof
       show "\<And>\<mu>. \<not> arr \<mu> \<Longrightarrow> SPN \<mu> = Span.null"
         unfolding SPN_def by simp
       show 1: "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.arr (SPN \<mu>)"
         using SPN_in_hom by auto
       show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.dom (SPN \<mu>) = SPN (dom \<mu>)"
       proof -
         fix \<mu>
         assume \<mu>: "arr \<mu>"
         have 1: "Maps.arr (Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>)"
         proof -
           have "src (tab\<^sub>0 (dom \<mu>)) \<in> Collect obj"
             using \<mu> by simp
           moreover have "src \<mu> \<in> Collect obj"
             using \<mu> by simp
           moreover have "\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (local.dom \<mu>))) (src \<mu>)"
           proof -
             have "\<guillemotleft>tab\<^sub>0 (dom \<mu>) : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src \<mu>\<guillemotright>"
               using \<mu> by simp
             moreover have "is_left_adjoint (tab\<^sub>0 (dom \<mu>))"
               using \<mu> tab\<^sub>0_simps [of "dom \<mu>"] by auto
             ultimately show ?thesis by auto
           qed
           ultimately show ?thesis by simp
         qed
         have "\<lbrakk>spn (dom \<mu>)\<rbrakk> = \<lbrakk>src (tab\<^sub>0 (dom \<mu>))\<rbrakk>"
           using \<mu> spn_ide iso_class_eqI by auto
         hence "SPN (dom \<mu>) = SPN\<^sub>0 (dom \<mu>)"
           unfolding SPN_def
           using \<mu> 1 Maps.dom_char by simp
         thus "Span.dom (SPN \<mu>) = SPN (dom \<mu>)"
           using \<mu> SPN_in_hom by auto
       qed
       show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.cod (SPN \<mu>) = SPN (cod \<mu>)"
       proof -
         fix \<mu>
         assume \<mu>: "arr \<mu>"
         have 1: "Maps.arr (Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>)"
         proof -
           have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
             using \<mu> by simp
           moreover have "src \<mu> \<in> Collect obj"
             using \<mu> by simp
           moreover have "\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>)"
           proof -
             have "\<guillemotleft>tab\<^sub>0 (cod \<mu>) : src (tab\<^sub>0 (cod \<mu>)) \<rightarrow> src \<mu>\<guillemotright>"
               using \<mu> by simp
             moreover have "is_left_adjoint (tab\<^sub>0 (cod \<mu>))"
               using \<mu> by simp
             ultimately show ?thesis by auto
           qed
           ultimately show ?thesis by simp
         qed
         have "\<lbrakk>spn (cod \<mu>)\<rbrakk> = \<lbrakk>src (tab\<^sub>0 (cod \<mu>))\<rbrakk>"
           using \<mu> spn_ide iso_class_eqI by auto
         hence "SPN (cod \<mu>) = SPN\<^sub>0 (cod \<mu>)"
           unfolding SPN_def
           using \<mu> 1 Maps.dom_char by simp
         thus "Span.cod (SPN \<mu>) = SPN (cod \<mu>)"
           using \<mu> SPN_in_hom by auto
       qed
       show "\<And>\<nu> \<mu>. seq \<nu> \<mu> \<Longrightarrow> SPN (\<nu> \<cdot> \<mu>) = SPN \<nu> \<bullet> SPN \<mu>"
       proof -
         fix \<mu> \<nu>
         assume seq: "seq \<nu> \<mu>"
         have "Dom (SPN (\<nu> \<cdot> \<mu>)) = Dom (SPN \<nu> \<bullet> SPN \<mu>)"
           using seq 1 Span.vcomp_def Span.arr_char
           by (elim seqE, simp)
         moreover have "Cod (SPN (\<nu> \<cdot> \<mu>)) = Cod (SPN \<nu> \<bullet> SPN \<mu>)"
           using seq 1 Span.vcomp_def Span.arr_char
           by (elim seqE, simp)
         moreover have "Chn (SPN (\<nu> \<cdot> \<mu>)) = Chn (SPN \<nu> \<bullet> SPN \<mu>)"
         proof -
           have *: "\<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk> = Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
           proof
             show "\<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk> \<subseteq> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
             proof
               fix h
               assume h: "h \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
               show "h \<in> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
               proof -
                 have 1: "spn \<nu> \<in> \<lbrakk>spn \<nu>\<rbrakk>"
                   using seq ide_in_iso_class by auto
                 moreover have 2: "spn \<mu> \<in> \<lbrakk>spn \<mu>\<rbrakk>"
                   using seq ide_in_iso_class by auto
                 moreover have "spn \<nu> \<star> spn \<mu> \<cong> h"
                 proof -
                   have "spn \<nu> \<star> spn \<mu> \<cong> spn (\<nu> \<cdot> \<mu>)"
                     using seq spn_hcomp 1 2 iso_class_def isomorphic_reflexive
                           isomorphic_symmetric
                     by simp
                   thus ?thesis
                     using h isomorphic_transitive iso_class_def by simp
                 qed
                 ultimately show ?thesis
                   unfolding Maps.Comp_def
                   by (metis (mono_tags, lifting) is_iso_classI spn_simps(2)
                       mem_Collect_eq seq seqE)
               qed
             qed
             show "Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk> \<subseteq> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
             proof
               fix h
               assume h: "h \<in> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
               show "h \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
               proof -
                 obtain f g where 1: "g \<in> \<lbrakk>spn \<nu>\<rbrakk> \<and> f \<in> \<lbrakk>spn \<mu>\<rbrakk> \<and> g \<star> f \<cong> h"
                   using h Maps.Comp_def [of "iso_class (spn \<nu>)" "iso_class (spn \<mu>)"]
                         iso_class_def iso_class_elems_isomorphic
                   by blast
                 have fg: "g \<cong> spn \<nu> \<and> f \<cong> spn \<mu> \<and> g \<star> f \<cong> h"
                 proof -
                   have "spn \<nu> \<in> \<lbrakk>spn \<nu>\<rbrakk> \<and> spn \<mu> \<in> \<lbrakk>spn \<mu>\<rbrakk>"
                     using seq ide_in_iso_class by auto
                   thus ?thesis
                     using 1 iso_class_elems_isomorphic isomorphic_symmetric is_iso_classI
                     by (meson spn_simps(2) seq seqE)
                 qed
                 have "g \<star> f \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
                   using seq fg 1 spn_hcomp iso_class_def isomorphic_symmetric by simp
                 thus ?thesis
                   using fg isomorphic_transitive iso_class_def by blast
               qed
             qed
           qed
           have "Chn (SPN \<nu> \<bullet> SPN \<mu>) =
                 Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk> \<odot>
                   Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"
             using 1 seq SPN_def Span.vcomp_def Span.arr_char
             apply (elim seqE)
             apply simp
             by (metis (no_types, lifting) seq vseq_implies_hpar(1) vseq_implies_hpar(2))
           also have "... = Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))
                                       (Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>)"
           proof -
             have "Maps.seq (Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
                            (Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)"
             proof
               show "Maps.in_hom (Maps.MkArr (src (tab\<^sub>0 (local.dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>)))
                                             \<lbrakk>spn \<mu>\<rbrakk>)
                                 (Maps.MkIde (src (tab\<^sub>0 (dom \<mu>))))
                                 (Maps.MkIde (src (tab\<^sub>0 (cod \<mu>))))"
               proof -
                 have "src (tab\<^sub>0 (dom \<mu>)) \<in> Collect obj"
                   using in_hhom_def seq by auto
                 moreover have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
                   using seq by auto
                 moreover have "\<lbrakk>spn \<mu>\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>)))"
                   using spn_props
                   by (metis (mono_tags, lifting) mem_Collect_eq seq seqE)
                 ultimately show ?thesis
                   using Maps.MkArr_in_hom by simp
               qed
               show "Maps.in_hom (Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
                                 (Maps.MkIde (src (tab\<^sub>0 (cod \<mu>))))
                                 (Maps.MkIde (src (tab\<^sub>0 (cod \<nu>))))"
               proof -
                 have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
                   using in_hhom_def seq by auto
                 moreover have "src (tab\<^sub>0 (cod \<nu>)) \<in> Collect obj"
                   using seq by auto
                 moreover have "\<lbrakk>spn \<nu>\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))"
                   using spn_props
                   by (metis (mono_tags, lifting) mem_Collect_eq seq seqE)
                 ultimately show ?thesis
                   using Maps.MkArr_in_hom by simp
               qed
             qed
             thus ?thesis
               using Maps.comp_char
                      [of "Maps.MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>"
                          "Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"]
               by simp
           qed
           also have "... = Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
             using * by simp
           also have "... = Chn (SPN (\<nu> \<cdot> \<mu>))"
             using seq SPN_def Span.vcomp_def
             by (elim seqE, simp)
           finally show ?thesis by simp
         qed
         ultimately show "SPN (\<nu> \<cdot> \<mu>) = SPN \<nu> \<bullet> SPN \<mu>" by simp
       qed
     qed
 
     lemma SPN_is_functor:
     shows "functor V Span.vcomp SPN"
       ..
 
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
     proof
       show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.isomorphic (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
       proof -
         fix \<mu>
         assume \<mu>: "arr \<mu>"
         let ?src = "Maps.MkIde (src \<mu>)"
         have src: "Maps.ide ?src"
           using \<mu> by simp
         interpret src: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>src \<mu>\<close>
           using \<mu> by unfold_locales auto
         interpret src: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                          \<open>src \<mu>\<close> src.tab \<open>tab\<^sub>0 (src \<mu>)\<close> \<open>tab\<^sub>1 (src \<mu>)\<close>
                          \<open>src \<mu>\<close> src.tab \<open>tab\<^sub>0 (src \<mu>)\<close> \<open>tab\<^sub>1 (src \<mu>)\<close>
                          \<open>src \<mu>\<close>
           using src.is_arrow_of_tabulations_in_maps by simp
         interpret src: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>\<close>
           using src by (unfold_locales, simp)
 
         let ?tab\<^sub>0 = "Maps.MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
         have tab\<^sub>0_src: "\<guillemotleft>tab\<^sub>0 (src \<mu>) : src (tab\<^sub>0 (src \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
                         is_left_adjoint (tab\<^sub>0 (src \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
           using \<mu> by simp
         have tab\<^sub>0: "Maps.arr ?tab\<^sub>0"
           using \<mu> Maps.arr_MkArr tab\<^sub>0_src by blast
         let ?tab\<^sub>1 = "Maps.MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
         have tab\<^sub>1_src: "\<guillemotleft>tab\<^sub>1 (src \<mu>) : src (tab\<^sub>0 (src \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
                         is_left_adjoint (tab\<^sub>1 (src \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
           using \<mu> by simp
         have tab\<^sub>1: "Maps.arr ?tab\<^sub>1"
           using \<mu> Maps.arr_MkArr tab\<^sub>1_src by blast
         interpret tab: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<close>
           using tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char by (unfold_locales, simp)
 
         have "src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>0 (src \<mu>)"
           using \<mu> iso_lunit isomorphic_def
           by (metis lunit_in_hom(2) src.ide_u src.u_simps(3) src_src)
         hence "src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>1 (src \<mu>)"
           using \<mu> src.obj_has_symmetric_tab isomorphic_transitive by blast
 
         have "\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)"
           using \<mu> tab\<^sub>0_src by blast
         have "\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)"
         proof -
           have "\<guillemotleft>src \<mu> : src \<mu> \<rightarrow> src \<mu>\<guillemotright> \<and> is_left_adjoint (src \<mu>) \<and> \<lbrakk>src \<mu>\<rbrakk> = \<lbrakk>src \<mu>\<rbrakk>"
             using \<mu> obj_is_self_adjoint by simp
           thus ?thesis by auto
         qed
 
         interpret SPN_src: arrow_of_spans Maps.comp \<open>SPN (src \<mu>)\<close>
           using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
         have SPN_src: "SPN (src \<mu>) =
                        \<lparr>Chn = Maps.MkArr (src (tab\<^sub>0 (src \<mu>))) (src (tab\<^sub>0 (src \<mu>))) \<lbrakk>spn (src \<mu>)\<rbrakk>,
                         Dom = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>,
                         Cod = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<rparr>"
           unfolding SPN_def using \<mu> by simp
 
         interpret src_SPN: arrow_of_spans Maps.comp \<open>Span.src (SPN \<mu>)\<close>
           using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
         have src_SPN: "Span.src (SPN \<mu>) =
                        \<lparr>Chn = ?src,
                         Dom = \<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>,
                         Cod = \<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>\<rparr>"
         proof -
           let ?tab\<^sub>0_dom = "Maps.MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
           have "Maps.arr ?tab\<^sub>0_dom"
           proof -
             have "\<guillemotleft>tab\<^sub>0 (dom \<mu>) : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
                   is_left_adjoint (tab\<^sub>0 (dom \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
               using \<mu> by simp
             thus ?thesis
               using \<mu> Maps.arr_MkArr by blast
           qed
           thus ?thesis
             using \<mu> Maps.cod_char Span.src_def by simp
         qed
 
         text \<open>
           The idea of the proof is that @{term "iso_class (tab\<^sub>0 (src \<mu>))"} is invertible
           in \<open>Maps(B)\<close> and determines an invertible arrow of spans from @{term "SPN (src \<mu>)"}
           to @{term "Span.src (SPN \<mu>)"}.
         \<close>
 
         let ?\<phi> = "\<lparr>Chn = ?tab\<^sub>0, Dom = Dom (SPN (src \<mu>)), Cod = Cod (Span.src (SPN \<mu>))\<rparr>"
         interpret \<phi>: arrow_of_spans Maps.comp ?\<phi>
           apply (unfold_locales, simp_all)
         proof -
           show "Maps.in_hom ?tab\<^sub>0 SPN_src.dom.apex src_SPN.cod.apex"
             using \<mu> tab\<^sub>0 Maps.dom_char Maps.cod_char SPN_src src_SPN
                   tab.apex_def src_SPN.cod.apex_def
             apply (intro Maps.in_homI) by simp_all
           show "src_SPN.cod.leg0 \<odot> ?tab\<^sub>0 = SPN_src.dom.leg0"
           proof -
             have "Maps.seq src_SPN.cod.leg0 ?tab\<^sub>0"
               using \<mu> src_SPN tab\<^sub>0 Maps.dom_char Maps.cod_char
               by (intro Maps.seqI, auto)
             moreover have "Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
             proof -
               have "tab\<^sub>0 (src \<mu>) \<in> Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
                 using \<mu> is_iso_classI ide_in_iso_class [of "src \<mu>"]
                       ide_in_iso_class [of "tab\<^sub>0 (src \<mu>)"] \<open>src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>0 (src \<mu>)\<close>
                 by auto
               thus ?thesis
                 using Maps.Comp_eq_iso_class_memb
                       \<open>\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)\<close>
                       \<open>\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)\<close>
                 by meson
             qed
             ultimately show ?thesis
               using \<mu> Maps.comp_char [of src_SPN.cod.leg0 ?tab\<^sub>0] src_SPN by simp
           qed
           show "src_SPN.cod.leg1 \<odot> ?tab\<^sub>0 = SPN_src.dom.leg1"
           proof -
             have "Maps.seq src_SPN.cod.leg1 ?tab\<^sub>0"
               using \<mu> src_SPN tab\<^sub>0 Maps.dom_char Maps.cod_char
               by (intro Maps.seqI, auto)
             moreover have "Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
             proof -
               have "tab\<^sub>1 (src \<mu>) \<in> Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
                 using \<mu> is_iso_classI ide_in_iso_class [of "src \<mu>"]
                       ide_in_iso_class [of "tab\<^sub>0 (src \<mu>)"]
                       \<open>isomorphic (src \<mu> \<star> tab\<^sub>0 (src \<mu>)) (tab\<^sub>1 (src \<mu>))\<close>
                 by auto
               thus ?thesis
                 using Maps.Comp_eq_iso_class_memb
                       \<open>\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)\<close>
                       \<open>\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)\<close>
                 by meson
             qed
             ultimately show ?thesis
               using \<mu> Maps.comp_char [of src_SPN.cod.leg1 ?tab\<^sub>0] src_SPN by simp
           qed
         qed
         have "Span.in_hom ?\<phi> (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
           using \<mu> tab\<^sub>0 spn_ide [of "src \<mu>"] iso_class_eqI
                 Span.arr_char Span.dom_char Span.cod_char \<phi>.arrow_of_spans_axioms
                 SPN_src src_SPN src.apex_def tab.apex_def Maps.dom_char
           apply (intro Span.in_homI) by auto
           (* The preceding cannot be written "by (intro Span.in_homI, auto)", why? *)
         moreover have "Maps.iso ?tab\<^sub>0"
           using \<mu> tab\<^sub>0 ide_in_iso_class src.is_map_iff_tab\<^sub>0_is_equivalence obj_is_self_adjoint
                 Maps.iso_char' [of ?tab\<^sub>0]
           by auto
         ultimately show "Span.isomorphic (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
           using Span.isomorphic_def Span.iso_char by auto
       qed
       show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.isomorphic (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
       proof -
         fix \<mu>
         assume \<mu>: "arr \<mu>"
         let ?trg = "Maps.MkIde (trg \<mu>)"
         have trg: "Maps.ide ?trg"
           using \<mu> by simp
         interpret trg: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>trg \<mu>\<close>
           using \<mu> by unfold_locales auto
         interpret trg: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>\<close>
           using trg by (unfold_locales, simp)
 
         let ?tab\<^sub>0 = "Maps.MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
         have tab\<^sub>0_trg: "\<guillemotleft>tab\<^sub>0 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
                         is_left_adjoint (tab\<^sub>0 (trg \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
           using \<mu> by simp
         have tab\<^sub>0: "Maps.arr ?tab\<^sub>0"
           using \<mu> Maps.arr_MkArr tab\<^sub>0_trg by blast
         let ?tab\<^sub>1 = "Maps.MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
         have tab\<^sub>1_trg: "\<guillemotleft>tab\<^sub>1 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
                         is_left_adjoint (tab\<^sub>1 (trg \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
           using \<mu> by simp
         have tab\<^sub>1: "Maps.arr ?tab\<^sub>1"
           using \<mu> Maps.arr_MkArr tab\<^sub>1_trg by blast
         interpret tab: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<close>
           using tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char by (unfold_locales, simp)
 
         have "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>0 (trg \<mu>)"
         proof -
           have "\<guillemotleft>\<l>[tab\<^sub>1 (trg \<mu>)] : trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<Rightarrow> tab\<^sub>1 (trg \<mu>)\<guillemotright>"
             using \<mu> by simp
           moreover have "iso \<l>[tab\<^sub>1 (trg \<mu>)]"
             using \<mu> iso_lunit by simp
           ultimately have "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)"
             using isomorphic_def by auto
           also have "tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>0 (trg \<mu>)"
             using \<mu> trg.obj_has_symmetric_tab isomorphic_symmetric by auto
           finally show ?thesis by blast
         qed
         hence "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)"
           using \<mu> trg.obj_has_symmetric_tab isomorphic_transitive by blast
 
         have "\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)"
         proof -
           have "\<guillemotleft>tab\<^sub>1 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and> is_left_adjoint (tab\<^sub>0 (trg \<mu>)) \<and>
                 \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
             using \<mu> by simp
           thus ?thesis by auto
         qed
         have "\<lbrakk>trg \<mu>\<rbrakk> \<in> Maps.Hom (trg \<mu>) (trg \<mu>)"
         proof -
           have "\<guillemotleft>trg \<mu> : trg \<mu> \<rightarrow> trg \<mu>\<guillemotright> \<and> is_left_adjoint (trg \<mu>) \<and> \<lbrakk>trg \<mu>\<rbrakk> = \<lbrakk>trg \<mu>\<rbrakk>"
             using \<mu> obj_is_self_adjoint by simp
           thus ?thesis by auto
         qed
 
         interpret SPN_trg: arrow_of_spans Maps.comp \<open>SPN (trg \<mu>)\<close>
           using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
         have SPN_trg: "SPN (trg \<mu>) =
                        \<lparr>Chn = Maps.MkArr (src (tab\<^sub>1 (trg \<mu>))) (src (tab\<^sub>1 (trg \<mu>))) \<lbrakk>spn (trg \<mu>)\<rbrakk>,
                         Dom = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>,
                         Cod = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<rparr>"
           unfolding SPN_def using \<mu> by simp
 
         interpret trg_SPN: arrow_of_spans Maps.comp \<open>Span.trg (SPN \<mu>)\<close>
           using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
         have trg_SPN: "Span.trg (SPN \<mu>) = \<lparr>Chn = ?trg,
                                            Dom = \<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>,
                                            Cod = \<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>\<rparr>"
         proof -
           let ?tab\<^sub>1_dom = "Maps.MkArr (src (tab\<^sub>1 (dom \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
           have "Maps.arr ?tab\<^sub>1_dom"
           proof -
             have "\<guillemotleft>tab\<^sub>1 (dom \<mu>) : src (tab\<^sub>1 (dom \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
                   is_left_adjoint (tab\<^sub>1 (dom \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
               using \<mu> by simp
             thus ?thesis
               using \<mu> Maps.arr_MkArr by blast
           qed
           thus ?thesis
             using \<mu> Maps.cod_char Span.trg_def by simp
         qed
 
         let ?\<phi> = "\<lparr>Chn = ?tab\<^sub>1, Dom = Dom (SPN (trg \<mu>)), Cod = Cod (Span.trg (SPN \<mu>))\<rparr>"
         interpret \<phi>: arrow_of_spans Maps.comp ?\<phi>
           apply (unfold_locales, simp_all)
         proof -
           show "Maps.in_hom ?tab\<^sub>1 SPN_trg.dom.apex trg_SPN.cod.apex"
             using \<mu> tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char SPN_trg trg_SPN
                   tab.apex_def trg_SPN.cod.apex_def
             apply (intro Maps.in_homI) by simp_all
             (* The preceding cannot be written "by (intro Maps.in_homI, simp_all)", why? *)
           show "Maps.comp trg_SPN.cod.leg0 ?tab\<^sub>1 = SPN_trg.dom.leg0"
           proof -
             have "Maps.seq trg_SPN.cod.leg0 ?tab\<^sub>1"
               using \<mu> trg_SPN tab\<^sub>1 Maps.dom_char Maps.cod_char
               by (intro Maps.seqI, auto)
             moreover have "Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
             proof -
               have "tab\<^sub>1 (trg \<mu>) \<in> Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
                 using \<mu> is_iso_classI ide_in_iso_class [of "trg \<mu>"]
                       ide_in_iso_class [of "tab\<^sub>1 (trg \<mu>)"] \<open>trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)\<close>
                 by auto
               thus ?thesis
                 using Maps.Comp_eq_iso_class_memb
                       \<open>iso_class (tab\<^sub>1 (trg \<mu>)) \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)\<close>
                       \<open>iso_class (trg \<mu>) \<in> Maps.Hom (trg \<mu>) (trg \<mu>)\<close>
                 by meson
             qed
             moreover have "\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
               using \<mu> iso_class_eqI trg.obj_has_symmetric_tab by auto
             ultimately show ?thesis
               using \<mu> Maps.comp_char [of trg_SPN.cod.leg0 ?tab\<^sub>1] trg_SPN
               by simp
           qed
           show "trg_SPN.cod.leg1 \<odot> ?tab\<^sub>1 = SPN_trg.dom.leg1"
           proof -
             have "Maps.seq trg_SPN.cod.leg1 ?tab\<^sub>1"
               using \<mu> trg_SPN tab\<^sub>1 Maps.dom_char Maps.cod_char
               by (intro Maps.seqI, auto)
             moreover have "Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
             proof -
               have "tab\<^sub>1 (trg \<mu>) \<in> Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
                 using \<mu> is_iso_classI ide_in_iso_class [of "trg \<mu>"]
                       ide_in_iso_class [of "tab\<^sub>1 (trg \<mu>)"] \<open>trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)\<close>
                 by auto
               thus ?thesis
                 using Maps.Comp_eq_iso_class_memb
                       \<open>\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)\<close>
                       \<open>\<lbrakk>trg \<mu>\<rbrakk> \<in> Maps.Hom (trg \<mu>) (trg \<mu>)\<close>
                 by meson
             qed
             ultimately show ?thesis
               using \<mu> Maps.comp_char [of trg_SPN.cod.leg1 ?tab\<^sub>1] trg_SPN by simp
           qed
         qed
         have \<phi>: "Span.in_hom ?\<phi> (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
           using \<mu> tab\<^sub>0 spn_ide [of "trg \<mu>"] iso_class_eqI
                 Span.arr_char Span.dom_char Span.cod_char \<phi>.arrow_of_spans_axioms
                 SPN_trg trg_SPN trg.apex_def tab.apex_def Maps.dom_char
           apply (intro Span.in_homI) by auto
         have "Maps.iso ?tab\<^sub>1"
         proof -
           have "Maps.iso ?tab\<^sub>0"
             using \<mu> tab\<^sub>0 ide_in_iso_class trg.is_map_iff_tab\<^sub>0_is_equivalence obj_is_self_adjoint
                   Maps.iso_char' [of ?tab\<^sub>0]
             by auto
           moreover have "?tab\<^sub>0 = ?tab\<^sub>1"
           proof -
             have "\<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
               using \<mu> iso_class_eqI trg.obj_has_symmetric_tab by auto
             thus ?thesis by simp
           qed
           ultimately show ?thesis by simp
         qed
         thus "Span.isomorphic (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
           using \<phi> Span.isomorphic_def Span.iso_char by auto
       qed
     qed
 
     lemma SPN_is_weak_arrow_of_homs:
     shows "weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN"
       ..
 
   end
 
   subsubsection "Compositors"
 
   text \<open>
     To complete the proof that \<open>SPN\<close> is a pseudofunctor, we need to obtain a natural
     isomorphism \<open>\<Phi>\<close>, whose component at \<open>(r, s)\<close> is an isomorphism \<open>\<Phi> (r, s)\<close>
     from the horizontal composite \<open>SPN r \<circ> SPN s\<close> to \<open>SPN (r \<star> s)\<close> in \<open>Span(Maps(B))\<close>,
     and we need to prove that the coherence conditions are satisfied.
 
     We have shown that the tabulations of \<open>r\<close> and \<open>s\<close> compose to yield a tabulation of \<open>r \<star> s\<close>.
     Since tabulations of the same arrow are equivalent, this tabulation must be equivalent
     to the chosen tabulation of \<open>r \<star> s\<close>.  We therefore obtain an equivalence map from the
     apex of \<open>SPN r \<circ> SPN s\<close> to the apex of \<open>SPN (r \<star> s)\<close> which commutes with the
     legs of these spans up to isomorphism.  This equivalence map determines an invertible
     arrow in \<open>Span(Maps(B))\<close>.  Moreover, by property \<open>T2\<close>, any two such equivalence maps are
     connected by a unique 2-cell, which is consequently an isomorphism.  This shows that
     the arrow in \<open>Span(Maps(B))\<close> is uniquely determined, which fact we can exploit to establish
     the required coherence conditions.
   \<close>
 
   locale two_composable_identities_in_bicategory_of_spans =
     bicategory_of_spans V H \<a> \<i> src trg +
     r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r +
     s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and r :: 'a
   and s :: 'a +
   assumes composable: "src r = trg s"
   begin
 
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation r: arrow_in_bicategory_of_spans V H \<a> \<i> src trg r r r
       by unfold_locales auto
     interpretation r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
                         r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
                         r
       using r.is_arrow_of_tabulations_in_maps by simp
     interpretation s: arrow_in_bicategory_of_spans V H \<a> \<i> src trg s s s
       by unfold_locales auto
     interpretation s: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
                         s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
                         s
       using s.is_arrow_of_tabulations_in_maps by simp
 
     sublocale identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>r \<star> s\<close>
       apply unfold_locales by (simp add: composable)
     sublocale horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
                 r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
                 r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
                 r s
       using composable by unfold_locales auto
 
     abbreviation p\<^sub>0 where "p\<^sub>0 \<equiv> \<rho>\<sigma>.p\<^sub>0"
     abbreviation p\<^sub>1 where "p\<^sub>1 \<equiv> \<rho>\<sigma>.p\<^sub>1"
 
     text \<open>
       We will take as the composition isomorphism from \<open>SPN r \<circ> SPN s\<close> to \<open>SPN (r \<star> s)\<close>
       the arrow of tabulations, induced by the identity \<open>r \<star> s\<close>, from the composite of
       the chosen tabulations of \<open>r\<close> and \<open>s\<close> to the chosen tabulation of \<open>r \<star> s\<close>.
       As this arrow of tabulations is induced by an identity, it is an equivalence map.
     \<close>
 
     interpretation cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                           \<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1\<close>
                           \<open>r \<star> s\<close> tab \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
                           \<open>r \<star> s\<close>
       using composable
       by unfold_locales auto
 
     lemma cmp_interpretation:
     shows "identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                           (r \<star> s) \<rho>\<sigma>.tab (tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0) (tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1)
                           (r \<star> s) tab (tab\<^sub>0 (r \<star> s)) (tab\<^sub>1 (r \<star> s))
                           (r \<star> s)"
       ..
 
     definition cmp
     where "cmp = cmp.chine"
 
     lemma cmp_props:
     shows "\<guillemotleft>cmp : src \<rho>\<sigma>.tab \<rightarrow> src tab\<guillemotright>"
     and "\<guillemotleft>cmp : cmp \<Rightarrow> cmp\<guillemotright>"
     and "equivalence_map cmp"
     and "tab\<^sub>0 (r \<star> s) \<star> cmp \<cong> tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0"
     and "tab\<^sub>1 (r \<star> s) \<star> cmp \<cong> tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1"
       using cmp_def cmp.leg0_uniquely_isomorphic(1) cmp.leg1_uniquely_isomorphic(1)
             isomorphic_symmetric cmp.chine_is_equivalence
       by auto
 
     lemma cmp_in_hom [intro]:
     shows "\<guillemotleft>cmp : src \<rho>\<sigma>.tab \<rightarrow> src tab\<guillemotright>"
     and "\<guillemotleft>cmp : cmp \<Rightarrow> cmp\<guillemotright>"
       using cmp_props by auto
 
     lemma cmp_simps [simp]:
     shows "arr cmp" and "ide cmp"
     and "src cmp = src \<rho>\<sigma>.tab" and "trg cmp = src tab"
     and "dom cmp = cmp" and "cod cmp = cmp"
       using cmp_props equivalence_map_is_ide by auto
 
     text \<open>
       Now we have to use the above properties of the underlying bicategory to
       exhibit the composition isomorphisms as actual arrows in \<open>Span(Maps(B))\<close>
       and to prove the required naturality and coherence conditions.
     \<close>
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp (infixr "\<odot>" 55)
 
     interpretation SPN: "functor" V Span.vcomp SPN
       using SPN_is_functor by simp
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
       using SPN_is_weak_arrow_of_homs by simp
 
     interpretation SPN_r_SPN_s: arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
       using composable Span.ide_char [of "SPN r \<circ> SPN s"] by simp
     interpretation SPN_r_SPN_s: identity_arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
       using composable Span.ide_char [of "SPN r \<circ> SPN s"]
       by (unfold_locales, simp)
     interpretation SPN_rs: arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
       using composable Span.arr_char r.base_simps(2) s.base_simps(2) by blast
     interpretation SPN_rs: identity_arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
       using composable Span.ide_char SPN.preserves_ide r.is_ide s.is_ide
       by (unfold_locales, simp)
 
     text \<open>
       The following are the legs (as arrows of \<open>Maps\<close>) of the spans \<open>SPN r\<close> and \<open>SPN s\<close>.
     \<close>
 
     definition R\<^sub>0 where "R\<^sub>0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>"
     definition R\<^sub>1 where "R\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
     definition S\<^sub>0 where "S\<^sub>0 = \<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>"
     definition S\<^sub>1 where "S\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 s\<rbrakk>\<rbrakk>"
 
     lemma span_legs_eq:
     shows "Leg0 (Dom (SPN r)) = R\<^sub>0" and "Leg1 (Dom (SPN r)) = R\<^sub>1"
     and "Leg0 (Dom (SPN s)) = S\<^sub>0" and "Leg1 (Dom (SPN s)) = S\<^sub>1"
       using SPN_def R\<^sub>0_def R\<^sub>1_def S\<^sub>0_def S\<^sub>1_def composable by auto
 
     lemma R\<^sub>0_in_hom [intro]:
     shows "Maps.in_hom R\<^sub>0 (Maps.MkIde (src r.s\<^sub>0)) (Maps.MkIde (src r))"
       by (simp add: Maps.MkArr_in_hom' R\<^sub>0_def)
 
     lemma R\<^sub>1_in_hom [intro]:
     shows "Maps.in_hom R\<^sub>1 (Maps.MkIde (src r.s\<^sub>0)) (Maps.MkIde (trg r))"
       by (simp add: Maps.MkArr_in_hom' R\<^sub>1_def)
 
     lemma S\<^sub>0_in_hom [intro]:
     shows "Maps.in_hom S\<^sub>0 (Maps.MkIde (src s.s\<^sub>0)) (Maps.MkIde (src s))"
       by (simp add: Maps.MkArr_in_hom' S\<^sub>0_def)
 
     lemma S\<^sub>1_in_hom [intro]:
     shows "Maps.in_hom S\<^sub>1 (Maps.MkIde (src s.s\<^sub>0)) (Maps.MkIde (trg s))"
       by (simp add: Maps.MkArr_in_hom' S\<^sub>1_def)
 
     lemma RS_simps [simp]:
     shows "Maps.arr R\<^sub>0" and "Maps.dom R\<^sub>0 = Maps.MkIde (src r.s\<^sub>0)"
     and "Maps.cod R\<^sub>0 = Maps.MkIde (src r)"
     and "Maps.Dom R\<^sub>0 = src r.s\<^sub>0" and "Maps.Cod R\<^sub>0 = src r"
     and "Maps.arr R\<^sub>1" and "Maps.dom R\<^sub>1 = Maps.MkIde (src r.s\<^sub>0)"
     and "Maps.cod R\<^sub>1 = Maps.MkIde (trg r)"
     and "Maps.Dom R\<^sub>1 = src r.s\<^sub>0" and "Maps.Cod R\<^sub>1 = trg r"
     and "Maps.arr S\<^sub>0" and "Maps.dom S\<^sub>0 = Maps.MkIde (src s.s\<^sub>0)"
     and "Maps.cod S\<^sub>0 = Maps.MkIde (src s)"
     and "Maps.Dom S\<^sub>0 = src s.s\<^sub>0" and "Maps.Cod S\<^sub>0 = src s"
     and "Maps.arr S\<^sub>1" and "Maps.dom S\<^sub>1 = Maps.MkIde (src s.s\<^sub>0)"
     and "Maps.cod S\<^sub>1 = Maps.MkIde (trg s)"
     and "Maps.Dom S\<^sub>1 = src s.s\<^sub>0" and "Maps.Cod S\<^sub>1 = trg s"
       using R\<^sub>0_in_hom R\<^sub>1_in_hom S\<^sub>0_in_hom S\<^sub>1_in_hom composable
       by (auto simp add: R\<^sub>0_def R\<^sub>1_def S\<^sub>0_def S\<^sub>1_def)
 
     text \<open>
       The apex of the composite span @{term "SPN r \<circ> SPN s"} (defined in terms of pullback)
       coincides with the apex of the composite tabulation \<open>\<rho>\<sigma>\<close> (defined using
       the chosen tabulation of \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s)\<close>).  We need this to be true in order
       to define the compositor of a pseudofunctor from the underlying bicategory \<open>B\<close>
       to \<open>Span(Maps(B))\<close>.  It is only true if we have carefully chosen pullbacks in \<open>Maps(B)\<close>
       in order to ensure the relationship with the chosen tabulations.
     \<close>
 
     lemma SPN_r_SPN_s_apex_eq:
     shows "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
     proof -
       have "obj (Maps.Cod SPN_r_SPN_s.leg0)"
         using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
       moreover have "obj (Maps.Dom SPN_r_SPN_s.leg0)"
         using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
       moreover have "SPN_r_SPN_s.leg0 \<noteq> Maps.Null"
         using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
       moreover have "Maps.Dom SPN_r_SPN_s.leg0 = src \<rho>\<sigma>.tab"
       proof -
         interpret REP_S\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP S\<^sub>1\<close>
           using Maps.REP_in_Map Maps.arr_char Maps.in_HomD S\<^sub>1_def
           apply unfold_locales
           by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
         interpret REP_R\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP R\<^sub>0\<close>
           using Maps.REP_in_Map Maps.arr_char Maps.in_HomD R\<^sub>0_def
           apply unfold_locales
           by (meson Maps.REP_in_hhom(2) R\<^sub>0_in_hom)
         have "Maps.Dom SPN_r_SPN_s.leg0 = Maps.Dom (S\<^sub>0 \<odot> Maps.PRJ\<^sub>0 R\<^sub>0 S\<^sub>1)"
           using composable Span.hcomp_def S\<^sub>0_def R\<^sub>0_def S\<^sub>1_def by simp
         also have "... = Maps.Dom \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>"
         proof -
           have "is_left_adjoint (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
           proof -
             have "ide ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
             proof -
               have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
                 using REP_R\<^sub>0.is_map REP_S\<^sub>1.is_map left_adjoint_is_ide R\<^sub>0_def S\<^sub>1_def
                 by (metis (no_types, lifting) Maps.REP_CLS REP_R\<^sub>0.antipar(2)
                     isomorphic_implies_hpar(4) composable r.leg0_simps(3)
                     r.satisfies_T0 s.leg1_is_map s.leg1_simps(3) s.leg1_simps(4))
               thus ?thesis by simp
             qed
             thus ?thesis by simp
           qed
           moreover have "Maps.Dom (S\<^sub>0 \<odot> \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>) =
                          src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
           proof -
             have "Maps.arr (\<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk>)"
               using Maps.CLS_in_hom Maps.prj0_simps(1) Maps.PRJ\<^sub>0_def composable by fastforce
             moreover have "Maps.Dom S\<^sub>0 = Maps.Cod \<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk>"
             proof -
               have "Maps.Cod \<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk> =
                     trg (prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0))"
                 by simp
               also have "... = src (Maps.REP S\<^sub>1)"
               proof -
                 have "ide (Maps.REP S\<^sub>1)"
                   by simp
                 moreover have "is_left_adjoint (Maps.REP R\<^sub>0)"
                   by auto
                 moreover have "trg (Maps.REP S\<^sub>1) = trg (Maps.REP R\<^sub>0)"
                   by (simp add: composable)
                 ultimately show ?thesis
                   using S\<^sub>1_def Maps.REP_CLS r.leg0_is_map s.leg1_is_map by simp
               qed
               also have "... = src (tab\<^sub>0 s)"
                 using tab\<^sub>0_in_hom(1) by simp
               also have "... = Maps.Dom S\<^sub>0"
                 using S\<^sub>0_def by simp
               finally show ?thesis by simp
             qed
             ultimately have
               "Maps.Dom (S\<^sub>0 \<odot> \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>) =
                Maps.Dom \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>"
               using Maps.CLS_in_hom by simp
             thus ?thesis by simp
           qed
           ultimately show ?thesis
             using Maps.PRJ\<^sub>0_def composable Maps.Dom.simps(1) RS_simps(1) RS_simps(16)
                   RS_simps(18) RS_simps(3)
             by presburger
         qed
         also have "... = src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
           by simp
         finally have
           "Maps.Dom SPN_r_SPN_s.leg0 = src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
           by simp
         also have "... = src (tab\<^sub>0 (r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1))"
         proof -
           interpret r\<^sub>0's\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1\<close>
             using composable by (unfold_locales, simp)
           have "(Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1 \<cong> r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1"
           proof -
             have "(Maps.REP R\<^sub>0)\<^sup>* \<cong> r.s\<^sub>0\<^sup>*"
             proof -
               have 1: "adjoint_pair (Maps.REP R\<^sub>0) (Maps.REP R\<^sub>0)\<^sup>*"
                 using REP_R\<^sub>0.is_map left_adjoint_extends_to_adjoint_pair by blast
               moreover have "adjoint_pair r.s\<^sub>0 (Maps.REP R\<^sub>0)\<^sup>*"
               proof -
                 have "Maps.REP R\<^sub>0 \<cong> r.s\<^sub>0"
                   unfolding R\<^sub>0_def
                   using Maps.REP_CLS r.leg0_is_map composable by force
                 thus ?thesis
                   using 1 adjoint_pair_preserved_by_iso isomorphic_def
                         REP_R\<^sub>0.triangle_in_hom(4) REP_R\<^sub>0.triangle_right'
                   by auto
               qed
               ultimately show ?thesis
                 using r.leg0_is_map left_adjoint_determines_right_up_to_iso
                       left_adjoint_extends_to_adjoint_pair
                 by auto
             qed
             moreover have "Maps.REP S\<^sub>1 \<cong> s.s\<^sub>1"
               unfolding S\<^sub>1_def
               using Maps.REP_CLS s.leg1_is_map composable by force
             moreover have "\<exists>a. a \<cong> (tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<and> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1 \<cong> a"
               using calculation composable isomorphic_implies_hpar(3)
                     hcomp_ide_isomorphic hcomp_isomorphic_ide [of "(Maps.REP R\<^sub>0)\<^sup>*" "r.s\<^sub>0\<^sup>*" s.s\<^sub>1]
               by auto
             ultimately show ?thesis
               using isomorphic_transitive by blast
           qed
           thus ?thesis
             using r\<^sub>0's\<^sub>1.isomorphic_implies_same_tab isomorphic_symmetric by metis
         qed
         also have "... = src \<rho>\<sigma>.tab"
           using VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C composable Span.hcomp_def \<rho>\<sigma>.tab_simps(2) by auto
         finally show ?thesis by simp
       qed
       ultimately show ?thesis
         using composable Maps.arr_char Maps.dom_char SPN_r_SPN_s.dom.apex_def
         apply auto
         by (metis (no_types, lifting) Maps.not_arr_null SPN_r_SPN_s.chine_eq_apex
             SPN_r_SPN_s.chine_simps(1))
     qed
 
     text \<open>
       We will be taking the arrow @{term "CLS cmp"} of \<open>Maps\<close> as the composition isomorphism from
       @{term "SPN r \<circ> SPN s"} to @{term "SPN (r \<star> s)"}.  The following result shows that it
       has the right domain and codomain for that purpose.
     \<close>
 
     lemma iso_class_cmp_in_hom:
     shows "Maps.in_hom (Maps.MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
                        SPN_r_SPN_s.apex SPN_rs.apex"
     and "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex"
     proof -
       show "Maps.in_hom (Maps.MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
                         SPN_r_SPN_s.apex SPN_rs.apex"
       proof -
         have "obj (src \<rho>\<sigma>.tab)"
           using obj_src \<rho>\<sigma>.tab_in_hom by blast
         moreover have "obj (src tab)"
           using obj_src by simp
         moreover have "\<lbrakk>cmp\<rbrakk> \<in> Maps.Hom (src \<rho>\<sigma>.tab) (src tab)"
           by (metis (mono_tags, lifting) cmp.is_map cmp_def cmp_props(1) mem_Collect_eq)
         moreover have "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
           using SPN_r_SPN_s_apex_eq by simp
         moreover have "SPN_rs.apex = Maps.MkIde (src tab)"
           using SPN_def composable SPN_rs.cod.apex_def Maps.arr_char Maps.dom_char
                 SPN_rs.dom.leg_simps(1)
           by fastforce
         ultimately show ?thesis
           using Maps.MkArr_in_hom by simp
       qed
       thus "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex" by simp
     qed
 
     interpretation r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
                             V H \<a> \<i> src trg \<open>(Maps.REP R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP S\<^sub>1\<close>
     proof
       show "ide (Maps.REP S\<^sub>1)"
         using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
         by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
       show "ide (Maps.REP R\<^sub>0)\<^sup>*"
         using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
               Maps.REP_in_hhom(2) R\<^sub>0_in_hom by auto
       show "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
         using Maps.REP_in_hhom(2) R\<^sub>0_in_hom composable by auto
     qed
 
     interpretation R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
       by (unfold_locales, simp add: composable)
 
     lemma prj_tab_agreement:
     shows "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
     and "\<rho>\<sigma>.p\<^sub>0 \<cong> prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
     and "\<rho>\<sigma>.p\<^sub>1 \<cong> prj\<^sub>1 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
     proof -
       show 1: "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
       proof -
         have "(tab\<^sub>0 r)\<^sup>* \<cong> (Maps.REP R\<^sub>0)\<^sup>*"
           using Maps.REP_CLS isomorphic_symmetric R\<^sub>0_def composable r.satisfies_T0
                 isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint
           by fastforce
         moreover have "tab\<^sub>1 s \<cong> Maps.REP S\<^sub>1"
           by (metis Maps.REP_CLS isomorphic_symmetric S\<^sub>1_def s.leg1_is_map s.leg1_simps(3-4))
         moreover have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (tab\<^sub>1 s)"
           using composable r.T0.antipar right_adjoint_simps(2) by fastforce
         ultimately show ?thesis
           using hcomp_isomorphic_ide [of "(tab\<^sub>0 r)\<^sup>*" "(Maps.REP R\<^sub>0)\<^sup>*" "tab\<^sub>1 s"]
                 hcomp_ide_isomorphic isomorphic_transitive composable
           by auto
       qed
       show "\<rho>\<sigma>.p\<^sub>0 \<cong> tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
         using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
       show "\<rho>\<sigma>.p\<^sub>1 \<cong> tab\<^sub>1 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
         using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
     qed
 
     lemma chine_hcomp_SPN_SPN:
     shows "Span.chine_hcomp (SPN r) (SPN s) = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
     proof -
       have "Span.chine_hcomp (SPN r) (SPN s) =
             Maps.MkIde (src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)))"
         using Span.chine_hcomp_ide_ide [of "SPN r" "SPN s"] composable
               Maps.pbdom_def Maps.PRJ\<^sub>0_def Maps.CLS_in_hom Maps.dom_char R\<^sub>0_def S\<^sub>1_def
         apply simp
         using Maps.prj0_simps(1) RS_simps(1) RS_simps(16) RS_simps(18) RS_simps(3)
         by presburger
       also have "... = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
         using prj_tab_agreement isomorphic_implies_hpar(3) by force
       finally show ?thesis by simp
     qed
 
   end
 
   text \<open>
     The development above focused on two specific composable 1-cells in bicategory \<open>B\<close>.
     Here we reformulate those results as statements about the entire bicategory.
   \<close>
 
   context bicategory_of_spans
   begin
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp (infixr "\<odot>" 55)
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation SPN: "functor" V Span.vcomp SPN
       using SPN_is_functor by simp
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
       using SPN_is_weak_arrow_of_homs by simp
 
     interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
                                 SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
       ..
     interpretation SPNoH: composite_functor VV.comp V
                             Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
       ..
 
     text \<open>
       Given arbitrary composable 1-cells \<open>r\<close> and \<open>s\<close>, obtain an arrow of spans in \<open>Maps\<close>
       having the isomorphism class of \<open>rs.cmp\<close> as its chine.
     \<close>
 
     definition CMP
     where "CMP r s \<equiv>
            \<lparr>Chn = \<lbrakk>\<lbrakk>two_composable_identities_in_bicategory_of_spans.cmp V H \<a> \<i> src trg r s\<rbrakk>\<rbrakk>,
             Dom = Dom (SPN r \<circ> SPN s), Cod = Dom (SPN (r \<star> s))\<rparr>"
 
     lemma compositor_in_hom [intro]:
     assumes "ide r" and "ide s" and "src r = trg s"
     shows "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
     and "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
     proof -
       have rs: "VV.ide (r, s)"
         using assms VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
       interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
         using rs VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by unfold_locales auto
       interpret cmp: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                      \<open>r \<star> s\<close> rs.\<rho>\<sigma>.tab \<open>tab\<^sub>0 s \<star> rs.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 r \<star> rs.\<rho>\<sigma>.p\<^sub>1\<close>
                      \<open>r \<star> s\<close> rs.tab \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
                      \<open>r \<star> s\<close>
         by unfold_locales auto
       have "rs.cmp = cmp.chine"
         using rs.cmp_def by simp
 
       interpret SPN_r_SPN_s: arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
         using rs.composable Span.ide_char [of "SPN r \<circ> SPN s"] by simp
       interpret SPN_r_SPN_s: identity_arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
         using rs.composable Span.ide_char [of "SPN r \<circ> SPN s"]
         by (unfold_locales, simp)
       interpret SPN_rs: arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
         using Span.arr_char rs.is_ide SPN.preserves_arr by blast
       interpret SPN_rs: identity_arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
         using Span.ide_char rs.is_ide SPN.preserves_ide
         by (unfold_locales, simp)
 
       interpret Dom: span_in_category Maps.comp \<open>Dom (CMP r s)\<close>
         by (unfold_locales, simp add: CMP_def)
       interpret Cod: span_in_category Maps.comp \<open>Cod (CMP r s)\<close>
       proof -
         (* TODO: I don't understand what makes this so difficult. *)
         have "\<guillemotleft>tab\<^sub>0 (r \<star> s) : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> src s\<guillemotright> \<and> is_left_adjoint (tab\<^sub>0 (r \<star> s)) \<and>
               \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> = \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk>"
           by simp
         hence "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> src s\<guillemotright> \<and> is_left_adjoint f \<and> \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> = \<lbrakk>f\<rbrakk>"
           by blast
         moreover have "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> trg r\<guillemotright> \<and> is_left_adjoint f \<and>
                            \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> = \<lbrakk>f\<rbrakk>"
           by (metis rs.base_simps(2) rs.leg1_in_hom(1) rs.leg1_is_map trg_hcomp)
         ultimately show "span_in_category Maps.comp (Cod (CMP r s))"
           using assms Maps.arr_char Maps.dom_char CMP_def
           by unfold_locales auto
       qed
 
       interpret r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
                          V H \<a> \<i> src trg \<open>(Maps.REP rs.R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP rs.S\<^sub>1\<close>
       proof
         show "ide (Maps.REP rs.S\<^sub>1)"
           using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
           by (meson Maps.REP_in_hhom(2) rs.S\<^sub>1_in_hom)
         show "ide (Maps.REP rs.R\<^sub>0)\<^sup>*"
           using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
                 Maps.REP_in_hhom(2) rs.R\<^sub>0_in_hom by auto
         show "src (Maps.REP rs.R\<^sub>0)\<^sup>* = trg (Maps.REP rs.S\<^sub>1)"
           using Maps.REP_in_hhom(2) rs.R\<^sub>0_in_hom rs.composable by auto
       qed
 
       interpret R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
         by (unfold_locales, simp add: rs.composable)
 
       text \<open>
         Here we obtain explicit formulas for the legs and apex of \<open>SPN_r_SPN_s\<close> and \<open>SPN_rs\<close>.
       \<close>
 
       have SPN_r_SPN_s_leg0_eq:
              "SPN_r_SPN_s.leg0 = Maps.comp rs.S\<^sub>0 (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1)"
         using rs.composable Span.hcomp_def rs.S\<^sub>0_def rs.R\<^sub>0_def rs.S\<^sub>1_def by simp
       have SPN_r_SPN_s_leg1_eq:
              "SPN_r_SPN_s.leg1 = Maps.comp rs.R\<^sub>1 (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1)"
         using rs.composable Span.hcomp_def rs.R\<^sub>1_def rs.R\<^sub>0_def rs.S\<^sub>1_def by simp
       have "SPN_r_SPN_s.apex = Maps.MkIde (src rs.\<rho>\<sigma>.tab)"
         using rs.SPN_r_SPN_s_apex_eq by auto
 
       have SPN_rs_leg0_eq: "SPN_rs.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk>\<rbrakk>"
         unfolding SPN_def using rs by simp
       have SPN_rs_leg1_eq: "SPN_rs.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk>\<rbrakk>"
         unfolding SPN_def using rs by simp
       have "SPN_rs.apex = Maps.MkIde (src (tab_of_ide (r \<star> s)))"
         using SPN_rs.dom.apex_def Maps.dom_char SPN_rs_leg0_eq SPN_rs.dom.leg_simps(1)
         by simp
 
       text \<open>
         The composition isomorphism @{term "CMP r s"} is an arrow of spans in \<open>Maps(B)\<close>.
       \<close>
 
       interpret arrow_of_spans Maps.comp \<open>CMP r s\<close>
       proof
         show 1: "Maps.in_hom (Chn (CMP r s)) Dom.apex Cod.apex"
           using rs.iso_class_cmp_in_hom rs.composable CMP_def by simp
         show "Cod.leg0 \<odot> Chn (CMP r s) = Dom.leg0"
         proof (intro Maps.arr_eqI)
           show 2: "Maps.seq Cod.leg0 (Chn (CMP r s))"
             using 1 Maps.dom_char Maps.cod_char by blast
           show 3: "Maps.arr Dom.leg0" by simp
           show "Maps.Dom (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Dom Dom.leg0"
             using 1 2 Maps.dom_char Maps.cod_char Maps.comp_char
                   Dom.leg_in_hom Maps.in_hom_char Maps.seq_char
             by auto
           show "Maps.Cod (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Cod Dom.leg0"
             using 2 3 Maps.comp_char [of Cod.leg0 "Chn (CMP r s)"]
                   Dom.leg_simps Dom.apex_def Maps.dom_char SPN_r_SPN_s_leg0_eq
                   Maps.comp_char [of rs.S\<^sub>0 "Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1"] CMP_def
             by simp
           show "Maps.Map (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Map Dom.leg0"
           proof -
             have "Maps.Map (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Comp \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk>"
               using 1 2 Maps.dom_char Maps.cod_char
                     Maps.comp_char [of Cod.leg0 "Chn (CMP r s)"] CMP_def
               by simp
             also have "... = Maps.Comp \<lbrakk>tab\<^sub>0 s\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
             proof -
               have "Maps.Comp \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk> = \<lbrakk>tab\<^sub>0 (r \<star> s) \<star> rs.cmp\<rbrakk>"
                 using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp cmp.is_map rs.cmp_def
                 by auto
               also have "... = Maps.Comp \<lbrakk>tab\<^sub>0 s\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
                 using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp iso_class_eqI rs.cmp_props(4)
                 by auto
               finally show ?thesis by simp
             qed
             also have "... = Maps.Map Dom.leg0"
             proof -
               have "Maps.seq rs.S\<^sub>0 (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1)"
                 by (intro Maps.seqI, simp_all add: rs.composable)
               moreover have "\<lbrakk>prj\<^sub>0 (Maps.REP rs.S\<^sub>1) (Maps.REP rs.R\<^sub>0)\<rbrakk> = \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
                 using "rs.prj_tab_agreement" iso_class_eqI by auto
               moreover have "Maps.Dom (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1) = src rs.\<rho>\<sigma>.p\<^sub>0"
                 using rs.prj_tab_agreement Maps.PRJ\<^sub>0_def rs.composable
                       isomorphic_implies_hpar(3)
                 by auto
               ultimately show ?thesis
                 using SPN_r_SPN_s_leg0_eq Maps.comp_char [of rs.S\<^sub>0 "Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1"]
                       rs.S\<^sub>0_def Maps.PRJ\<^sub>0_def rs.composable CMP_def
                 by simp
             qed
             finally show ?thesis by simp
           qed
         qed
         show "Cod.leg1 \<odot> Chn (CMP r s) = Dom.leg1"
         proof (intro Maps.arr_eqI)
           show 2: "Maps.seq Cod.leg1 (Chn (CMP r s))"
             using 1 Maps.dom_char Maps.cod_char by blast
           show 3: "Maps.arr Dom.leg1" by simp
           show "Maps.Dom (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Dom Dom.leg1"
             using 1 2 Maps.dom_char Maps.cod_char Maps.comp_char
                   Dom.leg_in_hom Maps.in_hom_char Maps.seq_char
             by auto
           show "Maps.Cod (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Cod Dom.leg1"
             using 2 3 Maps.comp_char [of Cod.leg1 "Chn (CMP r s)"]
                   Dom.apex_def Maps.dom_char SPN_r_SPN_s_leg1_eq
                   Maps.comp_char [of rs.R\<^sub>1 "Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1"] CMP_def
             by simp
           show "Maps.Map (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Map Dom.leg1"
           proof -
             have "Maps.Map (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Comp \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk>"
               using 1 2 Maps.dom_char Maps.cod_char
                     Maps.comp_char [of Cod.leg1 "Chn (CMP r s)"] CMP_def
               by simp
             also have "... = Maps.Comp \<lbrakk>tab\<^sub>1 r\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
             proof -
               have "Maps.Comp \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk> = \<lbrakk>tab\<^sub>1 (r \<star> s) \<star> rs.cmp\<rbrakk>"
                 using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp cmp.is_map rs.cmp_def
                 by auto
               also have "... = Maps.Comp \<lbrakk>tab\<^sub>1 r\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
                 using Maps.Comp_eq_iso_class_memb
                       Maps.CLS_hcomp [of "tab\<^sub>1 r" rs.\<rho>\<sigma>.p\<^sub>1] iso_class_eqI rs.cmp_props(5)
                 by auto
               finally show ?thesis by simp
             qed
             also have "... = Maps.Map Dom.leg1"
             proof -
               have "Maps.seq rs.R\<^sub>1 (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1)"
                 by (intro Maps.seqI, simp_all add: rs.composable)
               moreover have "\<lbrakk>prj\<^sub>1 (Maps.REP rs.S\<^sub>1) (Maps.REP rs.R\<^sub>0)\<rbrakk> = \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
                 using rs.prj_tab_agreement iso_class_eqI by auto
               moreover have "Maps.Dom (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1) = src rs.\<rho>\<sigma>.p\<^sub>1"
                 using rs.prj_tab_agreement Maps.PRJ\<^sub>1_def rs.composable
                       isomorphic_implies_hpar(3)
                 by auto
               ultimately show ?thesis
                 using SPN_r_SPN_s_leg1_eq Maps.comp_char [of rs.R\<^sub>1 "Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1"]
                       rs.R\<^sub>1_def Maps.PRJ\<^sub>1_def rs.composable CMP_def
                 by simp
             qed
             finally show ?thesis by simp
             (*
              * Very simple, right?  Yeah, once you sort through the notational morass and
              * figure out what equals what.
              *)
           qed
         qed
       qed
       show "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
           using Span.arr_char arrow_of_spans_axioms Span.dom_char Span.cod_char
                 CMP_def SPN.FF_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C rs.composable
           by auto
       thus "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
         using assms VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.in_hom_char\<^sub>S\<^sub>b\<^sub>C SPN.FF_def
         apply (intro Span.in_hhomI)
           apply auto
         using Span.src_dom [of "CMP r s"] Span.trg_dom [of "CMP r s"]
          apply (elim Span.in_homE)
          apply auto
         using Span.src_dom [of "CMP r s"] Span.trg_dom [of "CMP r s"]
         apply (elim Span.in_homE)
         by auto
     qed
 
     lemma compositor_simps [simp]:
     assumes "ide r" and "ide s" and "src r = trg s"
     shows "Span.arr (CMP r s)"
     and "Span.src (CMP r s) = SPN.map\<^sub>0 (src s)" and "Span.trg (CMP r s) = SPN.map\<^sub>0 (trg r)"
     and "Span.dom (CMP r s) = HoSPN_SPN.map (r, s)"
     and "Span.cod (CMP r s) = SPNoH.map (r, s)"
       using assms compositor_in_hom [of r s] by auto
 
     lemma compositor_is_iso:
     assumes "ide r" and "ide s" and "src r = trg s"
     shows "Span.iso (CMP r s)"
     proof -
       interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
         using assms by unfold_locales auto
       have "Span.arr (CMP r s)"
         using assms compositor_in_hom by blast
       moreover have "Maps.iso \<lbrakk>\<lbrakk>rs.cmp\<rbrakk>\<rbrakk>"
         using assms Maps.iso_char'
         by (metis (mono_tags, lifting) Maps.CLS_in_hom Maps.Map.simps(1) Maps.in_homE
             equivalence_is_left_adjoint ide_in_iso_class rs.cmp_props(3) rs.cmp_simps(2))
       ultimately show ?thesis
         unfolding CMP_def
         using assms Span.iso_char by simp
     qed
 
     interpretation \<Xi>: transformation_by_components VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
     proof
       fix rs
       assume rs: "VV.ide rs"
       let ?r = "fst rs"
       let ?s = "snd rs"
       show "Span.in_hom (CMP ?r ?s) (HoSPN_SPN.map rs) (SPNoH.map rs)"
         using rs compositor_in_hom [of ?r ?s] VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
       next
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
       let ?\<mu> = "fst \<mu>\<nu>"
       let ?\<nu> = "snd \<mu>\<nu>"
       show "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu> =
             SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
       proof -
         let ?LHS = "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu>"
         let ?RHS = "SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
         have LHS:
           "Span.in_hom ?LHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
         proof
           show "Span.in_hom (HoSPN_SPN.map \<mu>\<nu>) (HoSPN_SPN.map (VV.dom \<mu>\<nu>))
                             (HoSPN_SPN.map (VV.cod \<mu>\<nu>))"
             using \<mu>\<nu> by blast
           show "Span.in_hom (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)))
                             (HoSPN_SPN.map (VV.cod \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
             using \<mu>\<nu> VV.cod_simp by (auto simp add: VV.arr_char\<^sub>S\<^sub>b\<^sub>C)
         qed
         have RHS:
           "Span.in_hom ?RHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
           using \<mu>\<nu> VV.dom_simp VV.cod_simp by (auto simp add: VV.arr_char\<^sub>S\<^sub>b\<^sub>C)
         show "?LHS = ?RHS"
         proof (intro Span.arr_eqI)
           show "Span.par ?LHS ?RHS"
             apply (intro conjI)
             using LHS RHS apply auto[2]
           proof -
             show "Span.dom ?LHS = Span.dom ?RHS"
             proof -
               have "Span.dom ?LHS = HoSPN_SPN.map (VV.dom \<mu>\<nu>)"
                 using LHS by auto
               also have "... = Span.dom ?RHS"
                 using RHS by auto
               finally show ?thesis by simp
             qed
             show "Span.cod ?LHS = Span.cod ?RHS"
             proof -
               have "Span.cod ?LHS = SPNoH.map (VV.cod \<mu>\<nu>)"
                 using LHS by auto
               also have "... = Span.cod ?RHS"
                 using RHS by auto
               finally show ?thesis by simp
             qed
           qed
           show "Chn ?LHS = Chn ?RHS"
           proof -
             interpret dom_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                                  \<open>dom ?\<mu>\<close> \<open>dom ?\<nu>\<close>
               using \<mu>\<nu> VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by unfold_locales auto
             interpret cod_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                                  \<open>cod ?\<mu>\<close> \<open>cod ?\<nu>\<close>
               using \<mu>\<nu> VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by unfold_locales auto
             interpret \<mu>_\<nu>: horizontal_composite_of_arrows_of_tabulations_in_maps
                              V H \<a> \<i> src trg
                              \<open>dom ?\<mu>\<close> \<open>tab_of_ide (dom ?\<mu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>)\<close>
                              \<open>dom ?\<nu>\<close> \<open>tab_of_ide (dom ?\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<nu>)\<close>
                              \<open>cod ?\<mu>\<close> \<open>tab_of_ide (cod ?\<mu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>)\<close>
                              \<open>cod ?\<nu>\<close> \<open>tab_of_ide (cod ?\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<nu>)\<close>
                              ?\<mu> ?\<nu>
               using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C by unfold_locales auto
 
             let ?\<mu>\<nu> = "?\<mu> \<star> ?\<nu>"
             interpret dom_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom ?\<mu>\<nu>\<close>
               using \<mu>\<nu> by (unfold_locales, simp)
             interpret cod_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod ?\<mu>\<nu>\<close>
               using \<mu>\<nu> by (unfold_locales, simp)
             interpret \<mu>\<nu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                             \<open>dom ?\<mu>\<nu>\<close> \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
                             \<open>cod ?\<mu>\<nu>\<close> \<open>tab_of_ide (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
                             ?\<mu>\<nu>
               using \<mu>\<nu> by unfold_locales auto
 
             have Chn_LHS_eq:
               "Chn ?LHS = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
             proof -
               have "Chn ?LHS = Chn (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>))) \<odot>
                                  Chn (HoSPN_SPN.map \<mu>\<nu>)"
                 using \<mu>\<nu> LHS Span.Chn_vcomp by blast
               also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Chn (HoSPN_SPN.map \<mu>\<nu>)"
                 using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.cod_char\<^sub>S\<^sub>b\<^sub>C CMP_def by simp
               also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot>
                                  Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
                 using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C SPN.FF_def Span.hcomp_def by simp
               finally show ?thesis by blast
             qed
             have Chn_RHS_eq:
                "Chn ?RHS = Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                       (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                       \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
                            Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                                       \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
             proof -
               have "Chn ?RHS = Chn (SPN (?\<mu> \<star> ?\<nu>)) \<odot>
                                Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                                           \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                 using \<mu>\<nu> RHS Span.vcomp_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C CMP_def Span.arr_char Span.not_arr_Null
                       VV.dom_simp
                 by auto
               moreover have "Chn (SPN (?\<mu> \<star> ?\<nu>)) =
                              Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                         (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                         \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
               proof -
                 have "Chn (SPN (?\<mu> \<star> ?\<nu>)) =
                       Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                  (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                  \<lbrakk>spn ?\<mu>\<nu>\<rbrakk>"
                   using \<mu>\<nu> SPN_def by simp
                 also have "... = Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                             (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                             \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
                   using spn_def by simp
                 finally show ?thesis by simp
               qed
               ultimately show ?thesis by simp
             qed
 
             let ?Chn_LHS =
                 "Maps.MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
                    \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<odot>
                  Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"
             let ?Chn_RHS =
                 "Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                    \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
                  Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                    \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
 
             have "?Chn_LHS = ?Chn_RHS"
             proof (intro Maps.arr_eqI)
               interpret LHS: arrow_of_spans Maps.comp ?LHS
                 using LHS Span.arr_char by auto
               interpret RHS: arrow_of_spans Maps.comp ?RHS
                 using RHS Span.arr_char by auto
               show 1: "Maps.arr ?Chn_LHS"
                 using LHS.chine_in_hom Chn_LHS_eq by auto
               show 2: "Maps.arr ?Chn_RHS"
                 using RHS.chine_in_hom Chn_RHS_eq by auto
               text \<open>
                 Here is where we use \<open>dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN\<close>,
                 which depends on our having chosen the ``right'' pullbacks for \<open>Maps(B)\<close>.
                 The map \<open>Chn_LHS\<close> has as its domain the apex of the
                 horizontal composite of the components of @{term "VV.dom \<mu>\<nu>"},
                 whereas \<open>Chn_RHS\<close> has as its
                 domain the apex of the chosen tabulation of \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>.
                 We need these to be equal in order for \<open>Chn_LHS\<close> and \<open>Chn_RHS\<close> to be equal.
               \<close>
               show "Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS"
               proof -
                 have "Maps.Dom ?Chn_LHS = Maps.Dom (Maps.dom ?Chn_LHS)"
                    using \<mu>\<nu> 1 Maps.Dom_dom by presburger
                 also have
                   "... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
                 proof -
                   have "... = Maps.Dom (Maps.dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
                     using 1 Maps.seq_char Maps.Dom_comp by auto
                   also have "... = Maps.Dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
                                                         (Leg1 (Dom (SPN ?\<nu>))))"
                     using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C Span.chine_hcomp_in_hom [of "SPN ?\<nu>" "SPN ?\<mu>"]
                     by auto
                   also have "... = Maps.Dom (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
                                                                   (Leg1 (Dom (SPN ?\<nu>)))))"
                   proof -
                     have "Maps.cospan (Leg0 (Dom (SPN (fst \<mu>\<nu>)))) (Leg1 (Dom (SPN (snd \<mu>\<nu>))))"
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C SPN_in_hom Span.arr_char Span.dom_char SPN_def
                             Maps.CLS_in_hom Maps.arr_char Maps.cod_char dom_\<mu>_\<nu>.composable
                             dom_\<mu>_\<nu>.RS_simps(16) dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.RS_simps(1)
                             dom_\<mu>_\<nu>.R\<^sub>0_def Maps.pbdom_in_hom
                       by simp
                     thus ?thesis
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C Maps.pbdom_in_hom by simp
                   qed
                   also have "... = Maps.Dom
                                      (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN (dom ?\<mu>))))
                                                            (Leg1 (Dom (SPN (dom ?\<nu>))))))"
                     using \<mu>\<nu> SPN_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
                   also have "... = Maps.Dom
                                      (Maps.dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>))))"
                     using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C ide_dom
                     by (simp add: Span.chine_hcomp_ide_ide)
                   also have "... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
                     using Maps.Dom_dom Maps.in_homE SPN.preserves_reflects_arr SPN.preserves_src
                           SPN.preserves_trg Span.chine_hcomp_in_hom dom_\<mu>_\<nu>.composable
                           dom_\<mu>_\<nu>.r.base_simps(2) dom_\<mu>_\<nu>.s.base_simps(2)
                     by (metis (no_types, lifting))
                   finally show ?thesis by simp
                 qed
                 also have "... = src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
                   using "dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN" by simp
                 also have "... = Maps.Dom ?Chn_RHS"
                   using 2 Maps.seq_char Maps.Dom_comp by auto
                 finally show ?thesis by simp
               qed
               show "Maps.Cod ?Chn_LHS = Maps.Cod ?Chn_RHS"
               proof -
                 have "Maps.Cod ?Chn_LHS = src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>))"
                   using \<mu>\<nu> 1 VV.arr_char\<^sub>S\<^sub>b\<^sub>C Maps.seq_char by auto
                 also have "... = src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))"
                   using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C cod_\<mu>\<nu>.tab_simps(2) by auto
                 also have "... = Maps.Cod ?Chn_RHS"
                   by (metis (no_types, lifting) "2" Maps.Cod.simps(1) Maps.Cod_comp Maps.seq_char)
                 finally show ?thesis by simp
               qed
               show "Maps.Map ?Chn_LHS = Maps.Map ?Chn_RHS"
               proof -
                 have RHS: "Maps.Map ?Chn_RHS = iso_class (\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp)"
                 proof -
                   have "Maps.Map ?Chn_RHS = Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                     using \<mu>\<nu> 2 VV.arr_char\<^sub>S\<^sub>b\<^sub>C Maps.Map_comp
                           Maps.comp_char
                             [of "Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                             (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                             \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
                                 "Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
                                             (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                                             \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"]
                     by simp
                   also have "... = \<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk>"
                   proof -
                     have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
                           Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))"
                     proof -
                       have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
                             Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.tab) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))"
                         using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C dom_\<mu>_\<nu>.cmp_props(1-3)
                         by (metis (mono_tags, lifting) equivalence_is_left_adjoint mem_Collect_eq)
                       thus ?thesis
                         using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C dom_\<mu>\<nu>.tab_simps(2) by simp
                     qed
                     moreover have "\<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<in>
                                    Maps.Hom (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                             (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<mu>\<nu>.chine_in_hom \<mu>\<nu>.is_map by auto
                     moreover have
                       "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<in> Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                     proof
                       show "is_iso_class \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                         using is_iso_classI by simp
                       show "is_iso_class \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
                         using is_iso_classI by simp
                       show "dom_\<mu>_\<nu>.cmp \<in> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                         using ide_in_iso_class [of dom_\<mu>_\<nu>.cmp] by simp
                       show "\<mu>\<nu>.chine \<in> \<lbrakk>\<mu>\<nu>.chine\<rbrakk>" 
                         using ide_in_iso_class by simp
                       show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> \<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp"
                         using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<mu>\<nu>.chine_simps dom_\<mu>_\<nu>.cmp_simps dom_\<mu>\<nu>.tab_simps(2)
                               isomorphic_reflexive
                         by auto
                     qed
                     ultimately show ?thesis
                       using \<mu>\<nu> dom_\<mu>_\<nu>.cmp_props \<mu>\<nu>.chine_in_hom \<mu>\<nu>.chine_is_induced_map
                             Maps.Comp_eq_iso_class_memb
                       by blast
                   qed
                   finally show ?thesis by simp
                 qed
 
                 have LHS: "Maps.Map ?Chn_LHS = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
                 proof -
                   have "Maps.Map ?Chn_LHS =
                            Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
                                      (Maps.Map
                                        (Maps.tuple (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
                                                    (Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
                                                    (Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
                                                    (Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))))"
                   proof -
                     have "Maps.Map ?Chn_LHS =
                           Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
                                     (Maps.Map (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
                       using \<mu>\<nu> 1 VV.arr_char\<^sub>S\<^sub>b\<^sub>C Maps.Map_comp cod_\<mu>\<nu>.tab_simps(2)
                             Maps.comp_char
                               [of "Maps.MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
                                               (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
                                               \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
                                   "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"]
                       by simp
                     moreover have "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>) =
                                    Maps.tuple
                                      (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
                                       (Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
                                       (Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
                                      (Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))"
                     proof -
                       have "Maps.PRJ\<^sub>0
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                             \<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<and>
                             Maps.PRJ\<^sub>1
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                             \<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
                       proof -
                         interpret X: identity_in_bicategory_of_spans V H \<a> \<i> src trg
                                        \<open>(tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)\<close>
                           using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                           by (unfold_locales, simp)
                         have "Maps.PRJ\<^sub>0
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                               \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
                                                            \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
                                       Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
                                                            \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
                           unfolding Maps.PRJ\<^sub>0_def
                           using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
                                 dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
                                 dom_\<mu>_\<nu>.S\<^sub>1_def
                           by auto
                         moreover
                         have "Maps.PRJ\<^sub>1
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                               \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
                                                            \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
                                      Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
                                                           \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
                           unfolding Maps.PRJ\<^sub>1_def
                           using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
                                 dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
                                 dom_\<mu>_\<nu>.S\<^sub>1_def
                           by auto
                         moreover
                         have "(Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
                                                     \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
                               Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
                                                    \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) \<cong>
                               (tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)"
                           using VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<mu>\<nu> dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.s.leg1_simps(3)
                                 dom_\<mu>_\<nu>.s.leg1_simps(4) trg_dom dom_\<mu>_\<nu>.R\<^sub>0_def
                                 dom_\<mu>_\<nu>.prj_tab_agreement(1) isomorphic_symmetric
                           by simp
                         ultimately show ?thesis
                            using X.isomorphic_implies_same_tab isomorphic_symmetric by metis
                       qed
                       thus ?thesis
                         unfolding Span.chine_hcomp_def
                         using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C SPN_def isomorphic_reflexive
                               Maps.comp_CLS [of "spn ?\<mu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1 "spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1"]
                               Maps.comp_CLS [of "spn ?\<nu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 "spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"]
                         by simp
                     qed
                     moreover have "Maps.Dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)) =
                                    src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
                       by (metis (no_types, lifting) "1" "2" Maps.Dom.simps(1) Maps.comp_char
                           \<open>Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS\<close>)
                     ultimately show ?thesis by simp
                   qed
                   also have "... = Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
                   proof -
                     let ?tuple = "Maps.tuple \<lbrakk>\<lbrakk>spn (fst \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
                                                \<lbrakk>\<lbrakk>tab\<^sub>0 (cod ?\<mu>)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (cod ?\<nu>)\<rbrakk>\<rbrakk>
                                              \<lbrakk>\<lbrakk>spn (snd \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
                     have "iso_class \<mu>_\<nu>.chine = Maps.Map ?tuple"
                       using \<mu>_\<nu>.CLS_chine spn_def Maps.Map.simps(1)
                       by (metis (no_types, lifting))
                     thus ?thesis by simp
                   qed
                   also have "... = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
                   proof -
                     have "\<lbrakk>\<mu>_\<nu>.chine\<rbrakk> \<in> Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)"
                     proof -
                       have "\<guillemotleft>\<mu>_\<nu>.chine : src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<guillemotright>"
                         using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
                       thus ?thesis
                         using \<mu>_\<nu>.is_map ide_in_iso_class left_adjoint_is_ide by blast
                     qed
                     moreover have "\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<in>
                                    Maps.Hom (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
                     proof -
                       have "\<guillemotleft>cod_\<mu>_\<nu>.cmp : src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))\<guillemotright>"
                         using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C cod_\<mu>_\<nu>.cmp_in_hom cod_\<mu>\<nu>.tab_simps(2)
                         by simp
                       thus ?thesis
                         using cod_\<mu>_\<nu>.cmp_props equivalence_is_left_adjoint left_adjoint_is_ide
                               ide_in_iso_class [of cod_\<mu>_\<nu>.cmp]
                         by (metis (mono_tags, lifting) mem_Collect_eq)
                     qed
                     moreover have
                       "cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine \<in> Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
                     proof
                       show "is_iso_class \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
                         using \<mu>_\<nu>.w_simps(1) is_iso_classI by blast
                       show "is_iso_class \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
                         using cod_\<mu>_\<nu>.cmp_simps(2) is_iso_classI by blast
                       show "\<mu>_\<nu>.chine \<in> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
                         using ide_in_iso_class by simp
                       show "cod_\<mu>_\<nu>.cmp \<in> \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
                         using ide_in_iso_class by simp
                       show "cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
                         by (simp add: isomorphic_reflexive)
                     qed
                     ultimately show ?thesis
                       using \<mu>\<nu> cod_\<mu>_\<nu>.cmp_props \<mu>_\<nu>.chine_in_hom \<mu>_\<nu>.chine_is_induced_map
                             Maps.Comp_eq_iso_class_memb
                       by simp
                   qed
                   finally show ?thesis by simp
                 qed
 
                 have EQ: "\<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk> = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
                 proof (intro iso_class_eqI)
                   show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
                   proof -
                     interpret dom_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                          \<open>dom ?\<mu>\<nu>\<close>
                                          dom_\<mu>_\<nu>.\<rho>\<sigma>.tab
                                          \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                          \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                          \<open>dom ?\<mu>\<nu>\<close>
                                          \<open>tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)\<close>
                                          \<open>tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)\<close>
                                          \<open>tab\<^sub>1 (dom ?\<mu> \<star> dom ?\<nu>)\<close>
                                          \<open>dom ?\<mu>\<nu>\<close>
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C dom_\<mu>_\<nu>.cmp_interpretation by simp
                     interpret cod_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                         \<open>cod ?\<mu>\<nu>\<close>
                                         cod_\<mu>_\<nu>.\<rho>\<sigma>.tab
                                         \<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                         \<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                         \<open>cod ?\<mu>\<nu>\<close>
                                         \<open>tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)\<close>
                                         \<open>tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
                                         \<open>tab\<^sub>1 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
                                         \<open>cod ?\<mu>\<nu>\<close>
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C cod_\<mu>_\<nu>.cmp_interpretation by simp
                     interpret L: vertical_composite_of_arrows_of_tabulations_in_maps
                                    V H \<a> \<i> src trg
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
                                    \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                    \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                                    cod_\<mu>\<nu>.tab
                                    \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>?\<mu> \<star> ?\<nu>\<close>
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C dom_\<mu>_\<nu>.cmp_in_hom
                       by unfold_locales auto
                     interpret R: vertical_composite_of_arrows_of_tabulations_in_maps
                                    V H \<a> \<i> src trg
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
                                    \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                    \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                                    \<open>cod_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
                                    \<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                    \<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                                    cod_\<mu>\<nu>.tab
                                    \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
                                    \<open>?\<mu> \<star> ?\<nu>\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                        using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C cod_\<mu>_\<nu>.cmp_in_hom
                        by unfold_locales auto
                     have "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> L.chine"
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C L.chine_char dom_\<mu>_\<nu>.cmp_def isomorphic_symmetric
                       by simp
                     also have "... = R.chine"
                       using L.is_ide \<mu>\<nu> comp_arr_dom comp_cod_arr isomorphic_reflexive by force
                     also have "... \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
                       using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C R.chine_char cod_\<mu>_\<nu>.cmp_def by simp
                     finally show ?thesis by simp
                   qed
                 qed
                 show ?thesis
                   using LHS RHS EQ by simp
               qed
             qed
             thus ?thesis
               using Chn_LHS_eq Chn_RHS_eq by simp
           qed
         qed
       qed
     qed
 
     interpretation \<Xi>: natural_isomorphism VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<Xi>.map
       using VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<Xi>.map_simp_ide compositor_is_iso
       by (unfold_locales, simp)
 
     lemma compositor_is_natural_transformation:
     shows "transformation_by_components VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map
              (\<lambda>rs. CMP (fst rs) (snd rs))"
       ..
 
     lemma compositor_is_natural_isomorphism:
     shows "natural_isomorphism VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map \<Xi>.map"
       ..
 
   end
   
   subsubsection "Associativity Coherence"
 
   locale three_composable_identities_in_bicategory_of_spans =
     bicategory_of_spans V H \<a> \<i> src trg +
     f: identity_in_bicategory_of_spans V H \<a> \<i> src trg f +
     g: identity_in_bicategory_of_spans V H \<a> \<i> src trg g +
     h: identity_in_bicategory_of_spans V H \<a> \<i> src trg h
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and f :: 'a
   and g :: 'a
   and h :: 'a +
   assumes fg: "src f = trg g"
   and gh: "src g = trg h"
   begin
 
     interpretation f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
       using f.is_arrow_of_tabulations_in_maps by simp
     interpretation h: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h
       using h.is_arrow_of_tabulations_in_maps by simp
 
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp (infixr "\<odot>" 55)
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation SPN: "functor" V Span.vcomp SPN
       using SPN_is_functor by simp
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
       using SPN_is_weak_arrow_of_homs by simp
     interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
       using SPN.functor_FF by auto
     interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
                                 SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
       ..
     interpretation SPNoH: composite_functor VV.comp V Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
       ..
 
     text \<open>
       Here come a lot of interpretations for ``composite things''.
       We need these in order to have relatively short, systematic names for entities that will
       appear in the lemmas to follow.
       The names of the interpretations use a prefix notation, where \<open>H\<close> refers to horizontal
       composition of 1-cells and \<open>T\<close> refers to composite of tabulations.
       So, for example, \<open>THfgh\<close> refers to the composite of the tabulation associated with the
       horizontal composition \<open>f \<star> g\<close> with the tabulation associated with \<open>h\<close>.
     \<close>
     interpretation HHfgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation HfHgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation Tfg: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g
       using fg gh by unfold_locales auto
     interpretation Tgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg g h
       using fg gh by unfold_locales auto
     interpretation THfgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                             \<open>f \<star> g\<close> h
       using fg gh by unfold_locales auto
     interpretation THfgh: tabulation V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab
                             \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
       using THfgh.\<rho>\<sigma>.composite_is_tabulation by simp
     interpretation TfHgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                             f \<open>g \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation TfHgh: tabulation V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab
                             \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
       using TfHgh.\<rho>\<sigma>.composite_is_tabulation by simp
 
     interpretation Tfg_Hfg: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                               \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
                               \<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
                               \<open>f \<star> g\<close>
       by unfold_locales auto
     interpretation Tgh_Hgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                               \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
                               \<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
                               \<open>g \<star> h\<close>
       by unfold_locales auto
     interpretation THfgh_HHfgh:
         arrow_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
           \<open>(f \<star> g) \<star> h\<close> \<open>tab_of_ide ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
           \<open>(f \<star> g) \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation TfHgh_HfHgh:
         arrow_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
           \<open>f \<star> g \<star> h\<close> \<open>tab_of_ide (f \<star> g \<star> h)\<close> \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
           \<open>f \<star> g \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation TTfgh: composite_tabulation_in_maps V H \<a> \<i> src trg
                             \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
                             h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
       using fg gh by unfold_locales auto
     interpretation TTfgh_THfgh:
         horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
           h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
           \<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
           h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
           \<open>f \<star> g\<close> h
       ..
     interpretation TfTgh: composite_tabulation_in_maps V H \<a> \<i> src trg
                             f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
                             \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
       using fg gh by unfold_locales auto
     interpretation TfTgh_TfHgh:
         horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
           f \<open>g \<star> h\<close>
       ..
     interpretation TfTgh_TfTgh:
         horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
           f \<open>g \<star> h\<close>
       ..
     text \<open>
       The following interpretation defines the associativity between the peaks
       of the two composite tabulations \<open>TTfgh\<close> (associated to the left) and \<open>TfTgh\<close>
       (associated to the right).
     \<close>
     (* TODO: Try to get rid of the .\<rho>\<sigma> in, e.g., Tfg.\<rho>\<sigma>.p\<^sub>1. *)
     interpretation TTfgh_TfTgh:
         arrow_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
           \<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
           \<open>\<a>[f, g, h]\<close>
       using fg gh by unfold_locales auto
 
     text \<open>
       This interpretation defines the map, from the apex of the tabulation associated
       with the horizontal composite \<open>(f \<star> g) \<star> h\<close> to the apex of the tabulation associated
       with the horizontal composite \<open>f \<star> g \<star> h\<close>, induced by the associativity isomorphism
       \<open>\<a>[f, g, h]\<close> from \<open>(f \<star> g) \<star> h\<close> to \<open>f \<star> g \<star> h\<close>.
     \<close>
 
     interpretation HHfgh_HfHgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                   \<open>dom (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (dom (\<alpha> (f, g, h)))\<close>
                                   \<open>tab\<^sub>0 (dom (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (dom (\<alpha> (f, g, h)))\<close>
                                   \<open>cod (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (cod (\<alpha> (f, g, h)))\<close>
                                   \<open>tab\<^sub>0 (cod (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (cod (\<alpha> (f, g, h)))\<close>
                                   \<open>\<alpha> (f, g, h)\<close>
     proof -
       have "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
               ((f \<star> g) \<star> h) (tab_of_ide ((f \<star> g) \<star> h)) (tab\<^sub>0 ((f \<star> g) \<star> h)) (tab\<^sub>1 ((f \<star> g) \<star> h))
               (f \<star> g \<star> h) (tab_of_ide (f \<star> g \<star> h)) (tab\<^sub>0 (f \<star> g \<star> h)) (tab\<^sub>1 (f \<star> g \<star> h))
               \<a>[f, g, h]"
         using fg gh by unfold_locales auto
       thus "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
               (dom (\<alpha> (f, g, h))) (tab_of_ide (dom (\<alpha> (f, g, h))))
               (tab\<^sub>0 (dom (\<alpha> (f, g, h)))) (tab\<^sub>1 (dom (\<alpha> (f, g, h))))
               (cod (\<alpha> (f, g, h))) (tab_of_ide (cod (\<alpha> (f, g, h))))
               (tab\<^sub>0 (cod (\<alpha> (f, g, h)))) (tab\<^sub>1 (cod (\<alpha> (f, g, h))))
               (\<alpha> (f, g, h))"
         using fg gh \<alpha>_def by auto
     qed
 
     interpretation SPN_f: arrow_of_spans Maps.comp \<open>SPN f\<close>
       using SPN_in_hom Span.arr_char [of "SPN f"] by simp
     interpretation SPN_g: arrow_of_spans Maps.comp \<open>SPN g\<close>
       using SPN_in_hom Span.arr_char [of "SPN g"] by simp
     interpretation SPN_h: arrow_of_spans Maps.comp \<open>SPN h\<close>
       using SPN_in_hom Span.arr_char [of "SPN h"] by simp
     interpretation SPN_fgh: three_composable_identity_arrows_of_spans Maps.comp
                               Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 \<open>SPN f\<close> \<open>SPN g\<close> \<open>SPN h\<close>
       using fg gh Span.arr_char SPN_in_hom SPN.preserves_ide Span.ide_char
       apply unfold_locales by auto
 
     text \<open>
       The following relates the projections associated with the composite span \<open>SPN_fgh\<close>
       with tabulations in the underlying bicategory.
     \<close>
 
     lemma prj_char:
     shows "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     proof -
       show "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "ide (Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
           by (metis TTfgh.composable TTfgh.leg1_simps(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
               Tfg.\<rho>\<sigma>.T0.ide_right Tfg_Hfg.u_simps(3) f.T0.antipar(2) f.T0.ide_right
               f.u_simps(3) fg g.ide_leg1 g.leg1_simps(4) h.ide_leg1 h.leg1_simps(4)
               ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(1))
         thus ?thesis
           using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
                 Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
                 Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>1 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1"]
           by (simp add: TTfgh.composable Tfg.\<rho>\<sigma>.T0.antipar(2))
       qed
       show "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "ide (Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
           by (metis TTfgh.leg1_simps(2) bicategory_of_spans.tab\<^sub>0_simps(1)
               bicategory_of_spans.tab\<^sub>1_simps(1) bicategory_of_spans_axioms
               Tfg.\<rho>\<sigma>.T0.antipar(2) Tfg.\<rho>\<sigma>.T0.ide_right Tfg.composable f.T0.antipar(2)
               f.T0.ide_right f.u_simps(3) g.ide_leg1 g.leg1_simps(4)
               Tfg.u_simps(3) THfgh.composable h.ide_leg1 h.leg1_simps(4)
               ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(3))
         thus ?thesis
           using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
                 Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
                 Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>0 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1"]
           by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
       qed
       show "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
         using isomorphic_reflexive TTfgh.prj_char Tfg.\<rho>\<sigma>.prj_char
               Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
         by (simp add: Tfg.composable)
       show "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
         using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
               Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
               TfTgh.prj_char
         by simp
       show "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
        using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
               Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
               Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>1 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0"]
         by simp
       show "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
         using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
               Maps.comp_CLS [of "tab\<^sub>1 g" "Tgh.\<rho>\<sigma>.p\<^sub>1" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
               Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>0 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0"]
         by simp
     qed
 
     interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
       using compositor_is_natural_transformation by simp
     interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<Phi>.map
       using compositor_is_natural_isomorphism by simp
 
     (*
      * TODO: Figure out how this subcategory gets introduced.
      * The simps in the locale are used in the subsequent proofs.
      *)
     interpretation VVV': subcategory VxVxV.comp
                            \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> arr (fst (snd \<tau>\<mu>\<nu>)) \<and> arr (snd (snd \<tau>\<mu>\<nu>)) \<and>
                                   src (fst (snd \<tau>\<mu>\<nu>)) = trg (snd (snd \<tau>\<mu>\<nu>)) \<and>
                                   src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
       using fg gh VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C VVV.subcategory_axioms by simp
 
     text \<open>
       We define abbreviations for the left and right-hand sides of the equation for
       associativity coherence.
     \<close>
     (*
      * TODO: \<Phi> doesn't really belong in this locale.  Replace it with CMP and rearrange
      * material so that this locale comes first and the definition of \<Phi> comes later
      * in bicategory_of_spans.
      *)
     abbreviation LHS
     where "LHS \<equiv> SPN \<a>[f, g, h] \<bullet> \<Phi>.map (f \<star> g, h) \<bullet> (\<Phi>.map (f, g) \<circ> SPN h)"
 
     abbreviation RHS
     where "RHS \<equiv> \<Phi>.map (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi>.map (g, h)) \<bullet>
                     Span.assoc (SPN f) (SPN g) (SPN h)"
 
     lemma arr_LHS:
     shows "Span.arr LHS"
       using fg gh VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VVV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ide_char\<^sub>S\<^sub>b\<^sub>C Span.hseqI'
             HoHV_def compositor_in_hom \<alpha>_def
       apply (intro Span.seqI)
           apply simp_all
       using SPN.FF_def
        apply simp
     proof -
       have "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h)"
         using fg gh compositor_in_hom by simp
       also have "... = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
       proof -
         have "Span.seq (CMP (f \<star> g) h) (CMP f g \<circ> SPN h)"
         proof (intro Span.seqI Span.hseqI)
           show 1: "Span.in_hhom (SPN h) (SPN.map\<^sub>0 (src h)) (SPN.map\<^sub>0 (trg h))"
             using SPN.preserves_src SPN.preserves_trg by simp
           show 2: "Span.in_hhom (CMP f g) (SPN.map\<^sub>0 (trg h)) (SPN.map\<^sub>0 (trg f))"
             using compositor_in_hom SPN_fgh.\<nu>\<pi>.composable fg by auto
           show 3: "Span.arr (CMP (f \<star> g) h)"
             using TTfgh.composable Tfg.\<rho>\<sigma>.ide_base compositor_simps(1) h.is_ide by auto
           show "Span.dom (CMP (f \<star> g) h) = Span.cod (CMP f g \<circ> SPN h)"
             using 1 2 3 fg gh compositor_in_hom SPN_fgh.\<nu>\<pi>.composable SPN_in_hom SPN.FF_def
             by auto
         qed
         thus ?thesis by simp
       qed
       finally show "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
         by blast
     qed
 
     lemma arr_RHS:
     shows "Span.arr RHS"
       using fg gh VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<Phi>.map_simp_ide SPN.FF_def Span.hseqI'
       by (intro Span.seqI, simp_all)
 
     lemma par_LHS_RHS:
     shows "Span.par LHS RHS"
     proof (intro conjI)
       show "Span.arr LHS"
         using arr_LHS by simp
       show "Span.arr RHS"
         using arr_RHS by simp
       show "Span.dom LHS = Span.dom RHS"
       proof -
         have "Span.dom LHS = Span.dom (\<Phi>.map (f, g) \<circ> SPN h)"
           using arr_LHS by auto
         also have "... = Span.dom (\<Phi>.map (f, g)) \<circ> Span.dom (SPN h)"
           using arr_LHS Span.dom_hcomp [of "SPN h" "\<Phi>.map (f, g)"] by blast
         also have "... = (SPN f \<circ> SPN g) \<circ> SPN h"
           using fg \<Phi>.map_simp_ide VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C SPN.FF_def by simp
         also have "... = Span.dom (Span.assoc (SPN f) (SPN g) (SPN h))"
           using fg gh VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VVV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ide_char\<^sub>S\<^sub>b\<^sub>C by simp
         also have "... = Span.dom RHS"
           using \<open>Span.arr RHS\<close> by auto
         finally show ?thesis by blast
       qed
       show "Span.cod LHS = Span.cod RHS"
       proof -
         have "Span.cod LHS = Span.cod (SPN \<a>[f, g, h])"
           using arr_LHS by simp
         also have "... = SPN (f \<star> g \<star> h)"
           unfolding \<alpha>_def
           using fg gh VVV.ide_char\<^sub>S\<^sub>b\<^sub>C VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C HoVH_def
           by simp
         also have "... = Span.cod RHS"
           using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C SPN.FF_def
                 compositor_in_hom
           by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma Chn_LHS_eq:
     shows "Chn LHS =
            \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
     proof -
       have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot>
                         Span.chine_hcomp (CMP f g) (SPN h)"
       proof -
         have "Chn LHS = Chn (SPN \<a>[f, g, h]) \<odot> Chn (CMP (f \<star> g) h) \<odot>
                           Chn (CMP f g \<circ> SPN h)"
           using fg gh arr_LHS \<Phi>.map_simp_ide VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C Span.Chn_vcomp
           by auto
         moreover have "Chn (SPN \<a>[f, g, h]) = Maps.CLS HHfgh_HfHgh.chine"
           using fg gh SPN_def VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C spn_def \<alpha>_def by simp
         moreover have "Chn (CMP (f \<star> g) h) = Maps.CLS THfgh_HHfgh.chine"
           using fg gh CMP_def THfgh.cmp_def by simp
         moreover have "Chn (CMP f g \<circ> SPN h) = Span.chine_hcomp (CMP f g) (SPN h)"
           using fg gh Span.hcomp_def by simp
         ultimately show ?thesis by simp
       qed
       moreover have "Span.chine_hcomp (CMP f g) (SPN h) = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
       proof -
         have "Span.chine_hcomp (CMP f g) (SPN h) =
               Maps.tuple
                 (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
                    \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                 (\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
         proof -
           have "\<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
             using fg isomorphic_reflexive
                   Maps.comp_CLS [of "tab\<^sub>0 g" "Tfg.\<rho>\<sigma>.p\<^sub>0" "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
             by simp
           moreover have "span_in_category.apex Maps.comp
                            \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr> =
                          \<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk>"
           proof -
             interpret h: span_in_category Maps.comp \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr>\<close>
               using h.determines_span by simp
             interpret dom_h: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                \<open>dom h\<close> \<open>tab_of_ide (dom h)\<close> \<open>tab\<^sub>0 (dom h)\<close> \<open>tab\<^sub>1 (dom h)\<close>
                                \<open>cod h\<close> \<open>tab_of_ide (cod h)\<close> \<open>tab\<^sub>0 (cod h)\<close> \<open>tab\<^sub>1 (cod h)\<close>
                                h
               by (simp add: h.is_arrow_of_tabulations_in_maps
                   identity_arrow_of_tabulations_in_maps.intro
                   identity_arrow_of_tabulations_in_maps_axioms.intro)
             have "Maps.arr h.leg0"
               using h.leg_simps(1) by simp
             hence "Maps.dom h.leg0 = \<lbrakk>\<lbrakk>dom_h.chine\<rbrakk>\<rbrakk>"
               using Maps.dom_char Maps.CLS_in_hom
               apply simp
             proof -
               have "h.is_induced_map (src (tab\<^sub>0 h))"
                 using h.is_induced_map_iff dom_h.\<Delta>_eq_\<rho> h.apex_is_induced_by_cell by force
               hence "src (tab\<^sub>0 h) \<cong> h.chine"
                 using h.chine_is_induced_map h.induced_map_unique by simp
               thus "\<lbrakk>src (tab\<^sub>0 h)\<rbrakk> = \<lbrakk>h.chine\<rbrakk>"
                 using iso_class_eqI by simp
             qed
             thus ?thesis
               using h.apex_def spn_def by simp
           qed
           ultimately show ?thesis
             unfolding Span.chine_hcomp_def
             using fg gh CMP_def Tfg.\<rho>\<sigma>.prj_char Span.hcomp_def by simp
         qed
         also have "... = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
         proof -
           have "\<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
                 Maps.tuple \<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
                              \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                            \<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
             using TTfgh_THfgh.CLS_chine by simp
           also have "... =
                      Maps.tuple (\<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>)
                                   \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                                 (\<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
           proof -
             have "\<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
             proof -
               have "is_left_adjoint TTfgh.p\<^sub>1"
                 using Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable by simp
               moreover have "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1 \<cong> Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"
                 using TTfgh_THfgh.prj_chine(2) isomorphic_reflexive isomorphic_implies_hpar(2)
                 by blast
               ultimately show ?thesis
                 using Tfg_Hfg.is_map
                       Maps.comp_CLS [of Tfg_Hfg.chine TTfgh.p\<^sub>1 "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"]
                 by simp
             qed
             moreover have "\<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
             proof -
               have "is_left_adjoint TTfgh.p\<^sub>0"
                 by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
               moreover have "h.chine \<star> TTfgh.p\<^sub>0 \<cong> h.chine \<star> TTfgh.p\<^sub>0"
                 using TTfgh_THfgh.prj_chine(1) isomorphic_reflexive isomorphic_implies_hpar(2)
                 by blast
               ultimately show ?thesis
                 using h.is_map Maps.comp_CLS [of h.chine TTfgh.p\<^sub>0 "h.chine \<star> TTfgh.p\<^sub>0"]
                 by simp
             qed
             ultimately show ?thesis by argo
           qed
           also have "... =
                      Maps.tuple (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
                                   \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                                 (\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
             using Tfg.cmp_def spn_def TTfgh.prj_char by simp
           finally show ?thesis by simp
         qed
         finally show ?thesis by blast
       qed
       ultimately show ?thesis by simp
     qed
 
     abbreviation tuple_BC
     where "tuple_BC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0"
 
     abbreviation tuple_ABC
     where "tuple_ABC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>1\<^sub>1
                                     SPN_fgh.\<mu>.leg0
                                     (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
                                   tuple_BC"
 
     abbreviation tuple_BC'
     where "tuple_BC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
 
     abbreviation tuple_ABC'
     where "tuple_ABC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
                                       \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
                                    tuple_BC'"
 
     lemma csq:
     shows "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
                                     SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
     and "Maps.commutative_square SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
                                  SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
     proof -
       show 1: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
                                        SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
       proof
         show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
           using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
         show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
           using SPN_fgh.prj_simps(2-3,5-6) by presburger
         show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
           using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
           by auto
         show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
           by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
               Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
               SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
       qed
       show "Maps.commutative_square
               SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
               SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
       proof
         show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
           using fg gh SPN_fgh.prj_simps(10) by blast
         show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
           using fg gh 1 Maps.tuple_simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(1)
                 SPN_fgh.prj_simps(4) SPN_fgh.prj_simps(5)
           by presburger
         show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
           using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
         show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 = (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
           using 1 fg gh Maps.comp_assoc Maps.prj_tuple
           by (metis (no_types, lifting) Maps.pullback_commutes' SPN_fgh.cospan_\<mu>\<nu>)
       qed
     qed
 
     lemma tuple_ABC_eq_ABC':
     shows "tuple_BC = tuple_BC'"
     and "tuple_ABC = tuple_ABC'"
     proof -
       have "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
         using prj_char by simp
       moreover have "SPN_fgh.\<mu>.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk>"
         by simp
       moreover have "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
         using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
               Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
         by (simp add: g.T0.antipar(2))
       moreover show "tuple_BC = tuple_BC'"
         using prj_char Tfg.\<rho>\<sigma>.prj_char by simp
       ultimately show "tuple_ABC = tuple_ABC'"
         by argo
     qed
 
     lemma tuple_BC_in_hom:
     shows "Maps.in_hom tuple_BC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0))"
     proof
       show 1: "Maps.arr tuple_BC"
         using csq(1) by simp
       have 2: "Maps.commutative_square
                  \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
         by (metis Tfg.S\<^sub>0_def Tfg.span_legs_eq(3) Tgh.S\<^sub>1_def Tgh.span_legs_eq(4) csq(1)
                   prj_char(2) prj_char(3))
       show "Maps.dom tuple_BC = Maps.MkIde (src TTfgh.p\<^sub>0)"
       proof -
         have "Maps.dom tuple_BC' = Maps.dom \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
           using 2 Maps.tuple_simps by simp
         also have "... = Chn (Span.hcomp (Span.hcomp (SPN f) (SPN g)) (SPN h))"
           using Maps.dom_char
           by (metis SPN_fgh.prj_simps(5) prj_char(2))
         also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
           using 1 fg gh Maps.dom_char csq(1) prj_char(3) tuple_ABC_eq_ABC'(1)
                 Maps.Dom.simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(3,5-6)
           by presburger
         finally have "Maps.dom tuple_BC' = Maps.MkIde (src TTfgh.p\<^sub>0)"
           by blast
         thus ?thesis
           using tuple_ABC_eq_ABC' by simp
       qed
       show "Maps.cod tuple_BC = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
       proof -
         have "Maps.cod tuple_BC' = Maps.pbdom \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>"
           using 1 2 fg gh Maps.tuple_in_hom by blast
         also have "... = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
           using 1 2 fg gh Maps.pbdom_def
           by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
               SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tfg.S\<^sub>0_def Tfg.span_legs_eq(3)
               Tgh.S\<^sub>1_def Tgh.chine_hcomp_SPN_SPN Tgh.span_legs_eq(4) g.is_ide)
         finally show ?thesis
           using tuple_ABC_eq_ABC' by simp
       qed
     qed
 
     lemma tuple_ABC_in_hom:
     shows "Maps.in_hom tuple_ABC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src TfTgh.p\<^sub>0))"
     proof
       show 1: "Maps.arr tuple_ABC"
         using SPN_fgh.chine_assoc_def SPN_fgh.chine_assoc_in_hom by auto
       show "Maps.dom tuple_ABC = Maps.MkIde (src TTfgh.p\<^sub>0)"
       proof -
         have "Maps.dom tuple_ABC = Maps.dom SPN_fgh.chine_assoc"
           by (simp add: SPN_fgh.chine_assoc_def)
         also have "... = Chn ((SPN f \<circ> SPN g) \<circ> SPN h)"
           using SPN_fgh.chine_assoc_in_hom by blast
         also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
           by (metis (lifting) Maps.Dom.simps(1) Maps.dom_char SPN_fgh.prj_simps(3)
               SPN_fgh.prj_simps(6) prj_char(3))
         finally show ?thesis by blast
       qed
       show "Maps.cod tuple_ABC = Maps.MkIde (src TfTgh.p\<^sub>0)"
       proof -
         have "Maps.cod tuple_ABC = Maps.cod SPN_fgh.chine_assoc"
           by (simp add: SPN_fgh.chine_assoc_def)
         also have 1: "... = Chn (SPN f \<circ> SPN g \<circ> SPN h)"
           using SPN_fgh.chine_assoc_in_hom by blast
         also have "... = Maps.MkIde (src TfTgh.p\<^sub>0)"
           by (metis (lifting) Maps.Dom.simps(1) Maps.cod_char Maps.seq_char
               SPN_fgh.prj_chine_assoc(1) SPN_fgh.prj_simps(1) TfTgh.leg1_in_hom(1)
               TfTgh_TfTgh.u_in_hom 1 in_hhomE prj_char(4) src_hcomp)
         finally show ?thesis by argo
       qed
     qed
 
     lemma Chn_RHS_eq:
     shows "Chn RHS = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
     proof -
       have "Chn RHS =
             Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
               Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
       proof -
         have "Chn RHS = Chn (\<Phi>.map (f, g \<star> h)) \<odot>
                           Chn ((SPN f \<circ> \<Phi>.map (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h))"
           using arr_RHS Span.vcomp_eq Span.Chn_vcomp by blast
         also have "... = Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
                            Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
         proof -
           have "Span.seq (SPN f \<circ> \<Phi>.map (g, h)) (Span.assoc (SPN f) (SPN g) (SPN h))"
             using arr_RHS by auto
           thus ?thesis
             using fg gh Span.vcomp_eq [of "SPN f \<circ> \<Phi>.map (g, h)"
                                           "Span.assoc (SPN f) (SPN g) (SPN h)"]
             by simp
         qed
         finally show ?thesis by blast
       qed
       moreover have "Chn (\<Phi>.map (f, g \<star> h)) = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk>"
         using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C CMP_def TfHgh.cmp_def
         by simp
       moreover have "Chn (SPN f \<circ> \<Phi>.map (g, h)) = Span.chine_hcomp (SPN f) (CMP g h)"
         using fg gh Span.hcomp_def \<Phi>.map_simp_ide VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C SPN.FF_def
         by simp
       moreover have "Chn (Span.assoc (SPN f) (SPN g) (SPN h)) = tuple_ABC"
         using fg gh Span.\<alpha>_ide VVV.ide_char\<^sub>S\<^sub>b\<^sub>C VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C
               SPN_fgh.chine_assoc_def Span.\<alpha>_def
         by simp
       moreover have "Span.chine_hcomp (SPN f) (CMP g h) = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
       proof -
         have "Span.chine_hcomp (SPN f) (CMP g h) =
               Maps.tuple
                 (\<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>)
                    \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
                 (\<lbrakk>\<lbrakk>Tgh_Hgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
         proof -
           interpret f: span_in_category Maps.comp
                          \<open>\<lparr>Leg0 = Maps.MkArr (src (tab\<^sub>0 f)) (trg g) \<lbrakk>tab\<^sub>0 f\<rbrakk>,
                            Leg1 = Maps.MkArr (src (tab\<^sub>0 f)) (trg f) \<lbrakk>tab\<^sub>1 f\<rbrakk>\<rparr>\<close>
             using f.determines_span
             by (simp add: Tfg.composable)
           interpret f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
             using f.is_arrow_of_tabulations_in_maps by simp
           have "f.apex = Maps.CLS f.chine"
           proof (intro Maps.arr_eqI)
             show "Maps.arr f.apex" by simp
             show "Maps.arr \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
               using Maps.CLS_in_hom f.is_map by blast
             show "Maps.Dom f.apex = Maps.Dom \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
               using f.apex_def Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable by auto
             show "Maps.Cod f.apex = Maps.Cod \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
               using f.apex_def Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable by auto
             show "Maps.Map f.apex = Maps.Map \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
             proof -
               have "Maps.Map f.apex = \<lbrakk>src (tab\<^sub>0 f)\<rbrakk>"
                 using f.apex_def Maps.dom_char Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable
                 by auto
               also have "... = \<lbrakk>f.chine\<rbrakk>"
               proof (intro iso_class_eqI)
                 have "f.is_induced_map (src (tab\<^sub>0 f))"
                   using f.apex_is_induced_by_cell comp_cod_arr by auto
                 thus "src (tab\<^sub>0 f) \<cong> f.chine"
                   using f.induced_map_unique f.chine_is_induced_map by simp
               qed
               also have "... = Maps.Map \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
                 by simp
               finally show ?thesis by simp
             qed
           qed
           thus ?thesis
             unfolding Span.chine_hcomp_def
             using fg gh CMP_def Tgh.\<rho>\<sigma>.prj_char Span.hcomp_def isomorphic_reflexive
                   Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
                   Tgh.cmp_def TfTgh.prj_char
             by simp
         qed
         also have "... = Maps.tuple \<lbrakk>\<lbrakk>f.chine \<star> TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>
                                       \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
                                     \<lbrakk>\<lbrakk>Tgh_Hgh.chine \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
           using isomorphic_reflexive TfHgh.composable f.is_map TfHgh.composable Tgh_Hgh.is_map
                 Maps.comp_CLS [of f.chine TfTgh.p\<^sub>1 "f.chine \<star> TfTgh.p\<^sub>1"]
                 Maps.comp_CLS [of Tgh_Hgh.chine TfTgh.p\<^sub>0 "Tgh_Hgh.chine \<star> TfTgh.p\<^sub>0"]
           by auto
         also have "... = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
           using TfTgh_TfHgh.CLS_chine by simp
         finally show ?thesis by blast
       qed
       ultimately have "Chn RHS =\<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC"
         by simp
       also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
         using tuple_ABC_eq_ABC' by simp
       finally show ?thesis by simp
     qed
 
     interpretation g\<^sub>0h\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg \<open>tab\<^sub>1 h\<close> \<open>tab\<^sub>0 g\<close>
       using gh by unfold_locales auto
     interpretation f\<^sub>0g\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg \<open>tab\<^sub>1 g\<close> \<open>tab\<^sub>0 f\<close>
       using fg by unfold_locales auto
     interpretation f\<^sub>0gh\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg
                             \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close> \<open>tab\<^sub>0 f\<close>
       using fg gh Tgh.\<rho>\<sigma>.leg1_is_map
       by unfold_locales auto
     interpretation fg\<^sub>0h\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg
                             \<open>tab\<^sub>1 h\<close> \<open>tab\<^sub>0 g \<star> Tfg.p\<^sub>0\<close>
       using TTfgh.r\<^sub>0s\<^sub>1_is_cospan by simp
 
     lemma src_tab_eq:
     shows "(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
               TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu> =
            TTfgh.tab"
     proof -
       have "TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu> =
             (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> TTfgh.tab"
         unfolding TTfgh.tab_def
         using TTfgh_TfTgh.chine_is_induced_map TTfgh.tab_def TTfgh_TfTgh.\<Delta>_simps(4)
         by auto
       moreover have "iso (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0)"
         by (simp add: fg gh)
       moreover have "inv (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) = \<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
         using fg gh by simp
       ultimately show ?thesis
         using TTfgh_TfTgh.\<Delta>_simps(1)
               invert_side_of_triangle(1)
                 [of "TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu>"
                     "\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0" TTfgh.tab]
         by argo
     qed
 
     text \<open>
       We need to show that the associativity isomorphism (defined in terms of tupling) coincides
       with \<open>TTfgh_TfTgh.chine\<close> (defined in terms of tabulations).  In order to do this,
       we need to know how the latter commutes with projections.  That is the purpose of
       the following lemma.  Unfortunately, it requires some lengthy calculations,
       which I haven't seen any way to avoid.
     \<close>
 
     lemma prj_chine:
     shows "\<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "\<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     proof -
       have 1: "ide TfTgh.p\<^sub>1"
         by (simp add: TfTgh.composable)
       have 2: "ide TTfgh_TfTgh.chine"
         by simp
       have 3: "src TfTgh.p\<^sub>1 = trg TTfgh_TfTgh.chine"
         using TTfgh_TfTgh.chine_in_hom(1) by simp
       have 4: "src (tab\<^sub>1 f) = trg TfTgh.p\<^sub>1"
         using TfTgh.leg1_simps(2) by blast
       text \<open>
         The required isomorphisms will each be established via \<open>T2\<close>, using the equation
         \<open>src_tab_eq\<close> (associativities omitted from diagram):
 $$
 \begin{array}{l}
 \xymatrix{
   && \xtwocell[dddd]{}\omit{^{\rm the\_}\nu}
   & \scriptstyle{{\rm TTfgh}.{\rm apex}} \ar[dd]^{{\rm chine}} \ar[dddlll]_{{\rm TfTgh}.p_1} \ar[dddrrr]^{{\rm TfTgh}.p_0}
   & \xtwocell[dddd]{}\omit{^{\rm the\_}\theta} \\
   &&&&& \\
   &&& \scriptstyle{{\rm TfTgh.apex}} \ar[ddll]_{{\rm TfTgh}.p_1} \ar[dr]^{{\rm TfTgh}.p_0} && \\
   \scriptstyle{f.{\rm apex}} \ar[dd]_{f.{\rm tab}_1}
   && \dtwocell\omit{^<-7>{f_0gh_1.\phi}}
   && \scriptstyle{{\rm Tgh.apex}} \ar[dl]_{{\rm Tgh}.p_1} \ar[dr]^{{\rm Tgh}.p_0} \ddtwocell\omit{^{g_0h_1.\phi}}
   && \scriptstyle{h.{\rm apex}} \ar[dd]^{h.{\rm tab}_0} \\
   & \scriptstyle{f.{\rm apex}} \ar[dl]_{f.{\rm tab}_1} \ar[dr]^{f.{\rm tab}_0} \dtwocell\omit{^f.{\rm tab}}
   && \scriptstyle{g.{\rm apex}} \ar[dl]_{g.{\rm tab}_1} \ar[dr]^{g.{\rm tab}_0} \dtwocell\omit{^g.{\rm tab}}
   && \scriptstyle{h.{\rm apex}} \ar[dl]_{h.{\rm tab}_1} \ar[dr]^{h.{\rm tab}_0}  \dtwocell\omit{^h.{\rm tab}} \\  
   \scriptstyle{{\rm trg}~f} && \scriptstyle{{\rm src}~f = {\rm trg}~g} \ar[ll]^{f}
   && \scriptstyle{{\rm src}~g = {\rm trg}~h} \ar[ll]^{g} && \scriptstyle{{\rm src}~h} \ar[ll]^{h}
 }
 \\
 \\
 \hspace{7cm}=
 \\
 \\
 \xymatrix{
   &&& \scriptstyle{{\rm TTfgh.apex}} \ar[dl]_{{\rm TTfgh}.p_1} \ar[ddrr]^{{\rm TTfgh}.p_0} && \\
   && \scriptstyle{{\rm Tfg.apex}} \ar[dl]_{{\rm Tfg}.p_1} \ar[dr]^{{\rm Tfg}.p_0} \ddtwocell\omit{^{f_0g_1.\phi}}
   & \dtwocell\omit{^<-7>{fg_0h_1.\phi}} &&& \\
   & \scriptstyle{f.{\rm apex}} \ar[dl]_{f.{\rm tab}_1} \ar[dr]^{f.{\rm tab}_0} \dtwocell\omit{^f.{\rm tab}}
   && \scriptstyle{g.{\rm apex}} \ar[dl]_{g.{\rm tab}_1} \ar[dr]^{g.{\rm tab}_0} \dtwocell\omit{^g.{\rm tab}}
   && \scriptstyle{h.{\rm apex}} \ar[dl]_{h.{\rm tab}_1} \ar[dr]^{h.{\rm tab}_0}  \dtwocell\omit{^h.{\rm tab}} \\  
   \scriptstyle{{\rm trg}~f} && \scriptstyle{{\rm src}~f = {\rm trg}~g} \ar[ll]^{f}
   && \scriptstyle{{\rm src}~g = {\rm trg}~h} \ar[ll]^{g} && \scriptstyle{{\rm src}~h} \ar[ll]^{h}
 }
 \end{array}
 $$
         There is a sequential dependence between the proofs, such as we have already
         seen for \<open>horizontal_composite_of_arrows_of_tabulations_in_maps.prj_chine\<close>.
       \<close>
       define u\<^sub>f where "u\<^sub>f = g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
       define w\<^sub>f where "w\<^sub>f = Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1"
       define w\<^sub>f' where "w\<^sub>f' = TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
       define \<theta>\<^sub>f
       where "\<theta>\<^sub>f = (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot> (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot> (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                    \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                    ((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> (f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                    \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
       define \<theta>\<^sub>f'
       where "\<theta>\<^sub>f' = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                    can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                        (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                    (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                    (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                    ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                    (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                    (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                    \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]"
       define \<beta>\<^sub>f
       where "\<beta>\<^sub>f = \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                   TTfgh_TfTgh.the_\<nu> \<cdot>
                   \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
       have w\<^sub>f: "ide w\<^sub>f"
         using w\<^sub>f_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
       have w\<^sub>f_is_map: "is_left_adjoint w\<^sub>f"
         using w\<^sub>f_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
           by (simp add: left_adjoints_compose)
       have w\<^sub>f': "ide w\<^sub>f'"
         unfolding w\<^sub>f'_def by simp
       have w\<^sub>f'_is_map: "is_left_adjoint w\<^sub>f'"
         unfolding w\<^sub>f'_def
         using 3 TTfgh_TfTgh.is_map f\<^sub>0gh\<^sub>1.leg1_is_map
         by (simp add: left_adjoints_compose)
       have \<theta>\<^sub>f: "\<guillemotleft>\<theta>\<^sub>f : tab\<^sub>0 f \<star> w\<^sub>f \<Rightarrow> u\<^sub>f\<guillemotright>"
       proof (unfold \<theta>\<^sub>f_def w\<^sub>f_def u\<^sub>f_def, intro comp_in_homI)
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
                  tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using f\<^sub>0g\<^sub>1.leg1_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan by auto
         show "\<guillemotleft>f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1 :
                  (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using f\<^sub>0g\<^sub>1.\<phi>_in_hom(2) Tfg.\<rho>\<sigma>.T0.antipar(1)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>(g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 :
                  (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> ((g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using Tfg.\<rho>\<sigma>.T0.antipar(1)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1 :
                  ((g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (g \<star> tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
                 (g \<star> tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> g \<star> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
         show "\<guillemotleft>g \<star> fg\<^sub>0h\<^sub>1.\<phi> : g \<star> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> g \<star> tab\<^sub>1 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>g \<star> h.tab \<star> TTfgh.p\<^sub>0 : g \<star> tab\<^sub>1 h \<star> TTfgh.p\<^sub>0 \<Rightarrow> g \<star> (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0\<guillemotright>"
           using gh fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] :
                 g \<star> (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0 \<Rightarrow> g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
           using gh fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
           by (intro hcomp_in_vhom, auto)
       qed
       have \<theta>\<^sub>f': "\<guillemotleft>\<theta>\<^sub>f' : tab\<^sub>0 f \<star> w\<^sub>f' \<Rightarrow> u\<^sub>f\<guillemotright>"
       proof (unfold \<theta>\<^sub>f'_def w\<^sub>f'_def u\<^sub>f_def, intro comp_in_homI)
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
                  tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<Rightarrow> (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using "1" "2" "3" "4" assoc'_in_hom(2) f.ide_u f.leg1_simps(3) by auto
         show "\<guillemotleft>f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine :
                  (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine \<Rightarrow>
                      ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.\<phi>_in_hom(2)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
                  ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                          \<Rightarrow> (((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>(\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
                  (((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                     \<Rightarrow> ((g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
                 ((g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                    \<Rightarrow> ((g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan g\<^sub>0h\<^sub>1.\<phi>_in_hom(2)
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
                 ((g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                    \<Rightarrow> ((g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
           by (intro hcomp_in_vhom, auto)
         show "\<guillemotleft>can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                    (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) :
                    ((g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                      \<Rightarrow> g \<star> h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan by auto
         show "\<guillemotleft>g \<star> h \<star> TTfgh_TfTgh.the_\<theta> :
                  g \<star> h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                     \<Rightarrow> g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan TTfgh_TfTgh.the_\<theta>_in_hom
           by (intro hcomp_in_vhom, auto)
       qed
       have \<beta>\<^sub>f: "\<guillemotleft>\<beta>\<^sub>f : tab\<^sub>1 f \<star> w\<^sub>f \<Rightarrow> tab\<^sub>1 f \<star> w\<^sub>f'\<guillemotright>"
       proof (unfold \<beta>\<^sub>f_def w\<^sub>f_def w\<^sub>f'_def, intro comp_in_homI)
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
                  tab\<^sub>1 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using TTfgh.leg1_in_hom(2) assoc'_in_hom by auto
         show "\<guillemotleft>TTfgh_TfTgh.the_\<nu> :
                  (tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using TTfgh_TfTgh.the_\<nu>_in_hom TTfgh_TfTgh.the_\<nu>_props by simp
         show "\<guillemotleft>\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
                 (tab\<^sub>1 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine \<Rightarrow> tab\<^sub>1 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using 1 2 3 4 by auto
       qed
       have iso_\<beta>\<^sub>f: "iso \<beta>\<^sub>f"
         unfolding \<beta>\<^sub>f_def
         using 1 2 3 4 \<beta>\<^sub>f \<beta>\<^sub>f_def isos_compose
         apply (intro isos_compose)
             apply (metis TTfgh.composable TTfgh.leg1_in_hom(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
                          Tfg.\<rho>\<sigma>.T0.ide_right Tfg.\<rho>\<sigma>.leg1_in_hom(2) Tfg_Hfg.u_simps(3)
                          f.T0.antipar(2) f.T0.ide_right f.ide_leg1 f\<^sub>0g\<^sub>1.cospan g.ide_leg1
                          h.ide_leg1 h.leg1_simps(4) hcomp_in_vhomE ide_hcomp
                          iso_assoc' tab\<^sub>1_simps(1))
         using TTfgh_TfTgh.the_\<nu>_props(2) f.ide_leg1 iso_assoc by blast+
       have u\<^sub>f: "ide u\<^sub>f"
         using \<theta>\<^sub>f ide_cod by blast
       have w\<^sub>f_in_hhom: "in_hhom w\<^sub>f (src u\<^sub>f) (src (tab\<^sub>0 f))"
         using u\<^sub>f w\<^sub>f u\<^sub>f_def w\<^sub>f_def by simp
       have w\<^sub>f'_in_hhom: "in_hhom w\<^sub>f' (src u\<^sub>f) (src (tab\<^sub>0 f))"
         using u\<^sub>f w\<^sub>f' w\<^sub>f'_def u\<^sub>f_def by simp
       have 5: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>f \<Rightarrow> w\<^sub>f'\<guillemotright> \<and> \<beta>\<^sub>f = tab\<^sub>1 f \<star> \<gamma> \<and> \<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>)"
       proof -
         have eq\<^sub>f: "f.composite_cell w\<^sub>f \<theta>\<^sub>f = f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f"
         proof -
           text \<open>
             I don't see any alternative here to just grinding out the calculation.
             The idea is to bring \<open>f.composite_cell w\<^sub>f \<theta>\<^sub>f\<close> into a form in which
             \<open>src_tab_eq\<close> can be applied to eliminate \<open>\<theta>\<^sub>f\<close> in favor of \<open>\<theta>\<^sub>f'\<close>.
           \<close>
           have "f.composite_cell w\<^sub>f \<theta>\<^sub>f =
                   ((f \<star> g \<star> \<a>[h, tab\<^sub>0 h, fg\<^sub>0h\<^sub>1.p\<^sub>0]) \<cdot>
                     (f \<star> g \<star> h.tab \<star> fg\<^sub>0h\<^sub>1.p\<^sub>0) \<cdot>
                     (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                     (f \<star> \<a>[g, tab\<^sub>0 g \<star> f\<^sub>0g\<^sub>1.p\<^sub>0, fg\<^sub>0h\<^sub>1.p\<^sub>1]) \<cdot>
                     (f \<star> \<a>[g, tab\<^sub>0 g, f\<^sub>0g\<^sub>1.p\<^sub>0] \<star> fg\<^sub>0h\<^sub>1.p\<^sub>1) \<cdot>
                     (f \<star> (g.tab \<star> f\<^sub>0g\<^sub>1.p\<^sub>0) \<star> fg\<^sub>0h\<^sub>1.p\<^sub>1) \<cdot>
                     (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> fg\<^sub>0h\<^sub>1.p\<^sub>1) \<cdot>
                     (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, f\<^sub>0g\<^sub>1.p\<^sub>1, fg\<^sub>0h\<^sub>1.p\<^sub>1])) \<cdot>
                     \<a>[f, tab\<^sub>0 f, f\<^sub>0g\<^sub>1.p\<^sub>1 \<star> fg\<^sub>0h\<^sub>1.p\<^sub>1] \<cdot>
                     (f.tab \<star> f\<^sub>0g\<^sub>1.p\<^sub>1 \<star> fg\<^sub>0h\<^sub>1.p\<^sub>1)"
             unfolding w\<^sub>f_def \<theta>\<^sub>f_def
             using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps Tgh.composable whisker_left by simp  (* 12 sec, 30 sec cpu *)
           also have "... =
                   (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                     (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                     (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                     (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                     (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                     (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                     (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                     (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                     \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
                     (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
             using comp_assoc by simp
           also have "... =
                        (\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          \<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
                        (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
           proof -
             have "(\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                     \<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
                     (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) =
                   f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr comp_assoc_assoc' by simp
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
                        (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
             using comp_assoc by presburger
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0] \<cdot>
                        (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0)) \<cdot>
                        (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
             using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_assoc
                   assoc'_naturality [of f g "\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"]
             by simp
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>1 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>)) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
             using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_assoc
                   assoc'_naturality [of f g "h.tab \<star> TTfgh.p\<^sub>0"]
             by simp
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1]) \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
             using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_assoc
                   assoc'_naturality [of f g fg\<^sub>0h\<^sub>1.\<phi>]
             by simp
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
           proof -
             have "(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot> \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] =
                   \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                     \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             proof -
               have "(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot> \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] =
                     \<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                               \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
                 using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                       \<a>'_def \<alpha>_def
                 by simp
               also have "... =
                          \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                           (\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
                           \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
                 using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                 by (intro E.eval_eqI, simp_all)
               also have "... = \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                                  \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
                 using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                       \<a>'_def \<alpha>_def
                 by simp
               finally show ?thesis by blast
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
           proof -
             have "(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] =
                   \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1)"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom
                     assoc_naturality [of f f\<^sub>0g\<^sub>1.\<phi> TTfgh.p\<^sub>1]
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                        (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
           proof -
             have "(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] =
                   \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1)"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom
                     assoc_naturality [of f "g.tab \<star> Tfg.p\<^sub>0" TTfgh.p\<^sub>1]
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps assoc'_naturality [of f.tab Tfg.p\<^sub>1 TTfgh.p\<^sub>1] comp_assoc
             by simp
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1)) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "(((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                      ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
                      ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) =
                   (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr whisker_right comp_assoc_assoc'
                     whisker_left [of f "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]" "\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]"]
               by simp
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using comp_assoc by presburger
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (((\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "((\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                      (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
                      ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) =
                   (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1"
               using fg fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr comp_assoc_assoc'
                     whisker_right
                       [of TTfgh.p\<^sub>1 "\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0]" "\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0]"]
               by simp
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
                        ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1)) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using comp_assoc by presburger
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
                          (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
                          (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
                          (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
                          \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
                          (f.tab \<star> Tfg.p\<^sub>1)
                         \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                   whisker_right comp_assoc
             by simp
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
                          (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
                          (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
                          (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
                          \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
                          (f.tab \<star> Tfg.p\<^sub>1)
                         \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                        (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
                        (\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) =
                       \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                        (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                        (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
                         \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                        ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
                        (\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>)\<rbrace>"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                     \<a>'_def \<alpha>_def
               by simp
             also have "... = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
               by (intro E.eval_eqI, auto)
             also have "... = \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                     \<a>'_def \<alpha>_def
               by simp
             finally show ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
                          (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
                          (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
                          (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
                          \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
                          (f.tab \<star> Tfg.p\<^sub>1)
                         \<star> TTfgh.p\<^sub>1) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "(\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) =
                     ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                     comp_cod_arr comp_assoc_assoc'
               by simp
             thus ?thesis by simp
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                        ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                        \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
                          (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
                          (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
                          (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
                          \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
                          (f.tab \<star> Tfg.p\<^sub>1)
                         \<star> TTfgh.p\<^sub>1)) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using comp_assoc by presburger
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        TTfgh.tab \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using TTfgh.tab_def Tfg.\<rho>\<sigma>.tab_def by simp
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                          ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                          \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                          (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
                            (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
                            (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<cdot>
                                  (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<cdot>
                                  (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<cdot>
                                  (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                                  \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<cdot>
                                  (g.tab \<star> Tgh.p\<^sub>1)
                               \<star> TfTgh.p\<^sub>0) \<cdot>
                            (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                            \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                            (f.tab \<star> TfTgh.p\<^sub>1)
                           \<star> TTfgh_TfTgh.chine) \<cdot>
                          TTfgh_TfTgh.the_\<nu>) \<cdot>
                          \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using src_tab_eq TfTgh.tab_def Tgh.\<rho>\<sigma>.tab_def comp_assoc by simp
           text \<open>Now we have to make this look like \<open>f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f\<close>.\<close>
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                          ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                          ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                          \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                          (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
                            (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
                            ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
                              (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                              (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                              (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                              (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                              (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                              (f \<star> f\<^sub>0gh\<^sub>1.\<phi>)) \<cdot>
                              \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                              (f.tab \<star> TfTgh.p\<^sub>1)
                             \<star> TTfgh_TfTgh.chine) \<cdot>
                          TTfgh_TfTgh.the_\<nu>) \<cdot>
                          \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<cdot>
                           (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<cdot>
                           (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<cdot>
                           (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                           \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<cdot>
                           (g.tab \<star> Tgh.p\<^sub>1)
                       \<star> TfTgh.p\<^sub>0 =
                     (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0)"
               using fg gh whisker_right whisker_left by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
                       (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
                       (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1)
                      \<star> TTfgh_TfTgh.chine =
                     (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                     (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                     ((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine)"
               (* using fg gh whisker_right [of TTfgh_TfTgh.chine] by auto (* 2 min *) *)
             proof -
               have "arr (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
                       (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
                       (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using fg gh
                 by (intro seqI' comp_in_homI) auto
               moreover
               have "arr ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
                       (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               moreover
               have "arr (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1))"
                 using calculation by blast
               ultimately show ?thesis
                 using whisker_right [of TTfgh_TfTgh.chine] TTfgh_TfTgh.is_ide by presburger
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
          proof -
            have "((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
                     (f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine"
              using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                    comp_arr_dom comp_assoc_assoc'
              by simp
            thus ?thesis by simp
          qed
          also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using comp_assoc by presburger
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
                       \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine)"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                     assoc'_naturality [of f.tab TfTgh.p\<^sub>1 TTfgh_TfTgh.chine]
               by simp
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        ((\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine)) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "(\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                       \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
                       (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) =
                     f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
               using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                     comp_cod_arr comp_assoc_assoc'
               by simp
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
             using comp_assoc by presburger
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                       (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
             proof -
               have "(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
                         \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                         \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] =
                       \<lbrace>(\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                          \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                          \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
                 using \<a>'_def \<alpha>_def by simp
               also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                                   (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>])\<rbrace>"
                 using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                 by (intro E.eval_eqI, auto)
               also have "... = \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                                    (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
                 using \<a>'_def \<alpha>_def by simp
               finally show ?thesis by simp
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
             proof -
               (*
                * This one can't be shortcut with a straight coherence-based proof,
                * due to the presence of f\<^sub>0gh\<^sub>1.\<phi>, g\<^sub>0h\<^sub>1.\<phi>, h.tab, with associativities that
                * do not respect their domain and codomain.
                *
                * I also tried to avoid distributing the "f \<star>" in advance, in order to
                * reduce the number of associativity proof steps, but it then becomes
                * less automatic to prove the necessary "arr" facts to do the proof.
                * So unfortunately the mindless grind seems to be the path of least
                * resistance.
                *)
               have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
                         \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
                       ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         (((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         \<a>\<^sup>-\<^sup>1[f, (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                         (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
                 using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                       assoc'_naturality [of f f\<^sub>0gh\<^sub>1.\<phi> TTfgh_TfTgh.chine] comp_assoc
                 by simp
               also have "... =
                            ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                              (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
               proof -
                 have "((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[f, (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                         \<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                           (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
                   using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                         assoc'_naturality [of f "(g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
                   by simp
                 thus ?thesis
                   using comp_assoc by presburger
               qed
               also have "... =
                            ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                              (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
               proof -
                 have "((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                         \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                           (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
                   using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                           assoc'_naturality
                             [of f "\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
                   by simp
                 thus ?thesis
                   using comp_assoc by presburger
               qed
               also have "... =
                            ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                              (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
               proof -
                 have "((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                         \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                           (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
                   using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                         assoc'_naturality [of f "(g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
                   by simp
                 thus ?thesis
                   using comp_assoc by presburger
               qed
               also have "... =
                            (((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                              (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
               proof -
                 have "((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                         \<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                           (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
                   using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                         assoc'_naturality
                           [of f "(g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
                   by simp
                 thus ?thesis
                   using comp_assoc by presburger
               qed
               also have "... =
                            \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                              (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
               proof -
                 (* OK, we can perhaps shortcut the last few steps... *)
                 have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
                           ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                         \<lbrace>((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>])
                               \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                            ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                 \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                            ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                 \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                            \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
                                \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
                   using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                         \<a>'_def \<alpha>_def
                   by simp
                 also have "... =
                              \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
                                   \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                                 (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>])
                                     \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                                 (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                      \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                                 (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                      \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)\<rbrace>"
                     using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                     apply (intro E.eval_eqI) by simp_all
                   also have "... =
                              \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                                (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                                (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                                (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
                   using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps
                         \<a>'_def \<alpha>_def
                   by simp
                 finally show ?thesis
                   using comp_assoc by presburger
               qed
               finally show ?thesis
                 using comp_assoc by presburger
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        (\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                             \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                       (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                       (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                       (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                       (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                       (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) =
                     (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
               using fg gh whisker_left by simp  (* 15 sec elapsed, 30 sec cpu *)
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        (f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        (\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                        \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)) \<cdot>
                        (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                             \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
                        ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) =
                     \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                        (((f \<star> g) \<star> h) \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
             proof -
               have "(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) =
                       \<a>\<^sup>-\<^sup>1[f, g, h] \<star> TTfgh_TfTgh.the_\<theta>"
                 using fg gh comp_arr_dom comp_cod_arr
                       interchange [of "\<a>\<^sup>-\<^sup>1[f, g, h]" "f \<star> g \<star> h"
                                       "tab\<^sub>0 h \<star> TTfgh.p\<^sub>0" TTfgh_TfTgh.the_\<theta>]
                 by simp
               also have "... = (((f \<star> g) \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                                (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
                 using fg gh comp_arr_dom comp_cod_arr
                       interchange [of "(f \<star> g) \<star> h" "\<a>\<^sup>-\<^sup>1[f, g, h]" TTfgh_TfTgh.the_\<theta>
                                       "((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine"]
                 by simp
               finally show ?thesis
                 using comp_assoc by presburger
             qed
             also have "... =
                          (\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
                            ((f \<star> g) \<star> h \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
                            \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
               using fg gh assoc_naturality [of "f \<star> g" h TTfgh_TfTgh.the_\<theta>] comp_assoc
               by simp
             also have "... =
                          (f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            \<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
               using fg gh assoc_naturality [of f g "h \<star> TTfgh_TfTgh.the_\<theta>"] comp_assoc
               by simp
             finally show ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        ((f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        (f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                 (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
                        (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                             \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                        \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                        (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                        (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
                     f \<star> can
                           (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                           (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
             proof -
               have "\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                         \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
                         (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                         (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                         \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                         (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
                         (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                         (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
                       \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>,
                          \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                         \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>,
                          ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                         (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]
                            \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                         \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
                           \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                         (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>,
                              (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                         \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
                             \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                         (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star>
                           \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                         (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                            \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                         (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                            \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)\<rbrace>"
                 using \<a>'_def \<alpha>_def by simp
               also have "... =
                          can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                 \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))
                            (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                 \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))"
                 using fg gh
                 apply (unfold can_def)
                 apply (intro E.eval_eqI)
                 by simp_all
               also have "... =
                          f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                     \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                  (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                     \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
                 using fg gh whisker_can_left_0 by simp
               finally show ?thesis by blast
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... =
                        (f \<star> (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                           can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                  \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                               (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                  \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                           (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
                        \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
                        (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
                        \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                        TTfgh_TfTgh.the_\<nu> \<cdot>
                        \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
           proof -
             have "((f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                        (f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                    \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                 (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                    \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
                        (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                             (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                             \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) =
                     f \<star> (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                           can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                  \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                               (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                  \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                           (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                           (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                           \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]"
             proof -
               have 1: "arr ((g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
                 using fg gh
                 apply (intro seqI' comp_in_homI) by auto
               moreover
               have 2: "arr (can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                    \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                    \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
                 using calculation by blast
               ultimately show ?thesis
                 using whisker_left f.ide_base by presburger
             qed
             thus ?thesis
               using comp_assoc by presburger
           qed
           also have "... = f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f"
             unfolding w\<^sub>f'_def \<theta>\<^sub>f'_def \<beta>\<^sub>f_def
             using comp_assoc by presburger
           finally show ?thesis by blast
         qed
         show ?thesis
           using w\<^sub>f w\<^sub>f' \<theta>\<^sub>f \<theta>\<^sub>f' \<beta>\<^sub>f f.T2 [of w\<^sub>f w\<^sub>f' \<theta>\<^sub>f u\<^sub>f \<theta>\<^sub>f' \<beta>\<^sub>f] eq\<^sub>f by fast
       qed
       obtain \<gamma>\<^sub>f where \<gamma>\<^sub>f: "\<guillemotleft>\<gamma>\<^sub>f : w\<^sub>f \<Rightarrow> w\<^sub>f'\<guillemotright> \<and> \<beta>\<^sub>f = tab\<^sub>1 f \<star> \<gamma>\<^sub>f \<and> \<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f)"
         using 5 by auto
       show "\<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "iso \<gamma>\<^sub>f"
           using \<gamma>\<^sub>f BS3 w\<^sub>f_is_map w\<^sub>f'_is_map by blast
         hence "isomorphic w\<^sub>f w\<^sub>f'"
           using \<gamma>\<^sub>f isomorphic_def isomorphic_symmetric by auto
         thus ?thesis
           using w\<^sub>f w\<^sub>f_def w\<^sub>f'_def Maps.CLS_eqI isomorphic_symmetric by auto
       qed
       text \<open>
         On to the next equation:
         \[
            \<open>\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>\<close>.
         \]
         We have to make use of the equation \<open>\<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f)\<close> in this part,
         similarly to how the equation \<open>src_tab_eq\<close> was used to replace
         \<open>TTfgh.tab\<close> in the first part.
       \<close>
       define u\<^sub>g where "u\<^sub>g = h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
       define w\<^sub>g where "w\<^sub>g = Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1"
       define w\<^sub>g' where "w\<^sub>g' = Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
       define \<theta>\<^sub>g
       where "\<theta>\<^sub>g = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot>
                     \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
       define \<theta>\<^sub>g'
       where "\<theta>\<^sub>g' = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                    can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                        (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                    ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                    (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                    \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
       define \<beta>\<^sub>g
       where "\<beta>\<^sub>g = \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                   \<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                   (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                   (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot> \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                   \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
       have u\<^sub>g: "ide u\<^sub>g"
         unfolding u\<^sub>g_def by simp
       have w\<^sub>g: "ide w\<^sub>g"
         unfolding w\<^sub>g_def using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
       have w\<^sub>g_is_map: "is_left_adjoint w\<^sub>g"
         unfolding w\<^sub>g_def
         using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps left_adjoints_compose by simp
       have w\<^sub>g': "ide w\<^sub>g'"
         unfolding w\<^sub>g'_def by simp
       have w\<^sub>g'_is_map: "is_left_adjoint w\<^sub>g'"
         unfolding w\<^sub>g'_def
         using TTfgh_TfTgh.is_map left_adjoints_compose by simp
       have \<theta>\<^sub>g: "\<guillemotleft>\<theta>\<^sub>g : tab\<^sub>0 g \<star> w\<^sub>g \<Rightarrow> u\<^sub>g\<guillemotright>"
         using w\<^sub>g_def u\<^sub>g_def \<theta>\<^sub>g_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps fg\<^sub>0h\<^sub>1.\<phi>_in_hom by auto
       have \<theta>\<^sub>g': "\<guillemotleft>\<theta>\<^sub>g' : tab\<^sub>0 g \<star> w\<^sub>g' \<Rightarrow> u\<^sub>g\<guillemotright>"
         unfolding w\<^sub>g'_def u\<^sub>g_def \<theta>\<^sub>g'_def
         by (intro comp_in_homI) auto
       have w\<^sub>g_in_hhom: "in_hhom w\<^sub>g (src u\<^sub>g) (src (tab\<^sub>0 g))"
         unfolding w\<^sub>g_def u\<^sub>g_def by auto
       have w\<^sub>g'_in_hhom: "in_hhom w\<^sub>g' (src u\<^sub>g) (src (tab\<^sub>0 g))"
         unfolding w\<^sub>g'_def u\<^sub>g_def by auto
       have \<beta>\<^sub>g: "\<guillemotleft>\<beta>\<^sub>g : tab\<^sub>1 g \<star> w\<^sub>g \<Rightarrow> tab\<^sub>1 g \<star> w\<^sub>g'\<guillemotright>"
       proof (unfold \<beta>\<^sub>g_def w\<^sub>g_def, intro comp_in_homI)
         (* auto can solve this, but it's too slow *)
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
                  tab\<^sub>1 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
         show "\<guillemotleft>inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1 :
                  (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom f\<^sub>0g\<^sub>1.\<phi>_uniqueness(2)
           by (intro hcomp_in_vhom) auto
         show "\<guillemotleft>\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
                  (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps \<gamma>\<^sub>f w\<^sub>f_def w\<^sub>f'_def by auto
         show "\<guillemotleft>tab\<^sub>0 f \<star> \<gamma>\<^sub>f : tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps \<gamma>\<^sub>f w\<^sub>f_def w\<^sub>f'_def by auto
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
                  tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<Rightarrow> (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           by auto
         show "\<guillemotleft>f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine :
                  (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine
                     \<Rightarrow> ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using f\<^sub>0gh\<^sub>1.\<phi>_in_hom
           by (intro hcomp_in_vhom) auto
         show "\<guillemotleft>\<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] :
                  ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
                     \<Rightarrow> (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           by auto
         show "\<guillemotleft>\<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
                  (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine \<Rightarrow> tab\<^sub>1 g \<star> w\<^sub>g'\<guillemotright>"
           using w\<^sub>g'_def by auto
       qed
       have eq\<^sub>g: "g.composite_cell w\<^sub>g \<theta>\<^sub>g = g.composite_cell w\<^sub>g' \<theta>\<^sub>g' \<cdot> \<beta>\<^sub>g"
       proof -
         have "g.composite_cell w\<^sub>g \<theta>\<^sub>g =
               (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot>
                      (h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      fg\<^sub>0h\<^sub>1.\<phi> \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                 \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1] \<cdot>
                 (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
           unfolding w\<^sub>g_def \<theta>\<^sub>g_def by simp
         also have "... =
                    (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                      (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                      ((g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                      \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]) \<cdot>
                      (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
           using fg gh f\<^sub>0g\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps whisker_left
                 comp_assoc
           by simp
         also have "... =
                    (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                      (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                      (\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]))) \<cdot>
                      \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1] \<cdot>
                      (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
         proof -
           have "(\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                    \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                    (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) =
                 g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
             using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr comp_assoc_assoc' by simp
           thus ?thesis
             by (simp add: comp_assoc)
         qed
         also have "... =
                    (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                      (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                      \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                      \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]) \<cdot>
                      (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
           using comp_assoc by presburger
         also have "... =
                    (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                      (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                      \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                      (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1))"
           using fg gh f\<^sub>0g\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_assoc pentagon'
                 invert_opposite_sides_of_square
                   [of "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1"
                       "(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1])"
                       "\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]" "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]"]
           by simp
         also have "... =
                    (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                      (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                      \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                      ((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps assoc'_naturality [of g.tab Tfg.p\<^sub>0 TTfgh.p\<^sub>1] by simp
         also have "... =
                    (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
                      (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                      (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
                      \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                      (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
                      ((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
                      (f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                      \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                      (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
         proof -
           have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                      \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                      (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] =
                 ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                      (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                      \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
                      (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
             using comp_assoc by presburger
           also have "... = ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                              ((tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
                              (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
             using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps whisker_right comp_assoc_assoc' by simp
           also have "... = ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                              (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
                              \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
             using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_uniqueness comp_cod_arr by simp
           also have "... = ((tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
           proof -
             have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) =
                   f\<^sub>0g\<^sub>1.\<phi> \<cdot> inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1"
               using f\<^sub>0g\<^sub>1.\<phi>_uniqueness whisker_right by simp
             also have "... = (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1"
               using f\<^sub>0g\<^sub>1.\<phi>_uniqueness comp_arr_inv' by simp
             finally show ?thesis by simp
           qed
           also have "... = \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
             using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr by simp
           finally have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                           \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                      \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] = \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = \<theta>\<^sub>f \<cdot>
                            \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                            (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
           unfolding \<theta>\<^sub>f_def using comp_assoc by presburger
         also have "... = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
                            \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                            (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
           using \<gamma>\<^sub>f comp_assoc by simp
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
                            \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                            (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
           unfolding \<theta>\<^sub>f'_def using comp_assoc by presburger
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
                            \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
                            (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
         proof -
           have "(\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) =
                 f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine"
             using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps comp_cod_arr comp_arr_dom comp_assoc_assoc' by simp
           thus ?thesis
             using comp_assoc by fastforce
         qed
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<beta>\<^sub>g"
           unfolding \<beta>\<^sub>g_def using comp_assoc by presburger
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<beta>\<^sub>g"
         proof -
           have "(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                   \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                 \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                   ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
             using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
                   assoc'_naturality [of "(g.tab \<star> Tgh.p\<^sub>1)" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<beta>\<^sub>g"
         proof -
           have "((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                   \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                 \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                   (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
             using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
                   assoc'_naturality [of g.tab Tgh.p\<^sub>1 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
                            \<beta>\<^sub>g"
         proof -
           have "(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                   \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                   (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
                 g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
             using comp_cod_arr comp_assoc_assoc' by simp
           thus ?thesis
             using comp_assoc g\<^sub>0h\<^sub>1.\<phi>_in_hom by simp
         qed
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
                            \<beta>\<^sub>g"
         proof -
           have "(\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
                 (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            ((g \<star> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1)) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
             using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps comp_assoc comp_assoc_assoc' by simp
           also have "... = (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
             using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps comp_cod_arr comp_assoc_assoc' by simp
           also have "... = (((g \<star> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1)) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                              ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
             using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps whisker_right comp_assoc_assoc' by simp
           also have "... = (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine"
             using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps comp_cod_arr by simp
           finally show ?thesis by presburger
         qed
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                   \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
                            \<beta>\<^sub>g"
           using comp_assoc by presburger
         also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            (can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                    \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                    \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                 \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                     \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                       (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                       (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            (\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<beta>\<^sub>g"
         proof -
           have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                 \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                     \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                       (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                       (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
           proof -
             have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                   (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            ((((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
               using comp_assoc by presburger
             also have "... = ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                                \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
                                ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                                \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
             proof -
               have "(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                       ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
                 using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
                       assoc'_naturality [of "g \<star> g\<^sub>0h\<^sub>1.\<phi>" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
                 by simp
               thus ?thesis
                 using comp_assoc by presburger
             qed
             also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                       ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                                ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                                \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
             proof -
               have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                                \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                       ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
                 using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
                       assoc'_naturality [of "g \<star> h.tab \<star> Tgh.p\<^sub>0" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
                 by simp
               thus ?thesis
                 using comp_assoc by presburger
             qed
             also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                       (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                     \<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                       (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
             proof -
               have "((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                       \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                       (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
                 using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
                       assoc'_naturality [of g g\<^sub>0h\<^sub>1.\<phi> "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
                 by simp
               thus ?thesis
                 using comp_assoc by presburger
             qed
             also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                     \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                       (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                       (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
             proof -
               have "((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                     \<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                     \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                       (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
                 using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
                       assoc'_naturality [of g "h.tab \<star> Tgh.p\<^sub>0" "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
                 by simp
               thus ?thesis
                 using comp_assoc by presburger
             qed
             finally show ?thesis by simp
           qed
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = ((g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            (g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                        \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                     (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
                                        \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
                            (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])) \<cdot>
                            \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<beta>\<^sub>g"
         proof -
           have "can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                     (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                 \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                     \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                 g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                         (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
           proof -
             have "\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                   can (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                       ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
             proof -
               have "\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
                     \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
                 using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps canI_associator_0 \<a>'_def \<alpha>_def by simp
               also have "... = can (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                         \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                    ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
                                         \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
                 unfolding can_def
                 using gh
                 apply (intro E.eval_eqI) by simp_all
               finally show ?thesis by blast
             qed
             moreover
             have "\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                   can ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                       (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
             proof -
               have "\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                       \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
                 using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps canI_associator_0 \<a>'_def \<alpha>_def by simp
               also have "... = can ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
                                        \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                    (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
                                        \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
                 unfolding can_def
                 using gh
                 apply (intro E.eval_eqI) by simp_all
               finally show ?thesis by blast
             qed
             ultimately show ?thesis
               using gh whisker_can_left_0 by simp
           qed
           moreover have "\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                          g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
           proof -
             have "\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
                   \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                     \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                     ((\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
                     \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[(\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                     \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                     \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps \<a>'_def \<alpha>_def by simp
             also have "... = \<lbrace>\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
               apply (intro E.eval_eqI) by simp_all
             also have "... = g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
               using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps \<a>'_def \<alpha>_def by simp
             finally show ?thesis by simp
           qed
           ultimately show ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (g \<star>
                            (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                              (can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
                                      \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                   (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
                                      \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
                              ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                              (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                              \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<beta>\<^sub>g"
           using gh whisker_left by auto (* 11 sec *)
         also have "... = g.composite_cell w\<^sub>g' \<theta>\<^sub>g' \<cdot> \<beta>\<^sub>g"
           unfolding w\<^sub>g'_def \<theta>\<^sub>g'_def
           using comp_assoc by presburger
         finally show ?thesis by blast
       qed
       have 6: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>g \<Rightarrow> w\<^sub>g'\<guillemotright> \<and> \<beta>\<^sub>g = tab\<^sub>1 g \<star> \<gamma> \<and> \<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>)"
         using w\<^sub>g w\<^sub>g' \<theta>\<^sub>g \<theta>\<^sub>g' \<beta>\<^sub>g eq\<^sub>g g.T2 [of w\<^sub>g w\<^sub>g' \<theta>\<^sub>g u\<^sub>g \<theta>\<^sub>g' \<beta>\<^sub>g] by blast
       obtain \<gamma>\<^sub>g where \<gamma>\<^sub>g: "\<guillemotleft>\<gamma>\<^sub>g : w\<^sub>g \<Rightarrow> w\<^sub>g'\<guillemotright> \<and> \<beta>\<^sub>g = tab\<^sub>1 g \<star> \<gamma>\<^sub>g \<and> \<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)"
         using 6 by auto
       show "\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "iso \<gamma>\<^sub>g"
           using \<gamma>\<^sub>g BS3 w\<^sub>g_is_map w\<^sub>g'_is_map by blast
         hence "isomorphic w\<^sub>g w\<^sub>g'"
           using \<gamma>\<^sub>g isomorphic_def isomorphic_symmetric by auto
         thus ?thesis
           using w\<^sub>g w\<^sub>g' w\<^sub>g_def w\<^sub>g'_def Maps.CLS_eqI by auto
       qed
 
       text \<open>Now the last equation: similar, but somewhat simpler.\<close>
       define u\<^sub>h where "u\<^sub>h = tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
       define w\<^sub>h where "w\<^sub>h = TTfgh.p\<^sub>0"
       define w\<^sub>h' where "w\<^sub>h' = Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
       define \<theta>\<^sub>h
       where "\<theta>\<^sub>h = tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
       define \<theta>\<^sub>h'
       where "\<theta>\<^sub>h' = TTfgh_TfTgh.the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                  \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
       define \<beta>\<^sub>h
       where "\<beta>\<^sub>h = \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                    (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                    \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                    \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
       have u\<^sub>h: "ide u\<^sub>h"
         unfolding u\<^sub>h_def by simp
       have w\<^sub>h: "ide w\<^sub>h"
         unfolding w\<^sub>h_def by simp
       have w\<^sub>h_is_map: "is_left_adjoint w\<^sub>h"
         unfolding w\<^sub>h_def by simp
       have w\<^sub>h': "ide w\<^sub>h'"
         unfolding w\<^sub>h'_def by simp
       have w\<^sub>h'_is_map: "is_left_adjoint w\<^sub>h'"
         unfolding w\<^sub>h'_def
         using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps TTfgh_TfTgh.is_map left_adjoints_compose by simp
       have \<theta>\<^sub>h: "\<guillemotleft>\<theta>\<^sub>h : tab\<^sub>0 h \<star> w\<^sub>h \<Rightarrow> u\<^sub>h\<guillemotright>"
         unfolding \<theta>\<^sub>h_def w\<^sub>h_def u\<^sub>h_def by auto
       have \<theta>\<^sub>h': "\<guillemotleft>\<theta>\<^sub>h' : tab\<^sub>0 h \<star> w\<^sub>h' \<Rightarrow> u\<^sub>h\<guillemotright>"
         unfolding \<theta>\<^sub>h'_def w\<^sub>h'_def u\<^sub>h_def
         using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps
         by (intro comp_in_homI) auto
       have \<beta>\<^sub>h: "\<guillemotleft>\<beta>\<^sub>h : tab\<^sub>1 h \<star> w\<^sub>h \<Rightarrow> tab\<^sub>1 h \<star> w\<^sub>h'\<guillemotright>"
       proof (unfold \<beta>\<^sub>h_def w\<^sub>h_def w\<^sub>h'_def, intro comp_in_homI)
         (* auto can solve this, but it's too slow *)
         show "\<guillemotleft>inv fg\<^sub>0h\<^sub>1.\<phi> : tab\<^sub>1 h \<star> TTfgh.p\<^sub>0 \<Rightarrow> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.\<phi>_uniqueness by blast
         show "\<guillemotleft>\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
                  (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
         show "\<guillemotleft>tab\<^sub>0 g \<star> \<gamma>\<^sub>g :
                  tab\<^sub>0 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 g \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using \<gamma>\<^sub>g w\<^sub>g_def w\<^sub>g'_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
         show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
                  tab\<^sub>0 g \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
                     \<Rightarrow> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
         show "\<guillemotleft>g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine :
                 (tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
                    \<Rightarrow> (tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by force
         show "\<guillemotleft>\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
                 (tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
                    \<Rightarrow> tab\<^sub>1 h \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
           using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
       qed
       have eq\<^sub>h: "h.composite_cell w\<^sub>h \<theta>\<^sub>h = h.composite_cell w\<^sub>h' \<theta>\<^sub>h' \<cdot> \<beta>\<^sub>h"
       proof -
         text \<open>
           Once again, the strategy is to form the subexpression
           \[
              \<open>\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]\<close>
           \]
           which is equal to \<open>\<theta>\<^sub>g\<close>, so that we can make use of the equation \<open>\<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)\<close>.
         \<close>
         have "h.composite_cell w\<^sub>h \<theta>\<^sub>h =
               (h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0)"
           unfolding w\<^sub>h_def \<theta>\<^sub>h_def by simp
         also have "... = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0)"
         proof -
           have "(h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"
             using comp_cod_arr by simp
           thus ?thesis
             using comp_assoc by metis
         qed
         also have "... = (\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
                            fg\<^sub>0h\<^sub>1.\<phi> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
         proof -
           have "(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi> =
                 (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> ((tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
            using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_assoc_assoc' by simp
           also have "... = (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
            using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps fg\<^sub>0h\<^sub>1.\<phi>_uniqueness comp_cod_arr by simp
           also have "... = (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> (tab\<^sub>1 h \<star> TTfgh.p\<^sub>0)"
            using comp_arr_inv' fg\<^sub>0h\<^sub>1.\<phi>_uniqueness by simp
           also have "... = h.tab \<star> TTfgh.p\<^sub>0"
            using comp_arr_dom fg\<^sub>0h\<^sub>1.p\<^sub>0_simps by simp
           finally have "(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi> =
                         h.tab \<star> TTfgh.p\<^sub>0"
             by simp
           thus ?thesis
             using comp_assoc by simp
         qed
         also have "... = \<theta>\<^sub>g \<cdot> \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
           unfolding \<theta>\<^sub>g_def by simp
         also have "... = (\<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)) \<cdot> \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
           using \<gamma>\<^sub>g by simp
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
           unfolding \<theta>\<^sub>g'_def
           using comp_assoc by presburger
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            ((\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
         proof -
           have "(\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
                  (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
             using comp_cod_arr comp_assoc_assoc' by simp
           thus ?thesis
             using comp_assoc by simp
         qed
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            \<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (\<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
           using comp_assoc by presburger
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                  (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            \<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
           using assoc_naturality [of h.tab Tgh.p\<^sub>0 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"] comp_assoc
           by simp
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                  (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            \<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            ((\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
                            \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
         proof -
           have "(\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
                 h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
             using comp_cod_arr comp_assoc_assoc' by simp
           thus ?thesis
             using comp_assoc by simp
         qed
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            (can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                  (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            (\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            \<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])) \<cdot>
                            \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
           using comp_assoc by presburger
         also have "... = ((h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
                            (h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                     (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))) \<cdot>
                            \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
         proof -
           have "can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                     (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                   (\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                   \<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
                 can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                     (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                   \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                    \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
             using \<a>'_def \<alpha>_def by simp
           also have "... = can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                            can (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
           proof -
             have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                    \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace> =
                   can (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
               unfolding can_def
               apply (intro E.eval_eqI) by simp_all
             thus ?thesis by simp
           qed
           also have "... = can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
             by simp
           also have "... = h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                    (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
             using whisker_can_left_0 by simp
           finally have "can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                             (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
                           (\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                           \<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
                         h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                 (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
             by simp
           thus ?thesis
             using comp_assoc by presburger
         qed
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta> \<cdot>
                               can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                                   (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
                            \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
           using whisker_left [of h] comp_assoc by simp
         also have "... = (h \<star> TTfgh_TfTgh.the_\<theta> \<cdot>
                               \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                               \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
                            \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
                            \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
                            (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
                            \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
                            inv fg\<^sub>0h\<^sub>1.\<phi>"
         proof -
           have "can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                     (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) =
                 \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                  \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
             unfolding can_def
             apply (intro E.eval_eqI) by auto
           also have "... = \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                              \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
             using \<a>'_def \<alpha>_def by simp
           finally have "can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
                             (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) =
                         \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
                           \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
             by simp
           thus ?thesis by simp
         qed
         also have "... = h.composite_cell w\<^sub>h' \<theta>\<^sub>h' \<cdot> \<beta>\<^sub>h"
           unfolding w\<^sub>h'_def \<theta>\<^sub>h'_def \<beta>\<^sub>h_def
           using comp_assoc by presburger
         finally show ?thesis by simp
       qed
       have 7: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>h \<Rightarrow> w\<^sub>h'\<guillemotright> \<and> \<beta>\<^sub>h = tab\<^sub>1 h \<star> \<gamma> \<and> \<theta>\<^sub>h = \<theta>\<^sub>h' \<cdot> (tab\<^sub>0 h \<star> \<gamma>)"
         using w\<^sub>h w\<^sub>h' \<theta>\<^sub>h \<theta>\<^sub>h' \<beta>\<^sub>h eq\<^sub>h h.T2 [of w\<^sub>h w\<^sub>h' \<theta>\<^sub>h u\<^sub>h \<theta>\<^sub>h' \<beta>\<^sub>h] by blast
       obtain \<gamma>\<^sub>h where \<gamma>\<^sub>h: "\<guillemotleft>\<gamma>\<^sub>h : w\<^sub>h \<Rightarrow> w\<^sub>h'\<guillemotright> \<and> \<beta>\<^sub>h = tab\<^sub>1 h \<star> \<gamma>\<^sub>h \<and> \<theta>\<^sub>h = \<theta>\<^sub>h' \<cdot> (tab\<^sub>0 h \<star> \<gamma>\<^sub>h)"
         using 7 by auto
       show "\<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
       proof -
         have "iso \<gamma>\<^sub>h"
           using \<gamma>\<^sub>h BS3 w\<^sub>h_is_map w\<^sub>h'_is_map by blast
         hence "isomorphic w\<^sub>h w\<^sub>h'"
           using \<gamma>\<^sub>h isomorphic_def isomorphic_symmetric by auto
         thus ?thesis
           using w\<^sub>h w\<^sub>h' w\<^sub>h_def w\<^sub>h'_def Maps.CLS_eqI [of w\<^sub>h w\<^sub>h'] by simp
       qed
     qed
 
     text \<open>
       Finally, we can show that @{term TTfgh_TfTgh.chine} is given by tupling.
     \<close>
 
     lemma CLS_chine:
     shows "\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = tuple_ABC"
     proof -
       have "tuple_ABC = SPN_fgh.chine_assoc"
         using SPN_fgh.chine_assoc_def by simp
       also have "... = \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
       proof (intro Maps.arr_eqI)
         show "Maps.arr SPN_fgh.chine_assoc"
           using SPN_fgh.chine_assoc_in_hom by auto
         show "Maps.arr \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
           using Maps.CLS_in_hom TTfgh_TfTgh.is_map by blast
         show "Maps.Dom SPN_fgh.chine_assoc = Maps.Dom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
           using SPN_fgh.chine_assoc_def Maps.dom_char tuple_ABC_in_hom TTfgh_TfTgh.chine_in_hom
           by fastforce
         show "Maps.Cod SPN_fgh.chine_assoc = Maps.Cod \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
         proof - 
           have "Maps.Cod SPN_fgh.chine_assoc = Maps.Cod tuple_ABC"
             using SPN_fgh.chine_assoc_def by simp
           also have "... = src (prj\<^sub>0 (tab\<^sub>1 g \<star> prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)) (tab\<^sub>0 f))"
             by (metis (lifting) Maps.Dom.simps(1) Maps.seq_char SPN_fgh.prj_chine_assoc(1)
                 SPN_fgh.prj_simps(1) calculation f\<^sub>0gh\<^sub>1.leg1_simps(3) prj_char(4))
           also have "... = Maps.Cod \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
             using Maps.cod_char TTfgh_TfTgh.chine_in_hom by simp
           finally show ?thesis by blast
         qed
         show "Maps.Map SPN_fgh.chine_assoc = Maps.Map \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
         proof -
           have 0: "Chn (Span.hcomp (SPN f) (Span.hcomp (SPN g) (SPN h))) =
                    Maps.MkIde (src TfTgh.p\<^sub>0)"
             using fg gh
             by (metis (mono_tags, lifting) Maps.in_homE Maps.seqE SPN_fgh.prj_chine_assoc(1)
                 SPN_fgh.prj_simps(1) SPN_fgh.prj_simps(13) calculation tuple_ABC_in_hom)
           have "tuple_ABC = \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
           proof (intro Maps.prj_joint_monic
                          [of SPN_fgh.\<mu>.leg0 "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1"
                              tuple_ABC "\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"])
             show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
               using SPN_fgh.\<nu>\<pi>.dom.is_span SPN_fgh.\<nu>\<pi>.leg1_composite SPN_fgh.cospan_\<mu>\<nu>
               by auto
             show "Maps.seq SPN_fgh.Prj\<^sub>1 tuple_ABC"
               using 0 tuple_ABC_in_hom SPN_fgh.prj_in_hom(4) by auto
             show "Maps.seq SPN_fgh.Prj\<^sub>1 \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
             proof
               show "Maps.in_hom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
                                 \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                 using fg gh TTfgh_TfTgh.chine_in_hom Maps.CLS_in_hom TTfgh_TfTgh.is_map
                 by blast
               show "Maps.in_hom SPN_fgh.Prj\<^sub>1 \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> SPN_fgh.\<mu>.apex"
               proof
                 show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                   using SPN_fgh.prj_in_hom(4) by blast
                 show "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
                       Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                 proof -
                   have "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = Maps.MkIde (src TfTgh.p\<^sub>0)"
                     by simp
                   also have "... = Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                     using 0 Maps.pbdom_def SPN_fgh.chine_composite(2) by presburger
                   finally show ?thesis by blast
                 qed
                 show "SPN_fgh.\<mu>.apex = Maps.dom SPN_fgh.\<mu>.leg0"
                   using SPN_f.dom.apex_def by blast
               qed
             qed
             have 2: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
                                              SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
             proof
               show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
                 using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
               show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
                 using SPN_fgh.prj_simps(2-3,5-6) by presburger
               show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
                 using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
                 by auto
               show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
                 by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
                     Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
                     SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
             qed
             have 1: "Maps.commutative_square
                        SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
                        SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
             proof
               show "Maps.cospan SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                 using fg gh SPN_fgh.prj_simps(10) by blast
               show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
                 using fg gh csq(2) by blast
               show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
                 using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
               show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 =
                     (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
                 using 2 fg gh Maps.comp_assoc csq(2)
                       Maps.prj_tuple [of SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0]
                 by blast
             qed
             show "SPN_fgh.Prj\<^sub>1 \<odot> tuple_ABC = SPN_fgh.Prj\<^sub>1 \<odot> Maps.CLS TTfgh_TfTgh.chine"
             proof -
               have "SPN_fgh.Prj\<^sub>1 \<odot> tuple_ABC = SPN_fgh.Prj\<^sub>1\<^sub>1"
                 using csq(2) by simp
               also have "... = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
                 using prj_char by simp
               also have "... = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                 using prj_chine(1) by simp
               also have "... = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
               proof -
                 have "is_left_adjoint TfTgh.p\<^sub>1"
                   by (simp add: fg)
                 moreover have "is_left_adjoint TTfgh_TfTgh.chine"
                   using TTfgh_TfTgh.is_map by simp
                 moreover have "TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<cong> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
                   using fg gh isomorphic_reflexive by simp
                 ultimately show ?thesis
                   using Maps.comp_CLS
                           [of TfTgh.p\<^sub>1 TTfgh_TfTgh.chine "TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"]
                   by simp
               qed
               also have "... = SPN_fgh.Prj\<^sub>1 \<odot> Maps.CLS TTfgh_TfTgh.chine"
                 using prj_char by simp
               finally show ?thesis by blast
             qed
             show
               "Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_ABC =
                Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                  \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
             proof -
               have
                 "Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_ABC =
                  tuple_BC"
                 using csq(2)
                       Maps.prj_tuple [of SPN_fgh.\<mu>.leg0 "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1"
                                          SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC]
                 by simp
               also have "... =
                          Maps.comp
                            (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1))
                            \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
               proof (intro Maps.prj_joint_monic
                              [of SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 tuple_BC
                                  "Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                                     \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"])
                 show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
                   using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
                 show "Maps.seq SPN_fgh.\<nu>\<pi>.prj\<^sub>1 tuple_BC"
                 proof
                   show "Maps.in_hom tuple_BC
                                     (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.p\<^sub>0))"
                     using tuple_BC_in_hom by simp
                   show "Maps.in_hom SPN_fgh.\<nu>\<pi>.prj\<^sub>1 (Maps.MkIde (src Tgh.p\<^sub>0)) SPN_fgh.\<nu>.apex"
                   proof -
                     have "Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 = Maps.MkIde (src Tgh.p\<^sub>0)"
                       using fg gh Maps.pbdom_def
                       by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
                           SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tgh.chine_hcomp_SPN_SPN
                           g.is_ide)
                     thus ?thesis
                       using SPN_fgh.\<nu>\<pi>.prj_in_hom(1) by simp
                   qed
                 qed
                 show "Maps.seq SPN_fgh.\<nu>\<pi>.prj\<^sub>1
                                (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                                   \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>)"
                 proof
                   show "Maps.in_hom SPN_fgh.\<nu>\<pi>.prj\<^sub>1
                                     (Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1) SPN_fgh.\<nu>.apex"
                     using SPN_fgh.\<nu>\<pi>.prj_in_hom(1) by simp
                   show "Maps.in_hom
                          (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                              \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>)
                          \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
                          (Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1)"
                   proof
                     show "Maps.in_hom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
                                       \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh TTfgh_TfTgh.chine_in_hom Maps.CLS_in_hom TTfgh_TfTgh.is_map
                       by blast
                     show "Maps.in_hom
                            (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1))
                            \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
                            (Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1)"
                     proof
                       show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                         using SPN_fgh.prj_in_hom(4) by blast
                       show "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
                             Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                       proof -
                         have "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = Maps.MkIde (src TfTgh.p\<^sub>0)"
                           by simp
                         also have "... = Maps.pbdom SPN_fgh.\<mu>.leg0
                                                     (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                           using 0 Maps.pbdom_def SPN_fgh.chine_composite(2) by presburger
                         finally show ?thesis by blast
                       qed
                       show "Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 =
                             Maps.dom (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
                         using fg gh Maps.pbdom_def SPN_fgh.\<nu>\<pi>.apex_composite
                               SPN_fgh.\<nu>\<pi>.dom.apex_def SPN_fgh.\<nu>\<pi>.dom.is_span
                               SPN_fgh.\<nu>\<pi>.leg1_composite
                         by presburger
                     qed
                   qed
                 qed
                 show "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot> tuple_BC =
                       SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
                         Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                         \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                 proof - 
                   have "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot> tuple_BC = SPN_fgh.Prj\<^sub>0"
                     using csq(1) by simp
                   also have "... = SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
                                      Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                                      \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                   proof -
                     have "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
                             Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                             \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
                           \<lbrakk>\<lbrakk>Tgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char(1) isomorphic_reflexive
                             Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.p\<^sub>1"]
                       by simp
                     also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh TTfgh_TfTgh.is_map isomorphic_reflexive
                             Maps.comp_CLS
                               [of TfTgh.p\<^sub>0 TTfgh_TfTgh.chine "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
                       by simp
                     also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh TTfgh_TfTgh.is_map left_adjoints_compose isomorphic_reflexive
                             Maps.comp_CLS [of Tgh.p\<^sub>0 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
                                            "Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
                       by simp
                     also have "... = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
                       using prj_chine(3) by simp
                     also have "... = SPN_fgh.Prj\<^sub>0"
                       using prj_char by simp
                     finally show ?thesis by argo
                   qed
                   finally show ?thesis by blast
                 qed
                 show "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot> tuple_BC =
                       SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
                         Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                         \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                 proof -
                   have "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot> tuple_BC = SPN_fgh.Prj\<^sub>0\<^sub>1"
                     using csq(1) by simp
                   also have "... = SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
                                      Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                                       \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                   proof -
                     have "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
                             Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
                              \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
                           \<lbrakk>\<lbrakk>Tgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char(1) isomorphic_reflexive
                             Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.p\<^sub>1"]
                       by simp
                     also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh TTfgh_TfTgh.is_map isomorphic_reflexive
                             Maps.comp_CLS
                               [of TfTgh.p\<^sub>0 TTfgh_TfTgh.chine "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
                       by simp
                     also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
                       using fg gh TTfgh_TfTgh.is_map left_adjoints_compose isomorphic_reflexive
                             Maps.comp_CLS [of Tgh.p\<^sub>1 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
                                          "Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
                       by simp
                     also have "... = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
                       using prj_chine(2) by simp
                     also have "... = SPN_fgh.Prj\<^sub>0\<^sub>1"
                       using prj_char by simp
                     finally show ?thesis by argo
                   qed
                   finally show ?thesis by blast
                 qed
               qed
               finally show ?thesis by simp
             qed
           qed
           thus ?thesis
             using SPN_fgh.chine_assoc_def by simp
         qed
       qed
       finally show ?thesis by simp
     qed
 
     text \<open>
       At long last, we can show associativity coherence for \<open>SPN\<close>.
     \<close>
 
     lemma assoc_coherence:
     shows "LHS = RHS"
     proof (intro Span.arr_eqI)
       show "Span.par LHS RHS"
         using par_LHS_RHS by blast
       show "Chn LHS = Chn RHS"
       proof -
         have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
           using Chn_LHS_eq by simp
         also have "... = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
         proof -
           have "\<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
                 \<lbrakk>\<lbrakk>THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
             using fg gh isomorphic_reflexive HHfgh_HfHgh.is_map THfgh_HHfgh.is_map
                   TTfgh_THfgh.is_map left_adjoints_compose
                   Maps.comp_CLS
                     [of THfgh_HHfgh.chine TTfgh_THfgh.chine "THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"]
             by simp
           moreover
           have "\<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
                 \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
           proof -
             have "ide (HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
             proof -
               have "ide (THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"  
                 using fg gh HHfgh_HfHgh.is_map THfgh_HHfgh.is_map TTfgh_THfgh.is_map
                       left_adjoint_is_ide left_adjoints_compose
                 by auto
               moreover have "src HHfgh_HfHgh.chine = trg (THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
                 using fg gh HHfgh_HfHgh.chine_in_hom \<alpha>_def by auto
               ultimately show ?thesis by simp
             qed
             thus ?thesis
               using fg gh isomorphic_reflexive HHfgh_HfHgh.is_map THfgh_HHfgh.is_map
                     TTfgh_THfgh.is_map left_adjoints_compose
                     Maps.comp_CLS
                       [of HHfgh_HfHgh.chine "THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"
                           "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"]
               by auto
           qed
           ultimately show ?thesis by argo
         qed
         also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
         proof -
           interpret A: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
                          \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
                          \<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
                          \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
                          \<open>\<a>[f, g, h]\<close> \<open>f \<star> g \<star> h\<close>
             ..
           interpret B: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
                          \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
                          \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
                          \<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
                          \<open>\<a>[f, g, h]\<close> \<open>f \<star> g \<star> h\<close>
             using fg gh by unfold_locales auto
           interpret C: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
                          \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
                          \<open>(f \<star> g) \<star> h\<close> HHfgh.tab \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
                          \<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
                          \<open>(f \<star> g) \<star> h\<close> \<open>\<a>[f, g, h]\<close>
             using fg gh by unfold_locales auto
           interpret D: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
                          \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
                          \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
                          \<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
                          \<open>(f \<star> g) \<star> h\<close> \<open>\<a>[f, g, h]\<close>
             using fg gh by unfold_locales auto
           have "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine \<cong> D.chine"
           proof -
             have "D.chine \<cong> D.\<pi>.chine \<star> TTfgh_THfgh.chine"
               using D.chine_char by simp
             also have "... \<cong> C.chine \<star> TTfgh_THfgh.chine"
               using fg gh comp_arr_dom isomorphic_reflexive by simp
             also have "... \<cong> (C.\<pi>.chine \<star> THfgh_HHfgh.chine) \<star> TTfgh_THfgh.chine"
               using C.chine_char hcomp_isomorphic_ide by simp
             also have "... \<cong> (HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine) \<star> TTfgh_THfgh.chine"
             proof -
               have "C.\<pi>.chine = HHfgh_HfHgh.chine"
                 using fg gh comp_arr_dom comp_cod_arr \<alpha>_def by simp
               hence "isomorphic C.\<pi>.chine HHfgh_HfHgh.chine"
                 using isomorphic_reflexive by simp
               thus ?thesis
                 using hcomp_isomorphic_ide by simp
             qed
             also have "... \<cong> HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"
             proof -
               have "ide HHfgh_HfHgh.chine \<and> ide THfgh_HHfgh.chine \<and> ide TTfgh_THfgh.chine"
                 by simp
               moreover have "src HHfgh_HfHgh.chine = trg THfgh_HHfgh.chine \<and>
                              src THfgh_HHfgh.chine = trg TTfgh_THfgh.chine"
                 using fg gh HHfgh_HfHgh.chine_in_hom THfgh_HHfgh.chine_in_hom 
                       TTfgh_THfgh.chine_in_hom \<alpha>_def
                  by auto
               ultimately show ?thesis
                 using fg gh iso_assoc isomorphic_def
                        assoc_in_hom [of HHfgh_HfHgh.chine THfgh_HHfgh.chine TTfgh_THfgh.chine]
                 by auto
             qed
             finally show ?thesis
               using isomorphic_symmetric by blast
           qed
           also have "... \<cong> B.chine"
           proof -
             have "D.chine = B.chine"
               using fg gh comp_arr_dom comp_cod_arr by simp
             thus ?thesis
               using isomorphic_reflexive by simp
           qed
           also have "... \<cong> TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
           proof -
             have "B.chine \<cong> TfHgh_HfHgh.chine \<star> B.\<mu>.chine"
               using B.chine_char by simp
             also have "... \<cong> TfHgh_HfHgh.chine \<star> A.chine"
                 using fg gh comp_cod_arr isomorphic_reflexive by simp
             also have "... \<cong> TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
               using A.chine_char hcomp_ide_isomorphic by simp
             finally show ?thesis by blast
           qed
           finally have "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine \<cong>
                         TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
             by blast
           thus ?thesis
             using fg gh Maps.CLS_eqI isomorphic_implies_hpar(1) by blast
         qed
         also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
           using fg gh isomorphic_reflexive TfTgh_TfHgh.is_map TfHgh_HfHgh.is_map TTfgh_TfTgh.is_map
                 left_adjoints_compose
                 Maps.comp_CLS
                   [of TfTgh_TfHgh.chine TTfgh_TfTgh.chine "TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"]
                 Maps.comp_CLS
                   [of TfHgh_HfHgh.chine "TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
                       "TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"]
           by simp
         also have "... = Chn RHS"
           using Chn_RHS_eq CLS_chine tuple_ABC_eq_ABC'(2) by simp
         finally show ?thesis
           by blast
       qed
     qed
 
   end
 
   subsubsection "SPN is an Equivalence Pseudofunctor"
 
   context bicategory_of_spans
   begin
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp (infixr "\<odot>" 55)
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation SPN: "functor" V Span.vcomp SPN
       using SPN_is_functor by simp
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
       using SPN_is_weak_arrow_of_homs by simp
     interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
                                 SPN.FF \<open>\<lambda>\<mu>\<nu>. Span.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
       ..
     interpretation SPNoH: composite_functor VV.comp V Span.vcomp
                             \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
       ..
 
     interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
       using compositor_is_natural_transformation by simp
     interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<Phi>.map
       using compositor_is_natural_isomorphism by simp
 
     abbreviation \<Phi>
     where "\<Phi> \<equiv> \<Phi>.map"
 
     interpretation SPN: pseudofunctor V H \<a> \<i> src trg
                         Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>
     proof
       show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
                     SPN \<a>[f, g, h] \<bullet> \<Phi> (f \<star> g, h) \<bullet> (\<Phi> (f, g) \<circ> SPN h) =
                     \<Phi> (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi> (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h)"
       proof -
         fix f g h
         assume f: "ide f" and g: "ide g" and h: "ide h"
         assume fg: "src f = trg g" and gh: "src g = trg h"
         interpret fgh: three_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g h
           using f g h fg gh
           by (unfold_locales, simp)
         show "fgh.LHS = fgh.RHS"
           using fgh.assoc_coherence by simp
       qed
     qed
 
     lemma SPN_is_pseudofunctor:
     shows "pseudofunctor V H \<a> \<i> src trg
              Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>"
       ..
 
     interpretation SPN: equivalence_pseudofunctor V H \<a> \<i> src trg
                         Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>
     proof
       show "\<And>\<mu> \<mu>'. \<lbrakk>par \<mu> \<mu>'; SPN \<mu> = SPN \<mu>'\<rbrakk> \<Longrightarrow> \<mu> = \<mu>'"
       proof -
         fix \<mu> \<mu>'
         assume par: "par \<mu> \<mu>'"
         assume eq: "SPN \<mu> = SPN \<mu>'"
         interpret dom_\<mu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close>
           using par apply unfold_locales by auto
         interpret cod_\<mu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod \<mu>\<close>
           using par apply unfold_locales by auto
         interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                        \<open>dom \<mu>\<close> \<open>tab_of_ide (dom \<mu>)\<close> \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
                        \<open>cod \<mu>\<close> \<open>tab_of_ide (cod \<mu>)\<close> \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
                        \<mu>
           using par apply unfold_locales by auto
         interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
           using par apply unfold_locales by auto
         interpret \<mu>': arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         \<open>dom \<mu>\<close> \<open>tab_of_ide (dom \<mu>)\<close> \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
                         \<open>cod \<mu>\<close> \<open>tab_of_ide (cod \<mu>)\<close> \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
                         \<mu>'
           using par apply unfold_locales by auto
         interpret \<mu>': arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>'
           using par apply unfold_locales by auto
         have "\<mu>.chine \<cong> \<mu>'.chine"
           using par eq SPN_def spn_def Maps.CLS_eqI \<mu>.is_ide by auto
         hence "\<mu>.\<Delta> = \<mu>'.\<Delta>"
           using \<mu>.\<Delta>_naturality \<mu>'.\<Delta>_naturality
           by (metis \<mu>.\<Delta>_simps(4) \<mu>'.\<Delta>_simps(4) \<mu>.chine_is_induced_map \<mu>'.chine_is_induced_map
               \<mu>.induced_map_preserved_by_iso)
         thus "\<mu> = \<mu>'"
           using par \<mu>.\<mu>_in_terms_of_\<Delta> \<mu>'.\<mu>_in_terms_of_\<Delta> by metis
       qed
       show "\<And>a'. Span.obj a' \<Longrightarrow> \<exists>a. obj a \<and> Span.equivalent_objects (SPN.map\<^sub>0 a) a'"
       proof -
         fix a'
         assume a': "Span.obj a'"
         let ?a = "Maps.Dom (Chn a')"
         have a: "obj ?a"
-          using a' Span.obj_char Span.ide_char Maps.ide_char by blast
+          using a' Span.obj_char Span.ide_char Maps.ide_char\<^sub>C\<^sub>C by blast
         moreover have "Span.equivalent_objects (SPN.map\<^sub>0 ?a) a'"
         proof -
           have "SPN.map\<^sub>0 ?a = a'"
           proof (intro Span.arr_eqI)
             have "Chn (SPN.map\<^sub>0 ?a) = Chn (Span.src (SPN ?a))"
               using a a' by auto
             also have "... = Maps.MkIde (Maps.Dom (Chn a'))"
             proof -
               have "Maps.arr \<lbrakk>\<lbrakk>tab\<^sub>0 (dom (Maps.Dom (Chn a')))\<rbrakk>\<rbrakk>"
               proof -
                 have "is_left_adjoint (tab\<^sub>0 (dom (Maps.Dom (Chn a'))))"
                   using a by auto
                 thus ?thesis
                   using Maps.CLS_in_hom by auto
               qed
               moreover have "arr (Maps.Dom (Chn a'))"
                 using a by auto
               moreover have "Span.arr (SPN (Maps.Dom (Chn a')))"
                 using a a' SPN_in_hom by auto
               ultimately show ?thesis
                 using a a' SPN_def Span.src_def Maps.cod_char obj_simps(2) by simp
             qed
             also have "... = Chn a'"
               using a' Maps.MkIde_Dom Span.obj_char Span.ide_char by simp
             finally show "Chn (SPN.map\<^sub>0 ?a) = Chn a'" by simp
             show "Span.par (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) a'"
               using a a' Span.obj_char
               apply (intro conjI)
               using SPN.map\<^sub>0_simps(1) Span.obj_def
                  apply blast
                 apply simp
                apply (metis (no_types, lifting) SPN.map\<^sub>0_def SPN.preserves_arr Span.obj_src
                   \<open>Chn (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) = Chn a'\<close> obj_def)
               by (metis (no_types, lifting) SPN.map\<^sub>0_def SPN.preserves_arr Span.obj_src
                   \<open>Chn (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) = Chn a'\<close> obj_def)
           qed
           thus ?thesis
             using Span.equivalent_objects_reflexive
             by (simp add: a')
         qed
         ultimately show "\<exists>a. obj a \<and> Span.equivalent_objects (SPN.map\<^sub>0 a) a'"
           by auto
       qed
       show "\<And>a b g. \<lbrakk>obj a; obj b; Span.in_hhom g (SPN.map\<^sub>0 a) (SPN.map\<^sub>0 b); Span.ide g\<rbrakk>
                        \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> Span.isomorphic (SPN f) g"
       proof -
         fix a b g
         assume a: "obj a" and b: "obj b"
         and g_in_hhom: "Span.in_hhom g (SPN.map\<^sub>0 a) (SPN.map\<^sub>0 b)"
         and ide_g: "Span.ide g"
         have arr_a: "arr a"
           using a by auto
         have arr_b: "arr b"
          using b by auto
         show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> Span.isomorphic (SPN f) g"
         proof -
           interpret g: arrow_of_spans Maps.comp g
             using ide_g Span.ide_char by blast
           interpret g: identity_arrow_of_spans Maps.comp g
             using ide_g Span.ide_char
             by unfold_locales auto
           interpret REP_leg0: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP g.leg0\<close>
             using Maps.REP_in_Map [of g.leg0]
             by unfold_locales auto
           have 0: "\<guillemotleft>Maps.REP g.leg0 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg0\<guillemotright>"
             using g.dom.leg_in_hom Maps.REP_in_hhom
             by (metis (no_types, lifting) Maps.Dom_cod Maps.REP_simps(2) Maps.arr_cod
                 g.dom.leg_simps(1))
           have 1: "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
             using g.dom.leg_in_hom Maps.REP_in_hhom
             by (metis (no_types, lifting) Maps.Dom_cod Maps.REP_simps(2) Maps.arr_cod
                 g.dom.leg_simps(3))
           let ?f = "Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*"
           have f_in_hhom: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
           proof
             show "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> b\<guillemotright>"
             proof -
               have "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
                 using 1 by simp
               moreover have "Maps.Cod g.leg1 = b"
               proof -
                 have "src (Maps.REP g.dtrg) = src (Maps.REP (Leg0 (Dom (SPN.map\<^sub>0 b))))"
                   using g_in_hhom Span.trg_def [of g] by auto
                 also have "... = src (Maps.REP (Maps.cod \<lbrakk>\<lbrakk>tab\<^sub>0 b\<rbrakk>\<rbrakk>))"
                   using b arr_b SPN.map\<^sub>0_def Span.src_def SPN_in_hom by auto
                 also have "... = src (Maps.REP \<lbrakk>\<lbrakk>trg (tab\<^sub>0 b)\<rbrakk>\<rbrakk>)"
                   using b Maps.CLS_in_hom [of "tab\<^sub>0 b"] by force
                 also have "... = src (Maps.REP \<lbrakk>\<lbrakk>b\<rbrakk>\<rbrakk>)"
                   using b by fastforce
                 also have "... = b"
                   using b obj_simps by auto
                 finally show ?thesis by simp
               qed
               ultimately show ?thesis by argo
             qed
             show "\<guillemotleft>(Maps.REP g.leg0)\<^sup>* : a \<rightarrow> src (Maps.REP g.apex)\<guillemotright>"
             proof -
               have "\<guillemotleft>Maps.REP g.leg0 : src (Maps.REP g.apex) \<rightarrow> a\<guillemotright>"
               proof -
                 have "src (Maps.REP g.dsrc) = src (Maps.REP (Leg0 (Dom (SPN.map\<^sub>0 a))))"
                   using g_in_hhom Span.src_def [of g] by auto
                 also have "... = src (Maps.REP (Maps.cod \<lbrakk>\<lbrakk>tab\<^sub>0 a\<rbrakk>\<rbrakk>))"
                   using a arr_a SPN.map\<^sub>0_def Span.src_def SPN_in_hom by auto
                 also have "... = src (Maps.REP \<lbrakk>\<lbrakk>trg (tab\<^sub>0 a)\<rbrakk>\<rbrakk>)"
                   using a Maps.CLS_in_hom [of "tab\<^sub>0 a"] by force
                 also have "... = src (Maps.REP \<lbrakk>\<lbrakk>a\<rbrakk>\<rbrakk>)"
                   using a by fastforce
                 also have "... = a"
                   using a obj_simps by auto
                 finally show ?thesis by fast
               qed
               thus ?thesis
                 using REP_leg0.antipar REP_leg0.ide_right
                 apply (intro in_hhomI) by auto
             qed
           qed
           moreover have ide_f: "ide ?f"
             using REP_leg0.antipar f_in_hhom by fastforce
           moreover have "Span.isomorphic (SPN ?f) g"
           proof -
             have SPN_f_eq: "SPN ?f = \<lparr>Chn = \<lbrakk>\<lbrakk>spn ?f\<rbrakk>\<rbrakk>,
                                       Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>\<rparr>,
                                       Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>\<rparr>\<rparr>"
               using calculation(1) SPN_def [of ?f] REP_leg0.antipar by auto
             text \<open>
               We need an invertible arrow of spans from \<open>SPN f\<close> to \<open>g\<close>.
               There exists a tabulation \<open>(REP g.leg0, \<rho>, REP g.leg1)\<close> of \<open>f\<close>.
               There is also a tabulation \<open>(tab\<^sub>0 f, \<rho>', tab\<^sub>1 f) of f\<close>.
               As these are tabulations of the same arrow, they are equivalent.
               This yields an equivalence map which is an arrow of spans from
               \<open>(tab\<^sub>0 f, tab\<^sub>1 f)\<close> to \<open>(REP g.leg0, \<rho>, REP g.leg1)\<close>.
               Its isomorphism class is an invertible arrow of spans in maps
               from \<open>(CLS (tab\<^sub>0 f), CLS (tab\<^sub>1 f))\<close> to \<open>(g.leg0, g.leg1)\<close>.
             \<close>
             interpret f: identity_in_bicategory_of_spans V H \<a> \<i> src trg ?f
               using ide_f apply unfold_locales by auto
             interpret f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                            ?f f.tab \<open>tab\<^sub>0 ?f\<close> \<open>tab\<^sub>1 ?f\<close> ?f f.tab \<open>tab\<^sub>0 ?f\<close> \<open>tab\<^sub>1 ?f\<close> ?f
               using f.is_arrow_of_tabulations_in_maps by simp
             interpret g: span_of_maps V H \<a> \<i> src trg \<open>Maps.REP g.leg0\<close> \<open>Maps.REP g.leg1\<close>
               using Span.arr_char
               by (unfold_locales, blast+)
 
             have 2: "src (Maps.REP g.leg0) = src (Maps.REP g.leg1)"
               using 0 1 by fastforce
             hence "\<exists>\<rho>. tabulation (\<cdot>) (\<star>) \<a> \<i> src trg ?f \<rho> (Maps.REP g.leg0) (Maps.REP g.leg1)"
               using BS2' [of "Maps.REP g.leg0" "Maps.REP g.leg1" ?f] isomorphic_reflexive
                     Span.arr_char
               by auto
             hence "tabulation V H \<a> \<i> src trg ?f
                      (REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f) (Maps.REP g.leg0) (Maps.REP g.leg1)"
               using 2 REP_leg0.canonical_tabulation [of "Maps.REP g.leg1"] by auto
             hence 3: "\<exists>w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
                         equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
                         \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
                         \<guillemotleft>w' : src (Maps.REP g.leg0) \<rightarrow> src (tab\<^sub>0 ?f)\<guillemotright> \<and>
                         \<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
                         \<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                         f.tab = (?f \<star> \<theta>) \<cdot> \<a>[?f, Maps.REP g.leg0, w] \<cdot>
                                   (REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f \<star> w) \<cdot> \<nu> \<and>
                         \<guillemotleft>\<theta>' : tab\<^sub>0 ?f \<star> w' \<Rightarrow> Maps.REP g.leg0\<guillemotright> \<and>
                         \<guillemotleft>\<nu>' : Maps.REP g.leg1 \<Rightarrow> tab\<^sub>1 ?f \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
                         REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f =
                         (?f \<star> \<theta>') \<cdot> \<a>[?f, tab\<^sub>0 ?f, w'] \<cdot> (f.tab \<star> w') \<cdot> \<nu>'"
                           using f.apex_unique_up_to_equivalence
                                   [of "REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f"
                                       "Maps.REP g.leg0" "Maps.REP g.leg1"]
               by simp
             obtain w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
               where 4: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
                         \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
                         \<guillemotleft>w' : src (Maps.REP g.leg0) \<rightarrow> src (tab\<^sub>0 ?f)\<guillemotright> \<and>
                         \<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
                         \<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
                         f.tab = (?f \<star> \<theta>) \<cdot> \<a>[?f, Maps.REP g.leg0, w] \<cdot>
                                   (REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f \<star> w) \<cdot> \<nu> \<and>
                         \<guillemotleft>\<theta>' : tab\<^sub>0 ?f \<star> w' \<Rightarrow> Maps.REP g.leg0\<guillemotright> \<and>
                         \<guillemotleft>\<nu>' : Maps.REP g.leg1 \<Rightarrow> tab\<^sub>1 ?f \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
                         REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f =
                         (?f \<star> \<theta>') \<cdot> \<a>[?f, tab\<^sub>0 ?f, w'] \<cdot> (f.tab \<star> w') \<cdot> \<nu>'"
               using 3 by meson
             hence w\<theta>\<nu>: "equivalence_map w \<and> \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
                         \<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
                         \<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu>"
               using equivalence_map_def quasi_inverses_def quasi_inverses_symmetric
               by meson
             let ?W = "\<lparr>Chn = \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>, Dom = Dom (SPN ?f), Cod = Dom g\<rparr>"
             have W_in_hom: "Span.in_hom ?W (SPN ?f) g"
             proof
               have "arrow_of_spans Maps.comp ?W"
               proof
                 interpret Dom_W: span_in_category Maps.comp \<open>Dom ?W\<close>
                 proof (unfold_locales, intro conjI)
                   show "Maps.arr (Leg0 (Dom ?W))"
-                    apply (intro Maps.arrI)
+                    apply (intro Maps.arrI\<^sub>C\<^sub>C)
                        apply auto
                     by (metis f.base_simps(2) f.satisfies_T0 f.u_in_hom src_hcomp)
                   show "Maps.arr (Leg1 (Dom ?W))"
                     using 1
-                    apply (intro Maps.arrI)
+                    apply (intro Maps.arrI\<^sub>C\<^sub>C)
                        apply auto
                   proof -
                     let ?f = "tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
                     assume 1: "\<guillemotleft>Maps.REP g.leg1 : Maps.Dom g.apex \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
                     have "\<guillemotleft>?f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
                                    \<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
                           is_left_adjoint ?f \<and> \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>?f\<rbrakk>"
                       using 1 by simp
                     thus "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
                                    \<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
                               is_left_adjoint f \<and>
                               \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>f\<rbrakk>"
                       by blast
                   qed
                   show "Maps.dom (Leg0 (Dom ?W)) = Maps.dom (Leg1 (Dom ?W))"
                   proof -
                     have "Maps.dom (Leg0 (Dom ?W)) =
                           Maps.MkIde (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))"
                       using Maps.dom_char
                       apply simp
                       by (metis (no_types, lifting) Maps.CLS_in_hom Maps.in_homE f.base_simps(2)
                           f.satisfies_T0 f.u_simps(3) hcomp_simps(1))
                     also have "... = Maps.dom (Leg1 (Dom ?W))"
                       using Maps.dom_char Maps.CLS_in_hom f.leg1_is_map f_in_hhom
                       apply simp
                       by (metis (no_types, lifting) Maps.in_homE Maps.REP_simps(3) f.base_simps(2)
                           f.leg1_is_map f.leg1_simps(3) f.leg1_simps(4) g.dom.leg_simps(3)
                           trg_hcomp)
                     finally show ?thesis by blast
                   qed
                 qed
                 show "Maps.span (Leg0 (Dom ?W)) (Leg1 (Dom ?W))"
                   using Dom_W.span_in_category_axioms Dom_W.is_span by blast
                 interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
                   apply unfold_locales by fastforce
                 show "Maps.span (Leg0 (Cod ?W)) (Leg1 (Cod ?W))"
                   by fastforce
                 show "Maps.in_hom (Chn ?W) Dom_W.apex Cod_W.apex"
                 proof
                   show 1: "Maps.arr (Chn ?W)"
                     using w\<theta>\<nu> Maps.CLS_in_hom [of w] equivalence_is_adjoint by auto
                   show "Maps.dom (Chn ?W) = Dom_W.apex"
                   proof -
                     have "Maps.dom (Chn ?W) = Maps.MkIde (src w)"
                       using 1 w\<theta>\<nu> Maps.dom_char by simp
                     also have "... = Dom_W.apex"
                     proof -
                       have "src w = src (tab\<^sub>0 ?f)"
                         using w\<theta>\<nu> by blast
                       thus ?thesis
                         using Dom_W.apex_def Maps.arr_char Maps.dom_char
                         apply simp
                         by (metis (no_types, lifting) f.base_simps(2) f.satisfies_T0
                             f.u_in_hom hcomp_simps(1))
                     qed
                     finally show ?thesis by fastforce
                   qed
                   show "Maps.cod (Chn ?W) = Cod_W.apex"
                   proof -
                     have "Maps.cod (Chn ?W) = Maps.MkIde (trg w)"
                       using 1 w\<theta>\<nu> Maps.cod_char by simp
                     also have "... = Cod_W.apex"
                     proof -
                       have "trg w = src (Maps.REP g.leg0)"
                         using w\<theta>\<nu> by blast
                       thus ?thesis
                         using Cod_W.apex_def Maps.arr_char Maps.cod_char
                         apply simp
                         using g.dom.apex_def Maps.dom_char Maps.REP_simps(2) g.dom.is_span
                         by presburger
                     qed
                     finally show ?thesis by fastforce
                   qed
                 qed
                 show "Cod_W.leg0 \<odot> Chn ?W = Dom_W.leg0"
                 proof -
                   have "Cod_W.leg0 \<odot> Chn ?W = g.leg0 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     by simp
                   also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     using g.dom.leg_simps(1) Maps.CLS_REP [of g.leg0]
                     by simp
                   also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0 \<star> w\<rbrakk>\<rbrakk>"
                   proof -
                     have "is_left_adjoint (Maps.REP g.leg0)"
                       by fast
                     moreover have "is_left_adjoint w"
                       using w\<theta>\<nu> equivalence_is_adjoint by simp
                     moreover have "Maps.REP g.leg0 \<star> w \<cong> Maps.REP g.leg0 \<star> w"
                       using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom
                       by (metis (no_types, lifting) REP_leg0.ide_left adjoint_pair_antipar(1)
                           calculation(2) ide_hcomp in_hhomE)
                     ultimately show ?thesis
                       using w\<theta>\<nu> Maps.comp_CLS isomorphic_reflexive equivalence_is_adjoint
                       by blast
                   qed
                   also have "... = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>"
                   proof -
                     have "iso \<theta>"
                     proof -
                       have "is_left_adjoint (Maps.REP g.leg0 \<star> w)"
                         using w\<theta>\<nu> equivalence_is_adjoint Maps.REP_in_hhom
                         by (simp add: g.leg0_is_map in_hhom_def left_adjoints_compose)
                       moreover have "is_left_adjoint (tab\<^sub>0 ?f)"
                         by simp
                       ultimately show ?thesis
                         using w\<theta>\<nu> BS3 by blast
                     qed
                     thus ?thesis
                       using w\<theta>\<nu> Maps.CLS_eqI equivalence_is_adjoint
                       by (meson isomorphic_def isomorphic_implies_hpar(1))
                   qed
                   finally show ?thesis by fastforce
                 qed
                 show "Cod_W.leg1 \<odot> Chn ?W = Dom_W.leg1"
                 proof -
                   have "Cod_W.leg1 \<odot> Chn ?W = g.leg1 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     by simp
                   also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     using g.dom.leg_simps(3) Maps.CLS_REP by presburger
                   also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg1 \<star> w\<rbrakk>\<rbrakk>"
                   proof -
                     have "is_left_adjoint (Maps.REP g.leg1)"
                       by fast
                     moreover have "is_left_adjoint w"
                       using w\<theta>\<nu> equivalence_is_adjoint by simp
                     moreover have "Maps.REP g.leg1 \<star> w \<cong> Maps.REP g.leg1 \<star> w"
                       using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom
                       by (metis (no_types, lifting) "2" calculation(2) g.dom.is_span
                           hcomp_ide_isomorphic Maps.ide_REP in_hhomE
                           right_adjoint_determines_left_up_to_iso)
                     ultimately show ?thesis
                       using w\<theta>\<nu> Maps.comp_CLS isomorphic_reflexive equivalence_is_adjoint
                       by blast
                   qed
                   also have "... = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>"
                   proof -
                     have "ide (Maps.REP g.leg1 \<star> w)"
                       using 2 w\<theta>\<nu> equivalence_map_is_ide by auto
                     moreover have "Maps.REP g.leg1 \<star> w \<cong>
                                    tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
                       using w\<theta>\<nu> equivalence_is_adjoint f.leg1_is_map
                             right_adjoint_determines_left_up_to_iso adjoint_pair_preserved_by_iso
                       by (meson adjoint_pair_antipar(2) ide_in_hom(2) ide_is_iso)
                     ultimately show ?thesis
                       using Maps.CLS_eqI by blast
                   qed
                   finally show ?thesis by fastforce
                 qed
               qed
               thus W: "Span.arr ?W"
                 using Span.arr_char by blast
               interpret Dom_W:
                 span_in_category Maps.comp
                   \<open>\<lparr>Leg0 = Maps.MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
                                       (src (Maps.REP g.leg0)\<^sup>*)
                                       (iso_class (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))),
                     Leg1 = Maps.MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
                                       (Maps.Cod g.leg1)
                                       (iso_class (tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))\<rparr>\<close>
                 using W Span.arr_char
                 by (simp add: arrow_of_spans_def)
               interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
                 using W Span.arr_char
                 by (simp add: arrow_of_spans_def)
               show "Span.dom ?W = SPN ?f"
               proof -
                 have "Span.dom ?W =
                       \<lparr>Chn = Dom_W.apex,
                        Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>,
                               Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>\<rparr>,
                        Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>,
                               Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>\<rparr>\<rparr>"
                   using 0 W Span.dom_char by simp
                 also have "... = SPN ?f"
                   using SPN_def Dom_W.apex_def Maps.dom_char Dom_W.is_span iso_class_eqI
                         spn_ide
                   apply simp
                   using ide_f by blast
                 finally show ?thesis by blast
               qed
               show "Span.cod ?W = g"
                 using 0 W Span.cod_char Cod_W.apex_def by simp
             qed
             moreover have "Span.iso ?W"
             proof -
               have "Maps.iso \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
               proof -
                 have "Maps.arr \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk> \<and> w \<in> Maps.Map \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk> \<and> equivalence_map w"
                 proof (intro conjI)
                   show 1: "Maps.arr \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     using w\<theta>\<nu> Maps.CLS_in_hom equivalence_is_adjoint by blast
                   show "equivalence_map w"
                     using w\<theta>\<nu> by blast
                   show "w \<in> Maps.Map \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     using 1 w\<theta>\<nu> equivalence_is_adjoint Maps.arr_char
                     by (simp add: equivalence_map_is_ide ide_in_iso_class)
                 qed
                 thus ?thesis
                   using Maps.iso_char' by blast
               qed
               thus ?thesis
                 using w\<theta>\<nu> W_in_hom Span.iso_char by auto
             qed
             ultimately show ?thesis
               using Span.isomorphic_def by blast
           qed
           ultimately show ?thesis by blast
         qed
       qed
       show "\<And>r s \<tau>. \<lbrakk>ide r; ide s; src r = src s; trg r = trg s; Span.in_hom \<tau> (SPN r) (SPN s)\<rbrakk>
                        \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright> \<and> SPN \<mu> = \<tau>"
       proof -
         fix r s \<tau>
         assume r: "ide r" and s: "ide s"
         assume src_eq: "src r = src s" and trg_eq: "trg r = trg s"
         assume \<tau>: "Span.in_hom \<tau> (SPN r) (SPN s)"
         interpret \<tau>: arrow_of_spans Maps.comp \<tau>
           using \<tau> Span.arr_char by auto
         interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r
           using r by unfold_locales auto
         interpret s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
           using s by unfold_locales auto
         interpret s: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                        s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> s
           using s.is_arrow_of_tabulations_in_maps by simp
         have \<tau>_dom_leg0_eq: "\<tau>.dom.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>"
           using \<tau> Span.dom_char SPN_def [of r] by auto
         have \<tau>_dom_leg1_eq: "\<tau>.dom.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
           using \<tau> Span.dom_char SPN_def [of r] by auto
         have \<tau>_cod_leg0_eq: "\<tau>.cod.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>"
           using \<tau> Span.cod_char SPN_def [of s] by auto
         have \<tau>_cod_leg1_eq: "\<tau>.cod.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 s\<rbrakk>\<rbrakk>"
           using \<tau> Span.cod_char SPN_def [of s] by auto
 
         have 1: "tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<cong> tab\<^sub>0 r"
         proof -
           have "tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<cong> Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine"
           proof -
             have "Maps.REP \<tau>.cod.leg0 \<cong> tab\<^sub>0 s"
               using \<tau>_cod_leg0_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS s.satisfies_T0
               by presburger
             moreover have "src (tab\<^sub>0 s) = trg (Maps.REP \<tau>.chine)"
               using Maps.seq_char [of "\<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>" \<tau>.chine] \<tau>.cod.leg_simps(1)
                     \<tau>.leg0_commutes \<tau>_cod_leg0_eq
               by auto
             ultimately show ?thesis
               using hcomp_isomorphic_ide [of "tab\<^sub>0 s" "Maps.REP \<tau>.cod.leg0" "Maps.REP \<tau>.chine"]
                     isomorphic_symmetric
               by fastforce
           qed
           also have "... \<cong> Maps.REP \<tau>.dom.leg0"
           proof -
             have "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg0\<rbrakk>\<rbrakk>"
               using \<tau>.leg0_commutes Maps.CLS_REP \<tau>.chine_simps(1)
                     \<tau>.cod.leg_simps(1) \<tau>.dom.leg_simps(1)
               by presburger
             hence "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg0\<rbrakk>\<rbrakk>"
               using Maps.comp_CLS [of "Maps.REP \<tau>.cod.leg0" "Maps.REP \<tau>.chine"
                                       "Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine"]
                     isomorphic_reflexive
               by (metis (no_types, lifting) Maps.seq_char Maps.REP_in_hhom(2) Maps.REP_simps(2-3)
                   \<tau>.chine_in_hom \<tau>.cod.leg_in_hom(1) \<tau>.dom.leg_simps(1) \<tau>.leg0_commutes
                   ide_hcomp Maps.ide_REP)
             thus ?thesis
               using Maps.CLS_eqI Maps.seq_char Maps.ide_REP
               by (meson calculation isomorphic_implies_ide(2))
           qed
           also have "... \<cong> tab\<^sub>0 r"
             using \<tau>_dom_leg0_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS r.satisfies_T0
             by presburger
           finally show ?thesis by blast
         qed
         obtain \<theta> where \<theta>: "\<guillemotleft>\<theta> : tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<Rightarrow> tab\<^sub>0 r\<guillemotright> \<and> iso \<theta>"
           using 1 by blast
         have 2: "tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<cong> tab\<^sub>1 r"
         proof -
           have "tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<cong> Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine"
           proof -
             have "Maps.REP \<tau>.cod.leg1 \<cong> tab\<^sub>1 s"
               using \<tau>_cod_leg1_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS s.leg1_is_map
               by presburger
             moreover have "src (Maps.REP \<tau>.cod.leg1) = trg (Maps.REP \<tau>.chine)"
               using Maps.seq_char by auto
             ultimately show ?thesis
               using hcomp_isomorphic_ide [of "Maps.REP \<tau>.cod.leg1" "tab\<^sub>1 s" "Maps.REP \<tau>.chine"]
                     isomorphic_symmetric
               by fastforce
           qed
           also have "... \<cong> Maps.REP \<tau>.dom.leg1"
           proof -
             have "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg1\<rbrakk>\<rbrakk>"
               using \<tau>.leg1_commutes Maps.CLS_REP \<tau>.chine_simps(1)
                     \<tau>.cod.leg_simps(3) \<tau>.dom.leg_simps(3)
               by presburger
             hence "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg1\<rbrakk>\<rbrakk>"
               using Maps.comp_CLS [of "Maps.REP \<tau>.cod.leg1" "Maps.REP \<tau>.chine"
                                       "Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine"]
                     isomorphic_reflexive
               by (metis (no_types, lifting) Maps.seq_char Maps.REP_in_hhom(2)
                   Maps.REP_simps(2) Maps.REP_simps(3) \<tau>.chine_in_hom \<tau>.cod.leg_in_hom(2)
                   \<tau>.dom.leg_simps(3) \<tau>.leg1_commutes ide_hcomp Maps.ide_REP)
             thus ?thesis
               using Maps.CLS_eqI Maps.seq_char Maps.ide_REP
               by (meson calculation isomorphic_implies_ide(2))
           qed
           also have "... \<cong> tab\<^sub>1 r"
             using \<tau>_dom_leg1_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS r.leg1_is_map
             by presburger
           finally show ?thesis by blast
         qed
         obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 s \<star> Maps.REP \<tau>.chine\<guillemotright> \<and> iso \<nu>"
           using 2 isomorphic_symmetric by blast
 
         define \<Delta>
           where "\<Delta> \<equiv> (s \<star> \<theta>) \<cdot> \<a>[s, tab\<^sub>0 s, Maps.REP \<tau>.chine] \<cdot> (s.tab \<star> Maps.REP \<tau>.chine) \<cdot> \<nu>"
         have \<Delta>: "\<guillemotleft>\<Delta> : tab\<^sub>1 r \<Rightarrow> s \<star> tab\<^sub>0 r\<guillemotright>"
         proof (unfold \<Delta>_def, intro comp_in_homI)
           show "\<guillemotleft>\<nu> : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 s \<star> Maps.REP \<tau>.chine\<guillemotright>"
             using \<nu> by simp
           show 3: "\<guillemotleft>s.tab \<star> Maps.REP \<tau>.chine :
                       tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<Rightarrow> (s \<star> tab\<^sub>0 s) \<star> Maps.REP \<tau>.chine\<guillemotright>"
             apply (intro hcomp_in_vhom)
               apply auto
             using "1" by fastforce
           show "\<guillemotleft>\<a>[s, tab\<^sub>0 s, Maps.REP \<tau>.chine] :
                    (s \<star> tab\<^sub>0 s) \<star> Maps.REP \<tau>.chine \<Rightarrow> s \<star> tab\<^sub>0 s \<star> Maps.REP \<tau>.chine\<guillemotright>"
             using s assoc_in_hom [of s "tab\<^sub>0 s" "Maps.REP \<tau>.chine"]
             by (metis (no_types, lifting) Maps.ide_REP 3 \<tau>.chine_simps(1) hcomp_in_vhomE
                 ideD(2) ideD(3) s.ide_u s.tab_simps(2) s.u_simps(3))
           show "\<guillemotleft>s \<star> \<theta> : s \<star> tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<Rightarrow> s \<star> tab\<^sub>0 r\<guillemotright>"
             using 1 s \<theta> isomorphic_implies_hpar(4) src_eq by auto
         qed
         define \<mu> where "\<mu> \<equiv> r.T0.trnr\<^sub>\<epsilon> s \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
         have \<mu>: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
         proof (unfold \<mu>_def, intro comp_in_homI)
           show "\<guillemotleft>inv (r.T0.trnr\<^sub>\<epsilon> r r.tab) : r \<Rightarrow> tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<guillemotright>"
             using r.yields_isomorphic_representation by fastforce
           show "\<guillemotleft>r.T0.trnr\<^sub>\<epsilon> s \<Delta> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> s\<guillemotright>"
             using s \<Delta> src_eq r.T0.adjoint_transpose_right(2) [of s "tab\<^sub>1 r"] by auto
         qed
         interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg r s \<mu>
           using \<mu> by unfold_locales auto
         interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                        r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> \<mu>
           using \<mu>.is_arrow_of_tabulations_in_maps by simp
         have \<Delta>_eq: "\<Delta> = \<mu>.\<Delta>"
         proof -
           have "r.T0.trnr\<^sub>\<epsilon> s \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab) =
                 r.T0.trnr\<^sub>\<epsilon> s \<mu>.\<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
             using \<mu> \<mu>_def \<mu>.\<mu>_in_terms_of_\<Delta> by auto
           hence "r.T0.trnr\<^sub>\<epsilon> s \<Delta> = r.T0.trnr\<^sub>\<epsilon> s \<mu>.\<Delta>"
             using r s \<Delta> r.T0.adjoint_transpose_right(2) r.yields_isomorphic_representation
                   iso_inv_iso iso_is_retraction retraction_is_epi epiE
             by (metis \<mu>.in_hom \<mu>_def arrI)
           thus ?thesis
             using \<Delta> \<mu>.\<Delta>_in_hom(2) src_eq r.T0.adjoint_transpose_right(6)
                   bij_betw_imp_inj_on
                     [of "r.T0.trnr\<^sub>\<epsilon> s" "hom (tab\<^sub>1 r) (s \<star> tab\<^sub>0 r)" "hom (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) s"]
                   inj_on_def [of "r.T0.trnr\<^sub>\<epsilon> s" "hom (tab\<^sub>1 r) (s \<star> tab\<^sub>0 r)"]
             by simp
         qed
         have "\<mu>.is_induced_map (Maps.REP \<tau>.chine)"
           using \<theta> \<nu> \<Delta>_eq \<Delta>_def \<mu>.is_induced_map_iff \<tau>.chine_simps(1) Maps.ide_REP by blast
         hence 3: "Maps.REP \<tau>.chine \<cong> \<mu>.chine"
           using \<mu>.chine_is_induced_map \<mu>.induced_map_unique by simp
         have "SPN \<mu> = \<tau>"
         proof (intro Span.arr_eqI)
           show "Span.par (SPN \<mu>) \<tau>"
             using \<mu> \<tau> SPN_in_hom
             by (metis (no_types, lifting) SPN.preserves_cod SPN.preserves_dom Span.in_homE
                 in_homE)
           show "Chn (SPN \<mu>) = \<tau>.chine"
           proof -
             have "Chn (SPN \<mu>) = \<lbrakk>\<lbrakk>spn \<mu>\<rbrakk>\<rbrakk>"
               using \<mu> SPN_def spn_def by auto
             also have "... = \<lbrakk>\<lbrakk>\<mu>.chine\<rbrakk>\<rbrakk>"
               using \<mu> spn_def by fastforce
             also have "... = \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk>"
               using 3 isomorphic_symmetric Maps.CLS_eqI iso_class_eqI isomorphic_implies_hpar(3)
                     isomorphic_implies_hpar(4)
               by auto
             also have "... = \<tau>.chine"
               using Maps.CLS_REP \<tau>.chine_simps(1) by blast
             finally show ?thesis by blast
           qed
         qed
         thus "\<exists>\<mu>. \<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright> \<and> SPN \<mu> = \<tau>"
           using \<mu> by auto
       qed
     qed
 
     theorem SPN_is_equivalence_pseudofunctor:
     shows "equivalence_pseudofunctor V H \<a> \<i> src trg
              Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>"
       ..
 
     text \<open>
       We have completed the proof of the second half of the main result (CKS Theorem 4):
       \<open>B\<close> is biequivalent (via \<open>SPN\<close>) to \<open>Span(Maps(B))\<close>.
     \<close>
 
     corollary
     shows "equivalent_bicategories V H \<a> \<i> src trg
              Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg"
       using SPN_is_equivalence_pseudofunctor equivalent_bicategories_def by blast
 
   end
 
 end
diff --git a/thys/Bicategory/Strictness.thy b/thys/Bicategory/Strictness.thy
--- a/thys/Bicategory/Strictness.thy
+++ b/thys/Bicategory/Strictness.thy
@@ -1,4210 +1,4210 @@
 (*  Title:       Strictness
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Strictness"
 
 theory Strictness
 imports Category3.ConcreteCategory Pseudofunctor CanonicalIsos
 begin
 
   text \<open>
     In this section we consider bicategories in which some or all of the canonical isomorphisms
     are assumed to be identities.  A \emph{normal} bicategory is one in which the unit
     isomorphisms are identities, so that unit laws for horizontal composition are satisfied
     ``on the nose''.
     A \emph{strict} bicategory (also known as a \emph{2-category}) is a bicategory in which both
     the unit and associativity isomoprhisms are identities, so that horizontal composition is
     strictly associative as well as strictly unital.
 
     From any given bicategory \<open>B\<close> we may construct a related strict bicategory \<open>S\<close>,
     its \emph{strictification}, together with a pseudofunctor that embeds \<open>B\<close> in \<open>S\<close>.
     The Strictness Theorem states that this pseudofunctor is an equivalence pseudofunctor,
     so that bicategory \<open>B\<close> is biequivalent to its strictification.
     The Strictness Theorem is often used informally to justify suppressing canonical
     isomorphisms; which amounts to proving a theorem about 2-categories and asserting that
     it holds for all bicategories.  Here we are working formally, so we can't just wave
     our hands and mutter something about the Strictness Theorem when we want to avoid
     dealing with units and associativities.  However, in cases where we can establish that the
     property we would like to prove is reflected by the embedding of a bicategory in its
     strictification, then we can formally apply the Strictness Theorem to generalize to all
     bicategories a result proved for 2-categories.  We will apply this approach here to
     simplify the proof of some facts about internal equivalences in a bicategory.
   \<close>
 
   subsection "Normal and Strict Bicategories"
 
   text \<open>
     A \emph{normal} bicategory is one in which the unit isomorphisms are identities,
     so that unit laws for horizontal composition are satisfied ``on the nose''.
   \<close>
 
   locale normal_bicategory =
     bicategory +
   assumes strict_lunit: "\<And>f. ide f \<Longrightarrow> \<l>[f] = f"
   and strict_runit: "\<And>f. ide f \<Longrightarrow> \<r>[f] = f"
   begin
 
     lemma strict_unit:
     assumes "obj a"
     shows "ide \<i>[a]"
       using assms strict_runit unitor_coincidence(2) [of a] by auto
 
     lemma strict_lunit':
     assumes "ide f"
     shows "\<l>\<^sup>-\<^sup>1[f] = f"
       using assms strict_lunit by simp
 
     lemma strict_runit':
     assumes "ide f"
     shows "\<r>\<^sup>-\<^sup>1[f] = f"
       using assms strict_runit by simp
 
     lemma hcomp_obj_arr:
     assumes "obj b" and "arr f" and "b = trg f"
     shows "b \<star> f = f"
       using assms strict_lunit
       by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom lunit_naturality)
 
     lemma hcomp_arr_obj:
     assumes "arr f" and "obj a" and "src f = a"
     shows "f \<star> a = f"
       using assms strict_runit
       by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom runit_naturality)
 
   end
 
   text \<open>
     A \emph{strict} bicategory is a normal bicategory in which the associativities are also
     identities, so that associativity of horizontal composition holds ``on the nose''.
   \<close>
 
   locale strict_bicategory =
     normal_bicategory +
   assumes strict_assoc: "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow>
                                   ide \<a>[f, g, h]"
   begin
 
     lemma strict_assoc':
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "ide \<a>\<^sup>-\<^sup>1[f, g, h]"
       using assms strict_assoc by simp
 
     lemma hcomp_assoc:
     shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
     proof (cases "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>")
       show "\<not> (hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>) \<Longrightarrow> ?thesis"
         by (metis hseqE hseq_char' match_1 match_2)
       show "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau> \<Longrightarrow> ?thesis"
       proof -
         assume 1: "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>"
         have 2: "arr \<mu> \<and> arr \<nu> \<and> arr \<tau> \<and> src \<mu> = trg \<nu> \<and> src \<nu> = trg \<tau>"
           using 1 by blast
         have "(\<mu> \<star> \<nu>) \<star> \<tau> = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
           using 1 assoc_in_hom strict_assoc comp_cod_arr assoc_simps(4) hseq_char
           by simp
         also have "... = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
           using 1 assoc_naturality by auto
         also have "... = \<mu> \<star> \<nu> \<star> \<tau>"
           using 2 assoc_in_hom [of "dom \<mu>" "dom \<nu>" "dom \<tau>"] strict_assoc comp_arr_dom
           by auto
         finally show ?thesis by simp
       qed
     qed
 
     text \<open>
       In a strict bicategory, every canonical isomorphism is an identity.
     \<close>
 
     interpretation bicategorical_language ..
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     lemma ide_eval_Can:
     assumes "Can t"
     shows "ide \<lbrace>t\<rbrace>"
     proof -
       have 1: "\<And>u1 u2. \<lbrakk> ide \<lbrace>u1\<rbrace>; ide \<lbrace>u2\<rbrace>; Arr u1; Arr u2; Dom u1 = Cod u2 \<rbrakk>
                            \<Longrightarrow> ide (\<lbrace>u1\<rbrace> \<cdot> \<lbrace>u2\<rbrace>)"
         by (metis (no_types, lifting) E.eval_simps'(4-5) comp_ide_self ide_char)
       have "\<And>u. Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
       proof -
         fix u
         show "Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
           (* TODO: Rename \<ll>_ide_simp \<rr>_ide_simp to \<ll>_ide_eq \<rr>_ide_eq *)
           using 1 \<alpha>_def \<a>'_def strict_lunit strict_runit strict_assoc strict_assoc'
                 \<ll>_ide_simp \<rr>_ide_simp Can_implies_Arr comp_ide_arr E.eval_simps'(2-3)
           by (induct u) auto
       qed
       thus ?thesis
         using assms by simp
     qed
 
     lemma ide_can:
     assumes "Ide f" and "Ide g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
     shows "ide (can g f)"
       using assms Can_red Can_Inv red_in_Hom Inv_in_Hom can_def ide_eval_Can
             Can.simps(4) Dom_Inv red_simps(4)
       by presburger
 
   end
 
   context bicategory
   begin
 
     text \<open>
       The following result gives conditions for strictness of a bicategory that are typically
       somewhat easier to verify than those used for the definition.
     \<close>
 
     lemma is_strict_if:
     assumes "\<And>f. ide f \<Longrightarrow> f \<star> src f = f"
     and "\<And>f. ide f \<Longrightarrow> trg f \<star> f = f"
     and "\<And>a. obj a \<Longrightarrow> ide \<i>[a]"
     and "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow> ide \<a>[f, g, h]"
     shows "strict_bicategory V H \<a> \<i> src trg"
     proof
       show "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow> ide \<a>[f, g, h]"
         by fact
       fix f
       assume f: "ide f"
       show "\<l>[f] = f"
       proof -
         have "f = \<l>[f]"
           using assms f unit_simps(5)
           by (intro lunit_eqI) (auto simp add: comp_arr_ide)
         thus ?thesis by simp
       qed
       show "\<r>[f] = f"
       proof -
         have "f = \<r>[f]"
         proof (intro runit_eqI)
           show "ide f" by fact
           show "\<guillemotleft>f : f \<star> src f \<Rightarrow> f\<guillemotright>"
             using f assms(1) by auto
           show "f \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
           proof -
             have "(f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f] = (f \<star> src f) \<cdot> \<a>[f, src f, src f]"
               using f assms(2-3) unit_simps(5) by simp
             also have "... = (f \<star> src f \<star> src f) \<cdot> \<a>[f, src f, src f]"
               using f assms(1-2) ideD(1) trg_src src.preserves_ide by metis
             also have "... = f \<star> src f"
               using f comp_arr_ide assms(1,4) assoc_in_hom [of f "src f" "src f"] by auto
             finally show ?thesis by simp
           qed
         qed
         thus ?thesis by simp
       qed
     qed
 
   end
 
   subsection "Strictification"
 
   (*
    * TODO: Perhaps change the typeface used for a symbol that stands for a bicategory;
    * for example, to avoid the clashes here between B used as the name of a bicategory
    * and B used to denote a syntactic identity term.
    *)
 
   text \<open>
     The Strictness Theorem asserts that every bicategory is biequivalent to a
     strict bicategory.  More specifically, it shows how to construct, given an arbitrary
     bicategory, a strict bicategory (its \emph{strictification}) that is biequivalent to it.
     Consequently, given a property \<open>P\<close> of bicategories that is ``bicategorical''
     (\emph{i.e.}~respects biequivalence), if we want to show that \<open>P\<close> holds for a bicategory \<open>B\<close>
     then it suffices to show that \<open>P\<close> holds for the strictification of \<open>B\<close>, and if we want to show
     that \<open>P\<close> holds for all bicategories, it is sufficient to show that it holds for all
     strict bicategories.  This is very useful, because it becomes quite tedious, even
     with the aid of a proof assistant, to do ``diagram chases'' with all the units and
     associativities fully spelled out.
 
     Given a bicategory \<open>B\<close>, the strictification \<open>S\<close> of \<open>B\<close> may be constructed as the bicategory
     whose arrows are triples \<open>(A, B, \<mu>)\<close>, where \<open>X\<close> and \<open>Y\<close> are ``normal identity terms''
     (essentially, nonempty horizontally composable lists of 1-cells of \<open>B\<close>) having the same
     syntactic source and target, and \<open>\<guillemotleft>\<mu> : \<lbrace>X\<rbrace> \<Rightarrow> \<lbrace>Y\<rbrace>\<guillemotright>\<close> in \<open>B\<close>.
     Vertical composition in \<open>S\<close> is given by composition of the underlying arrows in \<open>B\<close>.
     Horizontal composition in \<open>S\<close> is given by \<open>(A, B, \<mu>) \<star> (A', B', \<mu>') = (AA', BB', \<nu>)\<close>,
     where \<open>AA'\<close> and \<open>BB'\<close> denote concatenations of lists and where \<open>\<nu>\<close> is defined as the
     composition \<open>can BB' (B \<^bold>\<star> B') \<cdot> (\<mu> \<star> \<mu>') \<cdot> can (A \<^bold>\<star> A') AA'\<close>, where \<open>can (A \<^bold>\<star> A') AA'\<close> and
     \<open>can BB' (B \<^bold>\<star> B')\<close> are canonical isomorphisms in \<open>B\<close>.  The canonical isomorphism
     \<open>can (A \<^bold>\<star> A') AA'\<close> corresponds to taking a pair of lists \<open>A \<^bold>\<star> A'\<close> and
     ``shifting the parentheses to the right'' to obtain a single list \<open>AA'\<close>.
     The canonical isomorphism can \<open>BB' (B \<^bold>\<star> B')\<close> corresponds to the inverse rearrangement.
 
     The bicategory \<open>B\<close> embeds into its strictification \<open>S\<close> via the functor \<open>UP\<close> that takes
     each arrow \<open>\<mu>\<close> of \<open>B\<close> to \<open>(\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>, \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>, \<mu>)\<close>, where \<open>\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>\<close> and \<open>\<^bold>\<langle>cod \<mu>\<^bold>\<rangle>\<close> denote
     one-element lists.  This mapping extends to a pseudofunctor.
     There is also a pseudofunctor \<open>DN\<close>, which maps \<open>(A, B, \<mu>)\<close> in \<open>S\<close> to \<open>\<mu>\<close> in \<open>B\<close>;
     this is such that \<open>DN o UP\<close> is the identity on \<open>B\<close> and \<open>UP o DN\<close> is equivalent to the
     identity on \<open>S\<close>, so we obtain a biequivalence between \<open>B\<close> and \<open>S\<close>.
 
     It seems difficult to find references that explicitly describe a strictification
     construction in elementary terms like this (in retrospect, it ought to have been relatively
     easy to rediscover such a construction, but my thinking got off on the wrong track).
     One reference that I did find useful was \cite{unapologetic-strictification},
     which discusses strictification for monoidal categories.
   \<close>
 
   locale strictified_bicategory =
     B: bicategory V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
   for V\<^sub>B :: "'a comp"                  (infixr "\<cdot>\<^sub>B" 55)
   and H\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"           (infixr "\<star>\<^sub>B" 53)
   and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<a>\<^sub>B[_, _, _]")
   and \<i>\<^sub>B :: "'a \<Rightarrow> 'a"                  ("\<i>\<^sub>B[_]")
   and src\<^sub>B :: "'a \<Rightarrow> 'a"
   and trg\<^sub>B :: "'a \<Rightarrow> 'a"
   begin
 
     sublocale E: self_evaluation_map V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B ..
 
     notation B.in_hhom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
     notation B.in_hom  ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
 
     notation E.eval ("\<lbrace>_\<rbrace>")
     notation E.Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
 
     text \<open>
       The following gives the construction of a bicategory whose arrows are triples \<open>(A, B, \<mu>)\<close>,
       where \<open>Nml A \<and> Ide A\<close>, \<open>Nml B \<and> Ide B\<close>, \<open>Src A = Src B\<close>, \<open>Trg A = Trg B\<close>, and \<open>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow> \<lbrace>B\<rbrace>\<close>.
       We use @{locale concrete_category} to construct the vertical composition, so formally the
       arrows of the bicategory will be of the form \<open>MkArr A B \<mu>\<close>.
     \<close>
 
     text \<open>
       The 1-cells of the bicategory correspond to normal, identity terms \<open>A\<close>
       in the bicategorical language associated with \<open>B\<close>.
     \<close>
 
     abbreviation IDE
     where "IDE \<equiv> {A. E.Nml A \<and> E.Ide A}"
 
     text \<open>
       If terms \<open>A\<close> and \<open>B\<close> determine 1-cells of the strictification and have a
       common source and target, then the 2-cells between these 1-cells correspond
       to arrows \<open>\<mu>\<close> of the underlying bicategory such that \<open>\<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>\<close>.
     \<close>
 
     abbreviation HOM
     where "HOM A B \<equiv> {\<mu>. E.Src A = E.Src B \<and> E.Trg A = E.Trg B \<and> \<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>}"
 
     text \<open>
       The map taking term \<open>A \<in> OBJ\<close> to its evaluation \<open>\<lbrace>A\<rbrace> \<in> HOM A A\<close> defines the
       embedding of 1-cells as identity 2-cells.
     \<close>
 
     abbreviation EVAL
     where "EVAL \<equiv> E.eval"
 
     sublocale concrete_category IDE HOM EVAL \<open>\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>\<close>
       using E.ide_eval_Ide B.comp_arr_dom B.comp_cod_arr B.comp_assoc
       by (unfold_locales, auto)
 
     lemma is_concrete_category:
     shows "concrete_category IDE HOM EVAL (\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>)"
       ..
 
     abbreviation vcomp     (infixr "\<cdot>" 55)
     where "vcomp \<equiv> COMP"
 
     lemma arr_char:
     shows "arr F \<longleftrightarrow>
            E.Nml (Dom F) \<and> E.Ide (Dom F) \<and> E.Nml (Cod F) \<and> E.Ide (Cod F) \<and>
            E.Src (Dom F) = E.Src (Cod F) \<and> E.Trg (Dom F) = E.Trg (Cod F) \<and>
            \<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright> \<and> F \<noteq> Null"
       using arr_char by auto
 
     lemma arrI (* [intro] *):
     assumes "E.Nml (Dom F)" and "E.Ide (Dom F)" and "E.Nml (Cod F)" and "E.Ide (Cod F)"
     and "E.Src (Dom F) = E.Src (Cod F)" and "E.Trg (Dom F) = E.Trg (Cod F)"
     and "\<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>" and "F \<noteq> Null"
     shows "arr F"
       using assms arr_char by blast
 
     lemma arrE [elim]:
     assumes "arr F"
     shows "(\<lbrakk> E.Nml (Dom F); E.Ide (Dom F); E.Nml (Cod F); E.Ide (Cod F);
               E.Src (Dom F) = E.Src (Cod F); E.Trg (Dom F) = E.Trg (Cod F);
               \<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>; F \<noteq> Null \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
       using assms arr_char by simp
 
     lemma ide_char:
     shows "ide F \<longleftrightarrow> endo F \<and> B.ide (Map F)"
     proof
       show "ide F \<Longrightarrow> endo F \<and> B.ide (Map F)"
-        using ide_char by (simp add: E.ide_eval_Ide)
+        using ide_char\<^sub>C\<^sub>C by (simp add: E.ide_eval_Ide)
       show "endo F \<and> B.ide (Map F) \<Longrightarrow> ide F"
-        by (metis (no_types, lifting) B.ide_char B.in_homE arr_char ide_char
+        by (metis (no_types, lifting) B.ide_char B.in_homE arr_char ide_char\<^sub>C\<^sub>C
             mem_Collect_eq seq_char)
     qed
 
     lemma ideI [intro]:
     assumes "arr F" and "Dom F = Cod F" and "B.ide (Map F)"
     shows "ide F"
       using assms ide_char dom_char cod_char seq_char by presburger
 
     lemma ideE [elim]:
     assumes "ide F"
     shows "(\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
               Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
       using assms
       by (metis (no_types, lifting) Map_ide(2) ide_char seq_char)
 
     text \<open>
       Source and target are defined by the corresponding syntactic operations on terms.
     \<close>
 
     definition src
     where "src F \<equiv> if arr F then MkIde (E.Src (Dom F)) else null"
 
     definition trg
     where "trg F \<equiv> if arr F then MkIde (E.Trg (Dom F)) else null"
 
     lemma src_simps [simp]:
     assumes "arr F"
     shows "Dom (src F) = E.Src (Dom F)" and "Cod (src F) = E.Src (Dom F)"
     and "Map (src F) = \<lbrace>E.Src (Dom F)\<rbrace>"
       using assms src_def arr_char by auto
 
     lemma trg_simps [simp]:
     assumes "arr F"
     shows "Dom (trg F) = E.Trg (Dom F)" and "Cod (trg F) = E.Trg (Dom F)"
     and "Map (trg F) = \<lbrace>E.Trg (Dom F)\<rbrace>"
       using assms trg_def arr_char by auto
 
     interpretation src: endofunctor vcomp src
       using src_def comp_char E.Obj_implies_Ide
       apply (unfold_locales)
           apply auto[4]
     proof -
       show "\<And>g f. seq g f \<Longrightarrow> src (g \<cdot> f) = src g \<cdot> src f"
       proof -
         fix g f
         assume gf: "seq g f"
         have "src (g \<cdot> f) = MkIde (E.Src (Dom (g \<cdot> f)))"
           using gf src_def comp_char by simp
         also have "... = MkIde (E.Src (Dom f))"
           using gf by (simp add: seq_char)
         also have "... = MkIde (E.Src (Dom g)) \<cdot> MkIde (E.Src (Dom f))"
           using gf seq_char E.Obj_implies_Ide by auto
         also have "... = src g \<cdot> src f"
           using gf src_def comp_char by auto
         finally show "src (g \<cdot> f) = src g \<cdot> src f" by blast
       qed
     qed
 
     interpretation trg: endofunctor vcomp trg
       using trg_def comp_char E.Obj_implies_Ide
       apply (unfold_locales)
           apply auto[4]
     proof -
       show "\<And>g f. seq g f \<Longrightarrow> trg (g \<cdot> f) = trg g \<cdot> trg f"
       proof -
         fix g f
         assume gf: "seq g f"
         have "trg (g \<cdot> f) = MkIde (E.Trg (Dom (g \<cdot> f)))"
           using gf trg_def comp_char by simp
         also have "... = MkIde (E.Trg (Dom f))"
           using gf by (simp add: seq_char)
         also have "... = MkIde (E.Trg (Dom g)) \<cdot> MkIde (E.Trg (Dom f))"
           using gf seq_char E.Obj_implies_Ide by auto
         also have "... = trg g \<cdot> trg f"
           using gf trg_def comp_char by auto
         finally show "trg (g \<cdot> f) = trg g \<cdot> trg f" by blast
       qed
     qed
 
     interpretation horizontal_homs vcomp src trg
       using src_def trg_def Cod_in_Obj Map_in_Hom E.Obj_implies_Ide
       by unfold_locales auto
 
     notation in_hhom  ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     definition hcomp    (infixr "\<star>" 53)
     where "\<mu> \<star> \<nu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>
                    then MkArr (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)
                               (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                                 (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                                 B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))
                    else null"
 
     lemma arr_hcomp:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "arr (\<mu> \<star> \<nu>)"
     proof -
       have 1: "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and> E.Nml (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and>
                E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and> E.Nml (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
         using assms arr_char src_def trg_def E.Ide_HcompNml E.Nml_HcompNml(1) by auto
       moreover
       have "\<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
                   \<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
       proof -
         have "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
           using assms arr_char dom_char cod_char src_def trg_def E.eval_simps'(2-3)
           by auto
         moreover
         have "\<guillemotleft>B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
                   \<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace>\<guillemotright> \<and>
                \<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) :
                   \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
           using assms 1 arr_char src_def trg_def
           apply (intro conjI B.in_homI) by auto
         ultimately show ?thesis by auto
       qed
       moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and>
                      E.Trg (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
         using assms arr_char src_def trg_def
         by (simp add: E.Src_HcompNml E.Trg_HcompNml)
       ultimately show ?thesis
         unfolding hcomp_def
         using assms by (intro arrI, auto)
     qed
 
     lemma src_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "src (\<mu> \<star> \<nu>) = src \<nu>"
       using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Src_HcompNml by simp
 
     lemma trg_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "trg (hcomp \<mu> \<nu>) = trg \<mu>"
       using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Trg_HcompNml by simp
 
     lemma hseq_char:
     shows "arr (\<mu> \<star> \<nu>) \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
       using arr_hcomp hcomp_def by simp
 
     lemma Dom_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "Dom (\<mu> \<star> \<nu>) = Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>"
       using assms hcomp_def [of \<mu> \<nu>] by simp
 
     lemma Cod_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "Cod (\<mu> \<star> \<nu>) = Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"
       using assms hcomp_def [of \<mu> \<nu>] by simp
 
     lemma Map_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "Map (\<mu> \<star> \<nu>) = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                            (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                            B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
       using assms hcomp_def [of \<mu> \<nu>] by simp
 
     interpretation "functor" VV.comp vcomp \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
     proof
       show "\<And>f. \<not> VV.arr f \<Longrightarrow> fst f \<star> snd f = null"
         using hcomp_def by auto
       show A: "\<And>f. VV.arr f \<Longrightarrow> arr (fst f \<star> snd f)"
         using VV.arrE hseq_char by blast
       show "\<And>f. VV.arr f \<Longrightarrow> dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
       proof -
         fix f
         assume f: "VV.arr f"
         have "dom (fst f \<star> snd f) = MkIde (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
           using f VV.arrE [of f] dom_char arr_hcomp hcomp_def by simp
         also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
         proof -
           have "hcomp (fst (VV.dom f)) (snd (VV.dom f)) =
                 MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))
                       (B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
                         (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
                         B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
             using f VV.arrE [of f] arr_hcomp hcomp_def VV.dom_simp by simp
           moreover have "B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
                            (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
                               B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
                          \<lbrace>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<rbrace>"
           proof -
             have 1: "E.Ide (Dom (fst f) \<^bold>\<star> Dom (snd f))"
               using f VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char dom_char
               apply simp
               by (metis (no_types, lifting) src_simps(1) trg_simps(1))
             have 2: "E.Ide (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               using f VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
             have 3: "\<^bold>\<lfloor>Dom (fst f) \<^bold>\<star> Dom (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<^bold>\<rfloor>"
               using f VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
                   src_simps(1) trg_simps(1))
             have "(\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
                     B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
                   B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               using "1" "2" "3" B.comp_cod_arr by force
             thus ?thesis
               using 1 2 3 f VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.can_Ide_self B.vcomp_can by simp
           qed
           ultimately show ?thesis by simp
         qed
         finally show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
           by simp
       qed
       show "\<And>f. VV.arr f \<Longrightarrow> cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
       proof -
         fix f
         assume f: "VV.arr f"
         have "cod (fst f \<star> snd f) = MkIde (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
           using f VV.arrE [of f] cod_char arr_hcomp hcomp_def by simp
         also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
         proof -
           have "hcomp (fst (VV.cod f)) (snd (VV.cod f)) =
                 MkArr (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
                       (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                         (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
                         B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)))"
             using f VV.arrE [of f] arr_hcomp hcomp_def VV.cod_simp by simp
           moreover have "B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                            (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
                              B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
                          \<lbrace>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<rbrace>"
           proof -
             have 1: "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
               using f VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char dom_char
               apply simp
               by (metis (no_types, lifting) src_simps(1) trg_simps(1))
             have 2: "E.Ide (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
               using f VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
             have 3: "\<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<^bold>\<rfloor>"
               using f VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
                   src_simps(1) trg_simps(1))
             have "(\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
                     B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
                   B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
               using "1" "2" "3" B.comp_cod_arr by force
             thus ?thesis
               using 1 2 3 f VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.can_Ide_self B.vcomp_can by simp
           qed
           ultimately show ?thesis by simp
         qed
         finally show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
           by simp
       qed
       show "\<And>g f. VV.seq g f \<Longrightarrow>
                    fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
       proof -
         fix f g
         assume fg: "VV.seq g f"
         have f: "arr (fst f) \<and> arr (snd f) \<and> src (fst f) = trg (snd f)"
           using fg VV.seq_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
         have g: "arr (fst g) \<and> arr (snd g) \<and> src (fst g) = trg (snd g)"
           using fg VV.seq_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
         have 1: "arr (fst (VV.comp g f)) \<and> arr (snd (VV.comp g f)) \<and>
                  src (fst (VV.comp g f)) = trg (snd (VV.comp g f))"
           using fg VV.arrE by blast
         have 0: "VV.comp g f = (fst g \<cdot> fst f, snd g \<cdot> snd f)"
           using fg 1 VV.comp_char VxV.comp_char
           by (metis (no_types, lifting) VV.seq_char\<^sub>S\<^sub>b\<^sub>C VxV.seqE)
         let ?X = "MkArr (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f)))
                         (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
                         (B.can (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
                                (Cod (fst (VV.comp g f)) \<^bold>\<star> Cod (snd (VV.comp g f))) \<cdot>\<^sub>B
                            (Map (fst (VV.comp g f)) \<star>\<^sub>B Map (snd (VV.comp g f))) \<cdot>\<^sub>B
                            B.can (Dom (fst (VV.comp g f)) \<^bold>\<star> Dom (snd (VV.comp g f)))
                                  (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f))))"
         have 2: "fst (VV.comp g f) \<star> snd (VV.comp g f) = ?X"
           unfolding hcomp_def using 1 by simp
         also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
         proof -
           let ?GG = "MkArr (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g))
                            (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                              (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                              B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)))"
           let ?FF = "MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
                            (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                              (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
                              B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
           have 4: "arr ?FF \<and> arr ?GG \<and> Dom ?GG = Cod ?FF"
           proof -
             have "arr ?FF \<and> arr ?GG"
               using f g fg VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.seqE hcomp_def A by presburger
             thus ?thesis
               using 0 1 by (simp add: fg seq_char)
           qed
           have "(fst g \<star> snd g) \<cdot> (fst f \<star> snd f) = ?GG \<cdot> ?FF"
             unfolding hcomp_def
             using 1 f g fg VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.seqE by simp
           also have "... = ?X"
           proof (intro arr_eqI)
             show "seq ?GG ?FF"
               using fg 4 seq_char by blast
             show "arr ?X"
               using fg 1 arr_hcomp hcomp_def by simp
             show "Dom (?GG \<cdot> ?FF) = Dom ?X"
               using fg 0 1 4 seq_char by simp
             show "Cod (?GG \<cdot> ?FF) = Cod ?X"
               using fg 0 1 4 seq_char by simp
             show "Map (?GG \<cdot> ?FF) = Map ?X"
             proof -
               have "Map (?GG \<cdot> ?FF) = Map ?GG \<cdot>\<^sub>B Map ?FF"
                 using 4 by auto
               also have
                 "... = (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                          (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                          B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                        (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                          (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
                          B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
                 using fg by simp
               also have
                 "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                          ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
                          B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               proof -
                 have "(B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                         (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                         B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                         (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                         (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
                         B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))) =
                       B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                         ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                         (B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
                         B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
                         (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
                         B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
                   using B.comp_assoc by simp
                 also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                                   ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
                                    B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
                 proof -
                   have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                           (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
                         \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
                   proof -
                     have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                           (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
                           B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Cod (fst f) \<^bold>\<star> Cod (snd f))"
                     proof -
                       have "E.Ide (Dom (fst g) \<^bold>\<star> Dom (snd g))"
                         using g arr_char
                         by (metis (no_types, lifting) E.Ide.simps(3) src_simps(2) trg_simps(2))
                       moreover have "E.Ide (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))"
                         using 4 by auto
                       moreover have "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
                         using f arr_char
                         by (metis (no_types, lifting) E.Ide.simps(3) src_simps(2) trg_simps(2))
                       moreover have
                         "\<^bold>\<lfloor>Dom (fst g) \<^bold>\<star> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor>"
                         using g E.Nml_HcompNml(1) calculation(1) by fastforce
                       moreover have
                         "\<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor>"
                         using g fg seq_char
                         by (metis (no_types, lifting) VV.seq_char\<^sub>S\<^sub>b\<^sub>C VxV.seqE calculation(4))
                       moreover have
                         "Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g) = Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)"
                         using 0 1 by (simp add: seq_char)
                       ultimately show ?thesis
                         using B.vcomp_can by simp
                     qed
                     also have "... = \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
                     proof -
                       have "Dom (fst g) \<^bold>\<star> Dom (snd g) = Cod (fst f) \<^bold>\<star> Cod (snd f)"
                         using 0 f g fg seq_char VV.seq_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                         by simp
                       thus ?thesis
                         using f B.can_Ide_self [of "Dom (fst f) \<^bold>\<star> Dom (snd f)"]
                         by (metis (no_types, lifting) B.can_Ide_self E.Ide.simps(3)
                             arrE src_simps(2) trg_simps(2))
                     qed
                     finally show ?thesis by simp
                   qed
                   hence "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
                            B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
                            (Map (fst f) \<star>\<^sub>B Map (snd f)) =
                          \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace> \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))"
                     by simp
                   also have "... = Map (fst f) \<star>\<^sub>B Map (snd f)"
                   proof -
                     have 1: "\<forall>p. arr p \<longrightarrow> map (cod p) \<cdot> map p = map p"
                       by blast
                     have 3: "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) = Map (map (cod (fst f)) \<cdot> map (fst f))"
                       by (simp add: f)
                     have 4: "map (cod (fst f)) \<cdot> map (fst f) = fst f"
                       using 1 f map_simp by simp
                     show ?thesis
                     proof -
                       have 2: "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) = Map (snd f)"
                         using 1 f map_simp
                         by (metis (no_types, lifting) Dom_cod Map_cod Map_comp arr_cod)
                       have "B.seq \<lbrace>Cod (snd f)\<rbrace> (Map (snd f))"
                         using f 2 by auto
                       moreover have "B.seq \<lbrace>Cod (fst f)\<rbrace> (Map (fst f))"
                         using 4 f 3 by auto
                       moreover have
                         "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
                          Map (fst f) \<star>\<^sub>B Map (snd f)"
                         using 2 3 4 by presburger
                       ultimately show ?thesis
                         by (simp add: B.interchange)
                     qed
                   qed
                   finally have
                     "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
                        B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
                        (Map (fst f) \<star>\<^sub>B Map (snd f)) =
                      Map (fst f) \<star>\<^sub>B Map (snd f)"
                     by simp
                   thus ?thesis
                     using fg B.comp_cod_arr by simp
                 qed
                 finally show ?thesis by simp
               qed
               also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                                  (Map (fst g \<cdot> fst f) \<star>\<^sub>B Map (snd g \<cdot> snd f)) \<cdot>\<^sub>B
                                  B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               proof -
                 have 2: "Dom (fst g) = Cod (fst f)"
                   using 0 f g fg VV.seq_char\<^sub>S\<^sub>b\<^sub>C [of g f] VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char seq_char
                   by (metis (no_types, lifting) fst_conv)
                 hence "Map (fst g \<cdot> fst f) = Map (fst g) \<cdot>\<^sub>B Map (fst f)"
                   using f g Map_comp [of "fst f" "fst g"] by simp
                 moreover have "B.seq (Map (fst g)) (Map (fst f)) \<and>
                                B.seq (Map (snd g)) (Map (snd f))"
                   using f g 0 1 2 arr_char
                   by (metis (no_types, lifting) B.seqI' prod.sel(2) seq_char)
                 ultimately show ?thesis
                   using 0 1 seq_char Map_comp B.interchange by auto
               qed
               also have "... = Map ?X"
                 using fg 0 1 by (simp add: seq_char)
               finally show ?thesis by simp
             qed
           qed
           finally show ?thesis by simp
         qed
         finally show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
           by simp
       qed
     qed
 
     interpretation horizontal_composition vcomp hcomp src trg
       using hseq_char by (unfold_locales, auto)
 
     lemma hcomp_assoc:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>"
     and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
     proof (intro arr_eqI)
       have \<mu>\<nu>: "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
         using assms src_def trg_def arr_char
         by (auto simp add: E.eval_simps'(2-3) Pair_inject)
       have \<nu>\<tau>: "\<guillemotleft>Map \<nu> \<star>\<^sub>B Map \<tau> : \<lbrace>Dom \<nu> \<^bold>\<star> Dom \<tau>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<nu> \<^bold>\<star> Cod \<tau>\<rbrace>\<guillemotright>"
         using assms src_def trg_def arr_char
         by (auto simp add: E.eval_simps'(2-3) Pair_inject)
       show "hseq (\<mu> \<star> \<nu>) \<tau>"
         using assms \<mu>\<nu> \<nu>\<tau> by auto
       show "hseq \<mu> (\<nu> \<star> \<tau>)"
         using assms \<mu>\<nu> \<nu>\<tau> by auto
       show "Dom ((\<mu> \<star> \<nu>) \<star> \<tau>) = Dom (\<mu> \<star> \<nu> \<star> \<tau>)"
       proof -
         have "E.Nml (Dom \<mu>) \<and> E.Nml (Dom \<nu>) \<and> E.Nml (Dom \<tau>)"
           using assms by blast
         moreover have "E.Src (Dom \<mu>) = E.Trg (Dom \<nu>) \<and> E.Src (Dom \<nu>) = E.Trg (Dom \<tau>)"
           using assms \<mu>\<nu> \<nu>\<tau>
           by (metis (no_types, lifting) src_simps(2) trg_simps(2))
         ultimately show ?thesis
           using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc by simp
       qed
       show "Cod ((\<mu> \<star> \<nu>) \<star> \<tau>) = Cod (\<mu> \<star> \<nu> \<star> \<tau>)"
       proof -
         have "E.Nml (Cod \<mu>) \<and> E.Nml (Cod \<nu>) \<and> E.Nml (Cod \<tau>)"
           using assms by blast
         moreover have "E.Src (Cod \<mu>) = E.Trg (Cod \<nu>) \<and> E.Src (Cod \<nu>) = E.Trg (Cod \<tau>)"
           using assms \<mu>\<nu> \<nu>\<tau>
           by (metis (no_types, lifting) arrE src_simps(2) trg_simps(2))
         ultimately show ?thesis
           using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc by simp
       qed
      show "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
       proof -
         have "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
               B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                 (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                    B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
         proof -
           have 1: "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
                    B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                      (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                        B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using assms \<mu>\<nu> \<nu>\<tau> hcomp_def E.HcompNml_assoc src_def trg_def arr_char
                   E.Nml_HcompNml E.Ide_HcompNml
             by auto (* 5 sec *)
           also have
             "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                      (B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
                        B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
           proof -
             have
               "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                  (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau> =
                B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                  (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                  B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
             proof -
               have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                       (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)
                          \<star>\<^sub>B Map \<tau> =
                     (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                       ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>)"
               proof -
                 have "B.seq (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>))
                                ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
                   by (metis (no_types, lifting) B.arrI Map_hcomp arrE arr_hcomp
                       assms(1) assms(2) assms(4))
                 moreover have "B.seq (B.can (Cod \<tau>) (Cod \<tau>)) (Map \<tau>)"
                   using B.can_in_hom assms(3) by blast
                 moreover have "B.ide (B.can (Cod \<tau>) (Cod \<tau>))"
                   using B.can_Ide_self E.ide_eval_Ide arr_char assms(3) by presburger
                 ultimately show ?thesis
                   by (metis (no_types) B.comp_ide_arr B.interchange)
               qed
               also have
                 "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                          ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                            (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
                               B.can (Dom \<tau>) (Dom \<tau>))"
               proof -
                 have "B.seq (Map \<mu> \<star>\<^sub>B Map \<nu>) (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
                   by (metis (no_types, lifting) B.arrI B.comp_null(2) B.ext Map_hcomp
                       arrE arr_hcomp assms(1) assms(2) assms(4))
                 moreover have "B.seq (Map \<tau>) (B.can (Dom \<tau>) (Dom \<tau>))"
                   using assms(3) by fastforce
                 ultimately show ?thesis
                   using B.interchange
                   by (metis (no_types, lifting) B.can_Ide_self B.comp_arr_ide E.ide_eval_Ide
                       arrE assms(3))
               qed
               also have
                 "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                          (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                            (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                              B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
                            (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
                               B.can (Dom \<tau>) (Dom \<tau>))"
               proof -
                 have "(Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau> =
                         B.\<a>' \<lbrace>Cod \<mu>\<rbrace> \<lbrace>Cod \<nu>\<rbrace> \<lbrace>Cod \<tau>\<rbrace> \<cdot>\<^sub>B
                           (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                              \<a>\<^sub>B \<lbrace>Dom \<mu>\<rbrace> \<lbrace>Dom \<nu>\<rbrace> \<lbrace>Dom \<tau>\<rbrace>"
                   using B.hcomp_reassoc(1)
                   by (metis (no_types, lifting) B.hcomp_in_vhomE B.in_homE \<mu>\<nu> \<nu>\<tau> arrE
                       assms(1) assms(2) assms(3))
                 also have "... = B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                                    (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                       B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                   using assms arr_char src_def trg_def arr_char B.canE_associator by simp
                finally show ?thesis by simp
               qed
               also have
                 "... = ((B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                          (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                        (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                           (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
                              B.can (Dom \<tau>) (Dom \<tau>)))"
                 using B.comp_assoc by simp
               also have
                 "... = B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                          (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
               proof -
                 have "(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                         (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) =
                       B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
                 proof -
                   have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu>)"
                     by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
                         src_simps(1) trg_simps(1))
                   moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
                     using E.Ide_HcompNml assms(1) assms(2) calculation by auto
                   moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<^bold>\<rfloor>"
                     using E.Nml_HcompNml(1) assms(1) assms(2) calculation(1) by fastforce
                   moreover have "E.Src (Cod \<mu> \<^bold>\<star> Cod \<nu>) = E.Trg (Cod \<tau>)"
                     by (metis (no_types, lifting) E.Src.simps(3) arrE assms(2-3,5)
                         src_simps(2) trg_simps(2))
                   moreover have "E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) = E.Trg (Cod \<tau>)"
                     using E.Src_HcompNml assms(1) assms(2) calculation(1) calculation(4)
                     by fastforce
                   moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
                     by (metis (no_types, lifting) E.Arr.simps(3) E.Nmlize_Hcomp_Hcomp
                         E.Nmlize_Hcomp_Hcomp' E.Ide_implies_Arr E.Src.simps(3) arrE assms(3)
                         calculation(1) calculation(4))
                   ultimately show ?thesis
                     using assms(3) B.hcomp_can B.vcomp_can by auto
                 qed
                 moreover have
                   "B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                      (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B B.can (Dom \<tau>) (Dom \<tau>)) =
                    B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                 proof -
                   have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
                     by (metis (no_types, lifting) E.Ide_HcompNml arrE assms(1-2,4)
                         src_simps(2) trg_simps(2))
                   moreover have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu>)"
                     by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
                         src_simps(1) trg_simps(1))
                   moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu>\<^bold>\<rfloor>"
                     using E.Nml_HcompNml(1) assms(1-2) calculation(2) by fastforce
                   moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Dom \<tau>)"
                     by (metis (no_types, lifting) E.Ide.simps(3) E.Src_HcompNml arrE
                         assms(1-3,5) calculation(2) src_simps(2) trg_simps(2))
                   moreover have "E.Src (Dom \<mu> \<^bold>\<star> Dom \<nu>) = E.Trg (Dom \<tau>)"
                     using E.Src_HcompNml assms(1-2) calculation(2) calculation(4)
                     by fastforce
                   moreover have "E.Ide ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                     using E.Ide.simps(3) assms(3) calculation(2) calculation(5) by blast
                   moreover have "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
                     using E.Nmlize_Hcomp_Hcomp calculation(6) by auto
                   ultimately show ?thesis
                     using assms(3) B.hcomp_can B.vcomp_can by auto
                 qed
                 ultimately show ?thesis by simp
               qed
               finally show ?thesis by simp
             qed
             thus ?thesis by simp
           qed
           also have
             "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                      B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                            B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using B.comp_assoc by simp
           also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                              (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
           proof -
             have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                     B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) =
                   B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
             proof -
               have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
                 using assms src_def trg_def by fastforce
               moreover have "E.Ide ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>)"
                 using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
                 by auto
               moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>)"
                 using assms arr_char src_def trg_def
                 by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
               moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
               moreover have "\<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
                 by simp
               ultimately show ?thesis by simp
             qed
             moreover have
               "B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                  B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
                B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             proof -
               have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>)"
                 using assms src_def trg_def by fastforce
               moreover have "E.Ide ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                 using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
                 by auto
               moreover have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
                 using assms arr_char src_def trg_def
                 by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
               moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
               moreover have
                 "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
                 by simp
               ultimately show ?thesis by simp
             qed
             ultimately show ?thesis by simp
           qed
           finally show ?thesis by simp
         qed
         also have "... = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
         proof -
           have 1: "Map (\<mu> \<star> \<nu> \<star> \<tau>) =
                    B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
                      (Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                                 (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                   B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
                         B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using assms Map_hcomp [of \<mu> "\<nu> \<star> \<tau>"] Map_hcomp [of \<nu> \<tau>] by simp
           also have
             "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
                      ((B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
                             B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))) \<cdot>\<^sub>B
                      B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
           proof -
             have "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                             (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                               B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
                     (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                           B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
               using assms B.interchange B.comp_cod_arr
               by (metis (no_types, lifting) B.can_Ide_self B.in_homE Map_hcomp arrE hseq_char)
             also have "... = (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B
                                  B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                                (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                  (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
                                     B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
               using assms B.interchange B.comp_arr_dom [of "Map \<mu>" "B.can (Dom \<mu>) (Dom \<mu>)"]
               by (metis (no_types, lifting) B.can_Ide_self B.comp_null(2) B.ext B.in_homE
                   Map_hcomp arrE hseq_char)
             finally have
               "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                  (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                    B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
               (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                 (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                   (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
               by simp
             thus ?thesis by simp
           qed
           also have
             "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
                      (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          ((B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
                              B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
                            B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
             using B.comp_assoc by simp
           also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                              (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                 B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
                   E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
             by simp
           finally show ?thesis by simp
         qed
         ultimately show ?thesis by metis
       qed
     qed
 
     lemma obj_char:
     shows "obj a \<longleftrightarrow> endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
     proof
       assume a: "obj a"
       show "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
       proof (intro conjI)
         show "endo a"
           using a ide_char by blast
         show "E.Obj (Dom a)"
           using a ide_char src_def
           by (metis (no_types, lifting) E.Ide_implies_Arr E.Obj_Trg arrE obj_def
               trg_simps(1) trg_src) 
         show "Map a = \<lbrace>Dom a\<rbrace>"
           using a ide_char src_def by blast
       qed
       next
       assume a: "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
       show "obj a"
       proof -
         have "arr a" using a by auto
         moreover have "src a = a"
           using a E.Obj_in_Hom(1) seq_char by (intro arr_eqI, auto)
         ultimately show ?thesis
           using obj_def by simp
       qed
     qed
 
     lemma hcomp_obj_self:
     assumes "obj a"
     shows "a \<star> a = a"
     proof (intro arr_eqI)
       show "hseq a a"
         using assms by auto
       show "arr a"
         using assms by auto
       show 1: "Dom (a \<star> a) = Dom a"
         unfolding hcomp_def
         using assms arr_char E.HcompNml_Trg_Nml
         apply simp
         by (metis (no_types, lifting) objE obj_def trg_simps(1))
       show 2: "Cod (a \<star> a) = Cod a"
         unfolding hcomp_def
         using assms 1 arr_char E.HcompNml_Trg_Nml
         apply simp
         by (metis (no_types, lifting) Dom_hcomp ideE objE)
       show "Map (a \<star> a) = Map a"
         using "1" Map_ide(1) assms by fastforce
     qed
 
     lemma hcomp_ide_src:
     assumes "ide f"
     shows "f \<star> src f = f"
     proof (intro arr_eqI)
       show "hseq f (src f)"
         using assms by simp
       show "arr f"
         using assms by simp
       show 1: "Dom (f \<star> src f) = Dom f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Nml_Src
         by (metis (no_types, lifting) ideD(1))
       show "Cod (f \<star> src f) = Cod f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Nml_Src
         by (metis (no_types, lifting) ideD(1))
       show "Map (f \<star> src f) = Map f"
         by (simp add: "1" Map_ide(1) assms)
     qed
 
     lemma hcomp_trg_ide:
     assumes "ide f"
     shows "trg f \<star> f = f"
     proof (intro arr_eqI)
       show "hseq (trg f) f"
         using assms by auto
       show "arr f"
         using assms by auto
       show 1: "Dom (trg f \<star> f) = Dom f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Trg_Nml
         by (metis (no_types, lifting) ideD(1))
       show "Cod (trg f \<star> f) = Cod f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Trg_Nml
         by (metis (no_types, lifting)  ideD(1))
       show "Map (trg f \<star> f) = Map f"
         by (simp add: "1" Map_ide(1) assms)
     qed
 
     interpretation L: full_functor vcomp vcomp L
     proof
       fix a a' g
       assume a: "ide a" and a': "ide a'"
       assume g: "in_hom g (L a') (L a)"
       have a_eq: "a = MkIde (Dom a)"
         using a dom_char [of a] by simp
       have a'_eq: "a' = MkIde (Dom a')"
         using a' dom_char [of a'] by simp
       have 1: "Cod g = Dom a"
       proof -
         have "Dom (L a) = Dom a"
           by (simp add: a hcomp_trg_ide)
         thus ?thesis
           using g cod_char [of g]
           by (metis (no_types, lifting) Dom_cod in_homE)
       qed
       have 2: "Dom g = Dom a'"
         using a' g hcomp_trg_ide in_hom_char by auto
       let ?f = "MkArr (Dom a') (Cod a) (Map g)"
       have f: "in_hom ?f a' a"
         by (metis (no_types, lifting) "1" "2" MkArr_Map a a' g ideE in_hom_char)
       moreover have "L ?f = g"
       proof -
         have "L ?f =
               trg (MkArr (Dom a') (Cod a) (Map g)) \<star> MkArr (Dom a') (Cod a) (Map g)"
           using f by auto
         also have "... = MkIde (E.Trg (Cod a)) \<star> MkArr (Dom a') (Cod a) (Map g)"
           using a a' f trg_def [of a] vconn_implies_hpar by auto
         also have "... = MkArr (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a)
                                (B.can (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
                                  (\<lbrace>E.Trg (Cod a)\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
                                  B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a'))"
           using hcomp_def
           apply simp
           by (metis (no_types, lifting) Cod.simps(1) arrE f in_homE src_trg trg.preserves_arr
               trg_def)
         also have "... = MkArr (Dom a') (Cod a)
                                (B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
                                  (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
                                  B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (Dom a'))"
         proof -
           have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a' = Dom a'"
             using a a' arr_char E.HcompNml_Trg_Nml
             by (metis (no_types, lifting) f ideE trg_simps(1) vconn_implies_hpar(4))
           moreover have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a = Cod a"
             using a a' arr_char E.HcompNml_Trg_Nml by blast
           moreover have "\<lbrace>E.Trg (Cod a)\<rbrace> = trg\<^sub>B \<lbrace>Cod a\<rbrace>"
             using a a' arr_char E.eval_simps'(3) by fastforce
           ultimately show ?thesis by simp
         qed
         also have "... = MkArr (Dom a') (Cod a)
                            (B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace>)"
         proof -
           have "E.Trg (Cod a) = E.Trg (Dom a')"
             using a a' a_eq g ide_char arr_char src_def trg_def trg_hcomp
                   \<open>Cod g = Dom a\<close> \<open>Dom g = Dom a'\<close>
             by (metis (no_types, lifting) Cod.simps(1) in_homE)
           moreover have "B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) = B.lunit \<lbrace>Cod a\<rbrace>"
             using a ide_char arr_char B.canE_unitor(2) by blast
           moreover have "B.can (E.Trg (Dom a') \<^bold>\<star> Dom a') (Dom a') = B.lunit' \<lbrace>Dom a'\<rbrace>"
             using a' ide_char arr_char B.canE_unitor(4) by blast
           ultimately show ?thesis by simp
         qed
         also have "... = MkArr (Dom g) (Cod g) (Map g)"
         proof -
           have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
             using a f g ide_char arr_char src_def B.comp_cod_arr
             by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
                 Cod.simps(1) Map.simps(1) in_homE)
           moreover have
             "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> = Map g"
           proof -
             have "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> =
                   B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g ide_char arr_char B.lunit'_naturality
               by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
             also have "... = (B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
               using B.comp_assoc by simp
             also have "... = \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g E.ide_eval_Ide B.comp_arr_inv' by fastforce
             also have "... = Map g"
               using g E.ide_eval_Ide B.comp_cod_arr by fastforce
             finally show ?thesis by simp
           qed
           ultimately have
             "B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace> = Map g"
             using a a' 1 2 f g hcomp_def dom_char cod_char
             by (metis (no_types, lifting) B.comp_null(2) B.ext B.lunit_simps(2) B.lunit_simps(3)
                 B.src.preserves_reflects_arr B.trg_vcomp B.vseq_implies_hpar(1) ideE)
           thus ?thesis
             using a 1 2 by auto
         qed
         also have "... = g"
           using g MkArr_Map by blast
         finally show ?thesis by simp
       qed
       ultimately show "\<exists>f. in_hom f a' a \<and> L f = g"
         by blast
     qed
 
     interpretation R: full_functor vcomp vcomp R
     proof
       fix a a' g
       assume a: "ide a" and a': "ide a'"
       assume g: "in_hom g (R a') (R a)"
       have a_eq: "a = MkIde (Dom a)"
         using a dom_char [of a] by simp
       have a'_eq: "a' = MkIde (Dom a')"
         using a' dom_char [of a'] by simp
       have 1: "Cod g = Dom a"
         using a g hcomp_ide_src in_hom_char by force
       have 2: "Dom g = Dom a'"
         using a' g hcomp_ide_src by auto
       let ?f = "MkArr (Dom a') (Cod a) (Map g)"
       have f: "in_hom ?f a' a"
       proof (intro in_homI)
         show 3: "arr (MkArr (Dom a') (Cod a) (Map g))"
           by (metis (no_types, lifting) "1" "2" Cod.simps(1) MkArr_Map a_eq g in_homE)
         show "dom (MkArr (Dom a') (Cod a) (Map g)) = a'"
           using a a' 3 dom_char by auto
         show "cod (MkArr (Dom a') (Cod a) (Map g)) = a"
           using a a' 3 cod_char by auto
       qed
       moreover have "R ?f = g"
       proof -
         have "R ?f =
                MkArr (Dom a') (Cod a) (Map g) \<star> src (MkArr (Dom a') (Cod a) (Map g))"
           using f by auto
         also have "... = MkArr (Dom a') (Cod a) (Map g) \<star> MkIde (E.Src (Cod a))"
           using a a' f src_def [of a] vconn_implies_hpar by auto
         also have "... = MkArr (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a))
                                (B.can (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B \<lbrace>E.Src (Cod a)\<rbrace>) \<cdot>\<^sub>B
                                  B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)))"
           using hcomp_def
           apply simp
           by (metis (no_types, lifting) Cod_cod arrE f in_homE trg_src src.preserves_arr src_def)
         also have "... = MkArr (Dom a') (Cod a)
                                (B.can (Cod a) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B
                                  B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a'))"
         proof -
           have "Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Dom a'"
             using a a' arr_char E.HcompNml_Nml_Src
             by (metis (no_types, lifting) f ideE src_simps(1) vconn_implies_hpar(3))
           moreover have "Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Cod a"
             using a a' arr_char E.HcompNml_Nml_Src by blast
           moreover have "\<lbrace>E.Src (Cod a)\<rbrace> = src\<^sub>B \<lbrace>Cod a\<rbrace>"
             using a a' arr_char E.eval_simps'(2) by fastforce
           ultimately show ?thesis by simp
         qed
         also have "... = MkArr (Dom a') (Cod a)
                                (B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace>)"
           by (metis (no_types, lifting) B.canE_unitor(1) B.canE_unitor(3) a a' arrE f ideE
               src_simps(1) vconn_implies_hpar(3))
         also have "... = MkArr (Dom g) (Cod g) (Map g)"
         proof -
           have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
             using a f g ide_char arr_char src_def B.comp_cod_arr
             by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
                 Cod.simps(1) Map.simps(1) in_homE)
           moreover have
             "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> = Map g"
           proof -
             have "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> =
                   B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit'\<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g ide_char arr_char B.runit'_naturality [of "Map g"]
               by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
             also have "... = (B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
               using B.comp_assoc by simp
             also have "... = \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g E.ide_eval_Ide B.comp_arr_inv' by fastforce
             also have "... = Map g"
               using g E.ide_eval_Ide B.comp_cod_arr by fastforce
             finally show ?thesis by simp
           qed
           ultimately have
             "B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace> = Map g"
             using a a' 1 2 f g hcomp_def dom_char cod_char
             by (metis (no_types, lifting) ideE)
           thus ?thesis
             using a 1 2 by auto
         qed
         also have "... = g"
            using g MkArr_Map by blast
         finally show ?thesis by simp
       qed
       ultimately show "\<exists>f. in_hom f a' a \<and> R f = g"
         by blast
     qed
 
     interpretation L: faithful_functor vcomp vcomp L
     proof
       fix f f'
       assume par: "par f f'" and eq: "L f = L f'"
       show "f = f'"
       proof (intro arr_eqI)
         have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
           using par dom_char cod_char by auto
         show "arr f"
           using par by simp
         show "arr f'"
           using par by simp
         show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
           using 1 by auto
         show "Map f = Map f'"
         proof -
           have "B.L (Map f) = trg\<^sub>B (Map f) \<star>\<^sub>B Map f"
             using par by auto
           also have "... = trg\<^sub>B (Map f') \<star>\<^sub>B Map f'"
           proof -
             have "\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f = \<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f'"
             proof -
               have A: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) :
                           \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>\<guillemotright>"
                 using par arr_char B.can_in_hom E.Ide_HcompNml
                       E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
                       src_def trg_def
                 by (metis (no_types, lifting) E.eval_simps(3) E.ide_eval_Ide E.Ide_implies_Arr
                     B.canE_unitor(4) B.lunit'_in_vhom)
               have B: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) :
                           \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f\<rbrace>\<guillemotright>"
                 using par arr_char B.can_in_hom E.Ide_HcompNml
                       E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
                       src_def trg_def
                 by (metis (no_types, lifting) E.Nmlize.simps(3) E.eval.simps(3) E.Ide.simps(3)
                     E.Ide_implies_Arr E.Src_Trg trg.preserves_arr trg_simps(2))
               have C: "\<guillemotleft>\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f :
                           \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace>\<guillemotright>"
                 using par arr_char
                 by (metis (no_types, lifting) E.eval_simps'(1) E.eval_simps(3) E.ide_eval_Ide
                     E.Ide_implies_Arr E.Obj_Trg E.Obj_implies_Ide B.hcomp_in_vhom
                     B.ide_in_hom(2) B.src_trg)
               have 3: "(\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
                           B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
                         (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
                             B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
               proof -
                 have 2: "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) \<cdot>\<^sub>B
                           (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
                             B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
                          B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f') \<cdot>\<^sub>B
                            (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
                              B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
                   using par eq hcomp_def trg_def src_trg trg.preserves_arr Map_hcomp
                         trg_simps(1) trg_simps(2) trg_simps(3)
                   by auto
                 have "B.mono (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))"
                   using par arr_char B.inverse_arrows_can B.iso_is_section B.section_is_mono
                         src_def trg_def E.Nmlize_Nml E.HcompNml_Trg_Nml E.Ide_implies_Arr
                         trg.preserves_arr trg_simps(1)
                   by auto
                 moreover have
                   "B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
                      ((\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
                        B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using A B C by auto
                 moreover have
                   "B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
                      ((\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
                        B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f'))"
                   using par 1 2 arr_char calculation(2) by auto
                 moreover have "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) =
                                B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f')"
                   using par 1 arr_char by simp
                 ultimately show ?thesis
                   using 2 B.monoE cod_char by auto
               qed
               show ?thesis
               proof -
                 have "B.epi (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using par arr_char B.inverse_arrows_can B.iso_is_retraction
                         B.retraction_is_epi E.Nmlize_Nml E.HcompNml_Trg_Nml src_def trg_def
                         E.Ide_implies_Arr
                   by (metis (no_types, lifting) E.Nmlize.simps(3) E.Ide.simps(3) E.Src_Trg
                       trg.preserves_arr trg_simps(1))
                 moreover have "B.seq (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f)
                                      (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using A C by auto
                 moreover have "B.seq (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f')
                                      (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using 1 3 calculation(2) by auto
                 ultimately show ?thesis
                   using par 1 3 arr_char B.epiE by simp
               qed
             qed
             moreover have "trg\<^sub>B (Map f) = \<lbrace>E.Trg (Dom f)\<rbrace> \<and>
                            trg\<^sub>B (Map f') = \<lbrace>E.Trg (Dom f')\<rbrace>"
               using par arr_char trg_def E.Ide_implies_Arr B.comp_arr_dom
                     B.vseq_implies_hpar(2) E.eval_simps(3)
               by (metis (no_types, lifting) B.vconn_implies_hpar(2))
             ultimately show ?thesis by simp
           qed
           also have "... = B.L (Map f')"
             using par B.hseqE B.hseq_char' by auto
           finally have "B.L (Map f) = B.L (Map f')"
             by simp
           thus ?thesis
             using 2 3 par arr_char B.L.is_faithful
             by (metis (no_types, lifting) B.in_homE)
         qed
       qed
     qed
 
     interpretation R: faithful_functor vcomp vcomp R
     proof
       fix f f'
       assume par: "par f f'" and eq: "R f = R f'"
       show "f = f'"
       proof (intro arr_eqI)
         have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
           using par dom_char cod_char by auto
         show "arr f"
           using par by simp
         show "arr f'"
           using par by simp
         show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
           using 1 by auto
         show "Map f = Map f'"
         proof -
           have "B.R (Map f) = Map f \<star>\<^sub>B src\<^sub>B (Map f)"
             using par apply simp by (metis B.hseqE B.hseq_char')
           also have "... = Map f' \<star>\<^sub>B src\<^sub>B (Map f')"
           proof -
             have "Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> = Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>"
             proof -
               have 2: "E.Ide (Cod f \<^bold>\<star> E.Src (Dom f))"
                 using par arr_char src.preserves_arr by auto
               hence 3: "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f))"
                 using par arr_char E.Nml_Src E.Ide_HcompNml calculation by auto
               have 4: "\<^bold>\<lfloor>Cod f \<^bold>\<star> E.Src (Dom f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<^bold>\<rfloor>"
                 using par arr_char by (simp add: E.Nml_HcompNml(1))
               have A: "\<guillemotleft>B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) :
                           \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
                 using par arr_char B.can_in_hom E.Ide_HcompNml
                       E.Ide_Nmlize_Ide E.Nml_Src E.Nmlize_Nml E.HcompNml_Nml_Src
                       src_def trg_def
                 by (metis (no_types, lifting) E.eval_simps(2) E.ide_eval_Ide E.Ide_implies_Arr
                     B.canE_unitor(3) B.runit'_in_vhom)
               have B: "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) :
                           \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace>\<guillemotright>"
                 using 2 3 4 B.can_in_hom [of "Cod f \<^bold>\<star> E.Src (Dom f)" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)"]
                 by simp
               have C: "\<guillemotleft>Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> :
                          \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
                 using par arr_char E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
                       src_def trg_def E.ide_eval_Ide E.Ide_implies_Arr E.Obj_implies_Ide
                 apply (intro B.hcomp_in_vhom)
                   apply (simp add: B.ide_in_hom(2))
                  apply simp
                 by (metis (no_types, lifting) A B.ideD(1) B.not_arr_null B.seq_if_composable
                     B.src.preserves_reflects_arr B.vconn_implies_hpar(3) E.HcompNml_Nml_Src)
               have 5: "(Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
                           B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
                         (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
                             B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
               proof -
                 have 6: "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
                            (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
                              B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
                          B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f')) \<cdot>\<^sub>B
                            (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
                              B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
                   using par eq hcomp_def src_def trg_src src.preserves_arr Map_hcomp
                         src_simps(1) src_simps(2) src_simps(3)
                   by auto
                 have "B.mono (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))"
                   using 2 3 4 B.inverse_arrows_can(1) B.iso_is_section B.section_is_mono
                   by simp
                 moreover have
                   "B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
                      ((Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
                        B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using A B C by auto
                 moreover have
                   "B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
                      ((Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
                        B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')))"
                   using par 1 6 arr_char calculation(2) by auto
                 moreover have "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) =
                                B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f'))"
                   using par 1 arr_char by simp
                 ultimately show ?thesis
                   using 6 B.monoE cod_char by auto
               qed
               show ?thesis
               proof -
                 have "B.epi (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using 2 3 4 B.inverse_arrows_can(1) B.iso_is_retraction B.retraction_is_epi
                   by (metis (no_types, lifting) E.Nml_Src E.Nmlize.simps(3) E.Nmlize_Nml
                       E.HcompNml_Nml_Src E.Ide.simps(3) par arrE)
                 moreover have "B.seq (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>)
                                    (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using A C by auto
                 moreover have "B.seq (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>)
                                    (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using 1 5 calculation(2) by auto
                 ultimately show ?thesis
                   using par 1 5 arr_char B.epiE by simp
               qed
             qed
             moreover have "src\<^sub>B (Map f) = \<lbrace>E.Src (Dom f)\<rbrace> \<and>
                            src\<^sub>B (Map f') = \<lbrace>E.Src (Dom f')\<rbrace>"
               using par arr_char src_def
               by (metis (no_types, lifting) B.vconn_implies_hpar(1) E.Nml_implies_Arr
                   E.eval_simps(2))
             ultimately show ?thesis by simp
           qed
           also have "... = B.R (Map f')"
             using par B.hseqE B.hseq_char' by auto
           finally have "B.R (Map f) = B.R (Map f')"
             by simp
           thus ?thesis
             using 2 3 par arr_char B.R.is_faithful
             by (metis (no_types, lifting) B.in_homE)
         qed
       qed
     qed
 
     definition \<a>
     where "\<a> \<tau> \<mu> \<nu> \<equiv> if VVV.arr (\<tau>, \<mu>, \<nu>) then hcomp \<tau> (hcomp \<mu> \<nu>) else null"
 
     interpretation natural_isomorphism VVV.comp vcomp HoHV HoVH
                      \<open>\<lambda>\<tau>\<mu>\<nu>. \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))\<close>
     proof
       show "\<And>\<tau>\<mu>\<nu>. \<not> VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow> \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>)) = null"
         using \<a>_def by simp
       show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                   dom (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = HoHV (VVV.dom \<tau>\<mu>\<nu>)"
         using VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<a>_def hcomp_assoc HoHV_def VVV.dom_simp VV.dom_simp
         by force
       show 1: "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                      cod (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = HoVH (VVV.cod \<tau>\<mu>\<nu>)"
         using VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C \<a>_def HoVH_def VVV.cod_simp VV.cod_simp by force
       show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                   HoVH \<tau>\<mu>\<nu> \<cdot>
                     \<a> (fst (VVV.dom \<tau>\<mu>\<nu>)) (fst (snd (VVV.dom \<tau>\<mu>\<nu>)))
                       (snd (snd (VVV.dom \<tau>\<mu>\<nu>))) =
                   \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
         using \<a>_def HoVH.as_nat_trans.is_natural_1 HoVH_def by auto
       show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                    \<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>)))
                      (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot> HoHV \<tau>\<mu>\<nu> =
                    \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
       proof -
         fix \<tau>\<mu>\<nu>
         assume \<tau>\<mu>\<nu>: "VVV.arr \<tau>\<mu>\<nu>"
         have "HoHV \<tau>\<mu>\<nu> = \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
           unfolding \<a>_def HoHV_def
           using \<tau>\<mu>\<nu> HoHV.preserves_cod hcomp_assoc VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C
           by simp
         thus "\<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>))) (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot>
                 HoHV \<tau>\<mu>\<nu> =
               \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
           using 1 \<tau>\<mu>\<nu> comp_cod_arr \<a>_def
           by (metis (no_types, lifting) HoVH_def HoHV.preserves_arr prod.collapse)
       qed
       show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<a> (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
         using \<a>_def HoVH.preserves_ide HoVH_def by auto
     qed
 
     definition \<i>
     where "\<i> \<equiv> \<lambda>a. a"
 
     sublocale bicategory vcomp hcomp \<a> \<i> src trg
       using hcomp_obj_self \<a>_def hcomp_assoc VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C
       apply unfold_locales
       by (auto simp add: \<i>_def ide_in_hom(2))
 
     lemma is_bicategory:
     shows "bicategory vcomp hcomp \<a> \<i> src trg"
       ..
 
     sublocale strict_bicategory vcomp hcomp \<a> \<i> src trg
     proof
       show "\<And>fgh. ide fgh \<Longrightarrow> lunit fgh = fgh"
       proof -
         fix fgh
         assume fgh: "ide fgh"
         have "fgh = lunit fgh"
         proof (intro lunit_eqI)
           show "ide fgh" using fgh by simp
           show "\<guillemotleft>fgh : trg fgh \<star> fgh \<Rightarrow> fgh\<guillemotright>"
             using fgh hcomp_def hcomp_trg_ide by auto
           show "trg fgh \<star> fgh = (\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
           proof -
             have "(\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh =
                   (trg fgh \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
               using fgh \<i>_def by metis
             also have "... = (trg fgh \<star> fgh) \<cdot> (trg fgh \<star> trg fgh \<star> fgh)"
               using fgh \<a>_def by fastforce
             also have "... = trg fgh \<star> fgh"
               using fgh hcomp_obj_self hcomp_assoc
               by (simp add: hcomp_trg_ide)
             finally show ?thesis by simp
           qed
         qed
         thus "lunit fgh = fgh" by simp
       qed
       show "\<And>fgh. ide fgh \<Longrightarrow> runit fgh = fgh"
       proof -
         fix fgh
         assume fgh: "ide fgh"
         have "fgh = runit fgh"
         proof (intro runit_eqI)
           show "ide fgh" using fgh by simp
           show "\<guillemotleft>fgh : fgh \<star> src fgh \<Rightarrow> fgh\<guillemotright>"
             using fgh hcomp_def hcomp_ide_src by auto
           show "fgh \<star> src fgh = (fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh)"
           proof -
             have "(fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh) =
                   (fgh \<star> src fgh) \<cdot> \<a> fgh (src fgh) (src fgh)"
               using fgh \<i>_def by metis
             also have "... = (fgh \<star> src fgh) \<cdot> (fgh \<star> src fgh \<star> src fgh)"
               using fgh \<a>_def by fastforce
             also have "... = fgh \<star> src fgh"
               using fgh comp_arr_dom hcomp_obj_self by simp
             finally show ?thesis by simp
           qed
         qed
         thus "runit fgh = fgh" by simp
       qed
       show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow> ide (\<a> f g h)"
         using \<a>_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C VVV.arr_char\<^sub>S\<^sub>b\<^sub>C by auto
     qed
 
     theorem is_strict_bicategory:
     shows "strict_bicategory vcomp hcomp \<a> \<i> src trg"
       ..
 
     lemma iso_char:
     shows "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
     and "iso \<mu> \<Longrightarrow> inv \<mu> = MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
     proof -
       have 1: "iso \<mu> \<Longrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
       proof -
         assume \<mu>: "iso \<mu>"
         obtain \<nu> where \<nu>: "inverse_arrows \<mu> \<nu>"
           using \<mu> by auto
         have "B.inverse_arrows (Map \<mu>) (Map \<nu>)"
         proof
           show "B.ide (Map \<mu> \<cdot>\<^sub>B Map \<nu>)"
           proof -
             have "Map \<mu> \<cdot>\<^sub>B Map \<nu> = Map (\<mu> \<cdot> \<nu>)"
               using \<mu> \<nu> inverse_arrows_def Map_comp arr_char seq_char
               by (metis (no_types, lifting) ide_compE)
             moreover have "B.ide ..."
               using \<nu> ide_char by blast
             ultimately show ?thesis by simp
           qed
           show "B.ide (Map \<nu> \<cdot>\<^sub>B Map \<mu>)"
           proof -
             have "Map \<nu> \<cdot>\<^sub>B Map \<mu> = Map (\<nu> \<cdot> \<mu>)"
               using \<mu> \<nu> inverse_arrows_def comp_char [of \<nu> \<mu>] by simp
             moreover have "B.ide ..."
               using \<nu> ide_char by blast
             ultimately show ?thesis by simp
           qed
         qed
         thus "arr \<mu> \<and> B.iso (Map \<mu>)"
           using \<mu> by auto
       qed
       let ?\<nu> = "MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
       have 2: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu> \<and> inv \<mu> = ?\<nu>"
       proof
         assume \<mu>: "arr \<mu> \<and> B.iso (Map \<mu>)"
         have \<nu>: "\<guillemotleft>?\<nu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
           using \<mu> arr_char dom_char cod_char by auto
         have 4: "inverse_arrows \<mu> ?\<nu>"
         proof
           show "ide (?\<nu> \<cdot> \<mu>)"
           proof -
             have "?\<nu> \<cdot> \<mu> = dom \<mu>"
               using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_inv_arr' dom_char by auto
             thus ?thesis
               using \<mu> by simp
           qed
           show "ide (\<mu> \<cdot> ?\<nu>)"
           proof -
             have "\<mu> \<cdot> ?\<nu> = cod \<mu>"
               using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_arr_inv' cod_char by auto
             thus ?thesis
               using \<mu> by simp
           qed
         qed
         thus "iso \<mu>" by auto
         show "inv \<mu> = ?\<nu>"
           using 4 inverse_unique by simp
       qed
       have 3: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu>"
         using 2 by simp
       show "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
         using 1 3 by blast
       show "iso \<mu> \<Longrightarrow> inv \<mu> = ?\<nu>"
         using 1 2 by blast
     qed
 
     subsection "The Strictness Theorem"
 
     text \<open>
       The Strictness Theorem asserts: ``Every bicategory is biequivalent to a strict bicategory.''
       This amounts to an equivalent (and perhaps more desirable) formulation of the
       Coherence Theorem.
       In this section we prove the Strictness Theorem by constructing an equivalence pseudofunctor
       from a bicategory to its strictification.
     \<close>
 
     text \<open>
       We define a map \<open>UP\<close> from the given bicategory \<open>B\<close> to its strictification,
       and show that it is an equivalence pseudofunctor.
       The following auxiliary definition is not logically necessary, but it provides some
       terms that can be the targets of simplification rules and thereby enables some proofs
       to be done by simplification that otherwise could not be.  Trying to eliminate it
       breaks some short proofs below, so I have kept it.
     \<close>
 
     definition UP\<^sub>0
     where "UP\<^sub>0 a \<equiv> if B.obj a then MkIde \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 else null"
 
     lemma obj_UP\<^sub>0 [simp]:
     assumes "B.obj a"
     shows "obj (UP\<^sub>0 a)"
       unfolding obj_def
       using assms UP\<^sub>0_def ide_MkIde [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] src_def by simp
 
     lemma UP\<^sub>0_in_hom [intro]:
     assumes "B.obj a"
     shows "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<rightarrow> UP\<^sub>0 a\<guillemotright>"
     and "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<Rightarrow> UP\<^sub>0 a\<guillemotright>"
       using assms obj_UP\<^sub>0 by blast+
 
     lemma UP\<^sub>0_simps [simp]:
     assumes "B.obj a"
     shows "ide (UP\<^sub>0 a)" "arr (UP\<^sub>0 a)"
     and "src (UP\<^sub>0 a) = UP\<^sub>0 a" and "trg (UP\<^sub>0 a) = UP\<^sub>0 a"
     and "dom (UP\<^sub>0 a) = UP\<^sub>0 a" and "cod (UP\<^sub>0 a) = UP\<^sub>0 a"
       using assms obj_UP\<^sub>0
            apply blast
       using assms obj_UP\<^sub>0 obj_simps
       by simp_all
 
     definition UP
     where "UP \<mu> \<equiv> if B.arr \<mu> then MkArr \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle> \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle> \<mu> else null"
 
     lemma Dom_UP [simp]:
     assumes "B.arr \<mu>"
     shows "Dom (UP \<mu>) = \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle>"
       using assms UP_def by fastforce
 
     lemma Cod_UP [simp]:
     assumes "B.arr \<mu>"
     shows "Cod (UP \<mu>) = \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle>"
       using assms UP_def by fastforce
 
     lemma Map_UP [simp]:
     assumes "B.arr \<mu>"
     shows "Map (UP \<mu>) = \<mu>"
       using assms UP_def by fastforce
 
     lemma arr_UP:
     assumes "B.arr \<mu>"
     shows "arr (UP \<mu>)"
       using assms UP_def
       by (intro arrI, fastforce+)
 
     lemma UP_in_hom [intro]:
     assumes "B.arr \<mu>"
     shows "\<guillemotleft>UP \<mu> : UP\<^sub>0 (src\<^sub>B \<mu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B \<mu>)\<guillemotright>"
     and "\<guillemotleft>UP \<mu> : UP (B.dom \<mu>) \<Rightarrow> UP (B.cod \<mu>)\<guillemotright>"
       using assms arr_UP UP_def UP\<^sub>0_def dom_char cod_char src_def trg_def by auto
 
     lemma UP_simps [simp]:
     assumes "B.arr \<mu>"
     shows "arr (UP \<mu>)"
     and "src (UP \<mu>) = UP\<^sub>0 (src\<^sub>B \<mu>)" and "trg (UP \<mu>) = UP\<^sub>0 (trg\<^sub>B \<mu>)"
     and "dom (UP \<mu>) = UP (B.dom \<mu>)" and "cod (UP \<mu>) = UP (B.cod \<mu>)"
       using assms arr_UP UP_in_hom by auto
 
     interpretation UP: "functor" V\<^sub>B vcomp UP
       using UP_def arr_UP UP_simps(4-5) arr_UP UP_def comp_char seq_char
       by unfold_locales auto
 
     interpretation UP: weak_arrow_of_homs V\<^sub>B src\<^sub>B trg\<^sub>B vcomp src trg UP
     proof
       fix \<mu>
       assume \<mu>: "B.arr \<mu>"
       show "isomorphic (UP (src\<^sub>B \<mu>)) (src (UP \<mu>))"
       proof -
         let ?\<phi> = "MkArr \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (src\<^sub>B \<mu>)"
         have \<phi>: "\<guillemotleft>?\<phi> : UP (src\<^sub>B \<mu>) \<Rightarrow> src (UP \<mu>)\<guillemotright>"
         proof
           show 1: "arr ?\<phi>"
             using \<mu> by (intro arrI, auto)
           show "dom ?\<phi> = UP (src\<^sub>B \<mu>)"
             using \<mu> 1 dom_char UP_def by simp
           show "cod ?\<phi> = src (UP \<mu>)"
             using \<mu> 1 cod_char src_def by auto
         qed
         have "iso ?\<phi>"
           using \<mu> \<phi> iso_char src_def by auto
         thus ?thesis
           using \<phi> isomorphic_def by auto
       qed
       show "isomorphic (UP (trg\<^sub>B \<mu>)) (trg (UP \<mu>))"
       proof -
         let ?\<phi> = "MkArr \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B \<mu>)"
         have \<phi>: "\<guillemotleft>?\<phi> : UP (trg\<^sub>B \<mu>) \<Rightarrow> trg (UP \<mu>)\<guillemotright>"
         proof
           show 1: "arr ?\<phi>"
             using \<mu> by (intro arrI, auto)
           show "dom ?\<phi> = UP (trg\<^sub>B \<mu>)"
             using \<mu> 1 dom_char UP_def by simp
           show "cod ?\<phi> = trg (UP \<mu>)"
             using \<mu> 1 cod_char trg_def by auto
         qed
         have "iso ?\<phi>"
           using \<mu> \<phi> iso_char trg_def by auto
         thus ?thesis
           using \<phi> isomorphic_def by auto
       qed
     qed
 
     interpretation HoUP_UP: composite_functor B.VV.comp VV.comp vcomp
                               UP.FF \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
     interpretation UPoH: composite_functor B.VV.comp V\<^sub>B vcomp
                            \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close> UP ..
 
     abbreviation \<Phi>\<^sub>o
     where "\<Phi>\<^sub>o fg \<equiv> MkArr (\<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>) \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle> (fst fg \<star>\<^sub>B snd fg)"
 
     interpretation \<Phi>: transformation_by_components
                         B.VV.comp vcomp HoUP_UP.map UPoH.map \<Phi>\<^sub>o
     proof
       fix fg
       assume fg: "B.VV.ide fg"
       show "\<guillemotleft>\<Phi>\<^sub>o fg : HoUP_UP.map fg \<Rightarrow> UPoH.map fg\<guillemotright>"
       proof (intro in_homI)
         show 1: "arr (\<Phi>\<^sub>o fg)"
           using fg arr_char B.VV.ide_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C by auto
         show "dom (\<Phi>\<^sub>o fg) = HoUP_UP.map fg"
           using 1 fg UP.FF_def B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.VV.ide_char\<^sub>S\<^sub>b\<^sub>C dom_char hcomp_def B.can_Ide_self
           by simp
         show "cod (\<Phi>\<^sub>o fg) = UPoH.map fg"
           using fg arr_char cod_char B.VV.ide_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C UP_def by auto
       qed
       next
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "B.VV.arr \<mu>\<nu>"
       show "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
       proof -
         have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
               MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                     (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                     (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
         proof -
           have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
                 MkArr (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>) (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>
                 MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char UP.FF_def hcomp_def UP_def B.VV.cod_simp
                   src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
             by auto
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  ((B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>))"
             using \<mu>\<nu> B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C
             by (intro comp_MkArr arr_MkArr, auto)
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.comp_cod_arr by auto
           finally show ?thesis by simp
         qed
         also have "... = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
         proof -
           have "UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>) =
                 MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>
                 MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>))"
             using \<mu>\<nu> B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char UP.FF_def hcomp_def UP_def B.VV.dom_simp
                   src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
             by auto
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  ((fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>\<^sub>B (B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)))"
             using \<mu>\<nu> B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_MkArr
             apply (intro comp_MkArr arr_MkArr) by auto
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.comp_arr_dom by auto
          finally show ?thesis by simp
         qed
         finally show ?thesis by simp
       qed
     qed
 
     abbreviation cmp\<^sub>U\<^sub>P
     where "cmp\<^sub>U\<^sub>P \<equiv> \<Phi>.map"
 
     lemma cmp\<^sub>U\<^sub>P_in_hom [intro]:
     assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
     shows "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>)) \<rightarrow> UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))\<guillemotright>"
     and "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> : UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))
                     \<Rightarrow> UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))\<guillemotright>"
     proof -
       let ?\<mu> = "fst \<mu>\<nu>" and ?\<nu> = "snd \<mu>\<nu>"
       show 1: "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> :
                   UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>) \<Rightarrow> UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)\<guillemotright>"
       proof
         show "arr (cmp\<^sub>U\<^sub>P \<mu>\<nu>)"
           using assms by auto
         show "dom (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
         proof -
           have "B.VV.in_hom (?\<mu>, ?\<nu>) (B.dom ?\<mu>, B.dom ?\<nu>) (B.cod ?\<mu>, B.cod ?\<nu>)"
             using assms B.VV.in_hom_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C by auto
           hence "dom (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = HoUP_UP.map (B.dom ?\<mu>, B.dom ?\<nu>)"
             by auto
           also have "... = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
             using assms UP.FF_def by fastforce
           finally show ?thesis by simp
         qed
         show "cod (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)"
           using assms B.VV.in_hom_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.VV.cod_simp by auto
       qed
       show "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B ?\<nu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B ?\<mu>)\<guillemotright>"
         using assms 1 src_dom [of "cmp\<^sub>U\<^sub>P \<mu>\<nu>"] trg_dom [of "cmp\<^sub>U\<^sub>P \<mu>\<nu>"] by fastforce
     qed
 
     lemma cmp\<^sub>U\<^sub>P_simps [simp]:
     assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
     shows "arr (cmp\<^sub>U\<^sub>P \<mu>\<nu>)"
     and "src (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>))" and "trg (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))"
     and "dom (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))"
     and "cod (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))"
       using assms cmp\<^sub>U\<^sub>P_in_hom [of \<mu>\<nu>] by auto
 
     lemma cmp\<^sub>U\<^sub>P_ide_simps [simp]:
     assumes "B.ide (fst fg)" and "B.ide (snd fg)" and "src\<^sub>B (fst fg) = trg\<^sub>B (snd fg)"
     shows "Dom (cmp\<^sub>U\<^sub>P fg) = \<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>"
     and "Cod (cmp\<^sub>U\<^sub>P fg) = \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle>"
     and "Map (cmp\<^sub>U\<^sub>P fg) = fst fg \<star>\<^sub>B snd fg"
       using assms B.VV.ide_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C by auto
 
     interpretation \<Phi>: natural_isomorphism
                         B.VV.comp vcomp HoUP_UP.map UPoH.map cmp\<^sub>U\<^sub>P
     proof
       fix fg
       assume fg: "B.VV.ide fg"
       have "arr (cmp\<^sub>U\<^sub>P fg)"
         using fg \<Phi>.preserves_reflects_arr [of fg] by simp
       thus "iso (cmp\<^sub>U\<^sub>P fg)"
         using fg iso_char by simp
     qed
 
     lemma cmp\<^sub>U\<^sub>P_ide_simp:
     assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
     shows "cmp\<^sub>U\<^sub>P (f, g) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
       using assms B.VV.ide_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
 
     lemma cmp\<^sub>U\<^sub>P'_ide_simp:
     assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
     shows "inv (cmp\<^sub>U\<^sub>P (f, g)) = MkArr \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
       using assms cmp\<^sub>U\<^sub>P_ide_simp iso_char \<Phi>.components_are_iso [of "(f, g)"]
             B.VV.ide_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C
       by simp
 
     interpretation UP: pseudofunctor
                          V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P
     proof
       fix f g h
       assume f: "B.ide f" and g: "B.ide g" and h: "B.ide h"
       and fg: "src\<^sub>B f = trg\<^sub>B g" and gh: "src\<^sub>B g = trg\<^sub>B h"
       show "UP \<a>\<^sub>B[f, g, h] \<cdot> cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) \<cdot> (cmp\<^sub>U\<^sub>P (f, g) \<star> UP h) =
             cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
       proof -
         have "UP \<a>\<^sub>B[f, g, h] \<cdot> cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) \<cdot> (cmp\<^sub>U\<^sub>P (f, g) \<star> UP h) =
               MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
         proof -
           have 1: "UP.hseq\<^sub>D (MkIde \<^bold>\<langle>f\<^bold>\<rangle>) (MkIde \<^bold>\<langle>g\<^bold>\<rangle>)"
             using f g fg hseq_char src_def trg_def arr_char by auto
           have 2: "UP.hseq\<^sub>D (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>))
                             (MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
           proof -
             have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
             proof -
               have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
                     MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
                 using f g fg by simp
               also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<cdot>\<^sub>B (f \<star>\<^sub>B g))"
                 using f g fg by (intro comp_MkArr arr_MkArr, auto)
               also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
                 using f g fg by simp
               finally show ?thesis by blast
             qed
             thus ?thesis
               using f g h fg gh arr_char src_def trg_def by auto
           qed
           have "UP \<a>\<^sub>B[f, g, h] = MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h]"
             using f g h fg gh UP_def B.HoHV_def B.HoVH_def B.VVV.arr_char\<^sub>S\<^sub>b\<^sub>C B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                   B.VVV.dom_char\<^sub>S\<^sub>b\<^sub>C B.VVV.cod_char\<^sub>S\<^sub>b\<^sub>C
             by simp
           moreover have
             "cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) = MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
                                   MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)"
             using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C UP.FF_def B.VV.cod_simp
                   hcomp_def B.can_Ide_self
             by simp
           moreover have "cmp\<^sub>U\<^sub>P (f, g) \<star> UP h =
                          MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
           proof -
             have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)
                         (B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<cdot>\<^sub>B (f \<star>\<^sub>B g) \<cdot>\<^sub>B B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)) =
                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
               using f g fg B.can_Ide_self B.comp_arr_dom B.comp_cod_arr by simp
             moreover have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot>
                              MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g) =
                            MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
               by (metis (no_types, lifting) 2 B.ideD(1) E.eval.simps(2-3) cod_MkArr
                   comp_arr_ide f g ide_char' seq_char)
             moreover have "B.can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) = B.inv \<a>\<^sub>B[f, g, h]"
               using f g h fg gh B.canI_associator_0 B.inverse_arrows_can by simp
             ultimately show ?thesis
               using 1 2 f g h fg gh \<Phi>.map_def UP_def hcomp_def UP.FF_def
                     B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.can_Ide_self B.comp_cod_arr B.VV.cod_simp
               by simp
           qed
           ultimately have "UP \<a>\<^sub>B[f, g, h] \<cdot> cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) \<cdot> (cmp\<^sub>U\<^sub>P (f, g) \<star> UP h) =
                            MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h] \<cdot>
                              MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
                                MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
                                  MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
             using comp_assoc by presburger
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle>
                                  (\<a>\<^sub>B[f, g, h] \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B
                                    B.inv \<a>\<^sub>B[f, g, h])"
           proof -
             have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])) \<and>
                      Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
                      Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)
                                 (((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
                      Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
                      Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle>
                           (((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
                      Arr (MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h])"
               using f g h fg gh B.\<alpha>.preserves_hom B.HoHV_def B.HoVH_def by auto
             thus ?thesis
               using f g h fg gh comp_def B.comp_arr_dom B.comp_cod_arr by simp
           qed
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
             using B.comp_cod_arr B.comp_arr_inv'
             by (auto simp add: f fg g gh h)
           finally show ?thesis by simp
         qed
         also have "... = cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
         proof -
           have "cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h) =
                 cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot>
                 (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
             using f g h fg gh VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char src_def trg_def UP_def \<a>_def
             by auto
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                             MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                              MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                               MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
           proof -
             have "cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
               using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def UP.FF_def UP_def hcomp_def
                     B.VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.can_Ide_self B.comp_arr_dom B.comp_cod_arr src_def trg_def
                     arr_char B.VV.cod_simp
               by auto
             moreover
             have "cmp\<^sub>U\<^sub>P (g, h) = MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h)"
               using g h gh cmp\<^sub>U\<^sub>P_ide_simp by blast
             moreover have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h) =
                            MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
               using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
                     B.comp_arr_dom B.comp_cod_arr
               by auto
             moreover
             have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle> =
                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
             proof -
               have "\<guillemotleft>f : f \<Rightarrow>\<^sub>B f\<guillemotright> \<and> \<guillemotleft>g : g \<Rightarrow>\<^sub>B g\<guillemotright> \<and> \<guillemotleft>h : h \<Rightarrow>\<^sub>B h\<guillemotright>"
                 using f g h by auto
               thus ?thesis
                 using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
                       B.comp_arr_dom B.comp_cod_arr
                 by auto
             qed
             ultimately show ?thesis
               using comp_assoc by auto
           qed
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
           proof -
             have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
                   Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
                   Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
                   Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h))"
               using f g h fg gh by auto
             thus ?thesis
               using f g h fg gh comp_def by auto
           qed
           finally show ?thesis by simp
         qed
         finally show ?thesis by blast
       qed
     qed
 
     lemma UP_is_pseudofunctor:
     shows "pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P" ..
 
     lemma UP_map\<^sub>0_obj [simp]:
     assumes "B.obj a"
     shows "UP.map\<^sub>0 a = UP\<^sub>0 a"
       using assms UP.map\<^sub>0_def by auto
 
     interpretation UP: full_functor V\<^sub>B vcomp UP
     proof
       fix \<mu> f g
       assume f: "B.ide f" and g: "B.ide g"
       assume \<mu>: "\<guillemotleft>\<mu> : UP f \<Rightarrow> UP g\<guillemotright>"
       show "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow>\<^sub>B g\<guillemotright> \<and> UP \<nu> = \<mu>"
       proof -
         have 1: "\<guillemotleft>Map \<mu> : f \<Rightarrow>\<^sub>B g\<guillemotright>"
           using f g \<mu> UP_def arr_char in_hom_char by auto
         moreover have "UP (Map \<mu>) = \<mu>"
         proof -
           have "\<mu> = MkArr (Dom \<mu>) (Cod \<mu>) (Map \<mu>)"
             using \<mu> MkArr_Map by auto
           also have "... = UP (Map \<mu>)"
             using "1" B.arrI UP.as_nat_trans.preserves_hom UP_def \<mu> in_hom_char by force
           finally show ?thesis by auto
         qed
         ultimately show ?thesis by blast
       qed
     qed
 
     interpretation UP: faithful_functor V\<^sub>B vcomp UP
       using arr_char UP_def
       by (unfold_locales, simp_all)
 
     interpretation UP: fully_faithful_functor V\<^sub>B vcomp UP ..
 
     lemma UP_is_fully_faithful_functor:
     shows "fully_faithful_functor V\<^sub>B vcomp UP"
       ..
 
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")   (* Inherited from functor, I think. *)
 
     lemma Map_reflects_hhom:
     assumes "B.obj a" and "B.obj b" and "ide g"
     and "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
     shows "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
     proof
       have 1: "B.ide (Map g)"
         using assms ide_char by blast
       show "B.arr (Map g)"
         using 1 by simp
       show "src\<^sub>B (Map g) = a"
       proof -
         have "src\<^sub>B (Map g) = Map (src g)"
           using assms src_def apply simp
           by (metis (no_types, lifting) E.eval_simps(2) E.Ide_implies_Arr arr_char ideE)
         also have "... = Map (UP.map\<^sub>0 a)"
           using assms by (metis (no_types, lifting) in_hhomE)
         also have "... = a"
           using assms UP.map\<^sub>0_def UP_def [of a] src_def by auto
         finally show ?thesis by simp
       qed
       show "trg\<^sub>B (Map g) = b"
       proof -
         have "trg\<^sub>B (Map g) = Map (trg g)"
           using assms trg_def apply simp
           by (metis (no_types, lifting) E.eval_simps(3) E.Ide_implies_Arr arr_char ideE)
         also have "... = Map (UP.map\<^sub>0 b)"
           using assms by (metis (no_types, lifting) in_hhomE)
         also have "... = b"
           using assms UP.map\<^sub>0_def UP_def [of b] src_def by auto
         finally show ?thesis by simp
       qed
     qed
 
     lemma eval_Dom_ide [simp]:
     assumes "ide g"
     shows "\<lbrace>Dom g\<rbrace> = Map g"
       using assms dom_char ideD by auto
 
     lemma Cod_ide:
     assumes "ide f"
     shows "Cod f = Dom f"
       using assms dom_char by auto
 
     lemma Map_preserves_objects:
     assumes "obj a"
     shows "B.obj (Map a)"
     proof -
       have "src\<^sub>B (Map a) = Map (src a)"
         using assms src_def apply simp
         using E.eval_simps(2) E.Ide_implies_Arr arr_char ideE
         by (metis (no_types, lifting) objE)
       also have 1: "... = \<lbrace>E.Src (Dom a)\<rbrace>"
         using assms src_def by auto
       also have "... = \<lbrace>\<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0\<rbrace>"
         using assms B.src.is_extensional 1 obj_simps(2) by force
       also have "... = Map a"
         using assms by auto
       finally have "src\<^sub>B (Map a) = Map a" by simp
       moreover have "B.arr (Map a)"
         using assms B.ideD arr_char by auto
       ultimately show ?thesis
         using B.obj_def by simp
     qed
 
     interpretation UP: equivalence_pseudofunctor
                          V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P
     proof
       (* UP is full, hence locally full. *)
       show "\<And>f f' \<nu>. \<lbrakk> B.ide f; B.ide f'; src\<^sub>B f = src\<^sub>B f'; trg\<^sub>B f = trg\<^sub>B f';
                        \<guillemotleft>\<nu> : UP f \<Rightarrow> UP f'\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> UP \<mu> = \<nu>"
         using UP.is_full by simp
       (* UP is biessentially surjective on objects. *)
       show "\<And>b. obj b \<Longrightarrow> \<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
       proof -
         fix b
         assume b: "obj b"
         have 1: "B.obj (Map b)"
           using b Map_preserves_objects by simp
         have 3: "UP.map\<^sub>0 (Map b) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
           using b 1 UP.map\<^sub>0_def [of "Map b"] UP_def src_def arr_char by auto
         have 4: "b = MkArr (Dom b) (Dom b) (Map b)"
           using b objE eval_Dom_ide
           by (metis (no_types, lifting) dom_char ideD(2) obj_def)
         let ?\<phi> = "MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Dom b) (Map b)"
         have \<phi>: "arr ?\<phi>"
         proof -
           have 2: "E.Obj (Dom b)"
             using b obj_char by blast
           have "E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0"
             using 1 by auto
           moreover have "E.Nml (Dom b) \<and> E.Ide (Dom b)"
             using b arr_char [of b] by auto
           moreover have "E.Src \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Src (Dom b)"
             using b 1 2
             apply (cases "Dom b")
                      apply simp_all
             by fastforce
           moreover have "E.Trg \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Trg (Dom b)"
             using b 1 2
             apply (cases "Dom b")
                      apply simp_all
             by fastforce
           moreover have "\<guillemotleft>Map b : \<lbrace>\<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom b\<rbrace>\<guillemotright>"
             using b 1 by (elim objE, auto)
           ultimately show ?thesis
             using arr_char \<open>E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<close> by auto
         qed
         hence "iso ?\<phi>"
           using 1 iso_char by auto
         moreover have "dom ?\<phi> = UP.map\<^sub>0 (Map b)"
           using \<phi> dom_char b 1 3 B.objE UP.map\<^sub>0_def UP_def src_def by auto
         moreover have "cod ?\<phi> = b"
           using \<phi> cod_char b 4 1 by auto
         ultimately have "isomorphic (UP.map\<^sub>0 (Map b)) b"
           using \<phi> 3 4 isomorphic_def by blast
         moreover have 5: "obj (UP.map\<^sub>0 (Map b))"
           using 1 UP.map\<^sub>0_simps(2) by simp
         ultimately have 6: "UP.map\<^sub>0 (Map b) = b"
           using b isomorphic_objects_are_equal by simp
         have "equivalent_objects (UP.map\<^sub>0 (Map b)) b"
           using b 6 equivalent_objects_reflexive [of b] by simp
         thus "\<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
           using 1 6 by auto
       qed
       (* UP is locally essentially surjective. *)
       show "\<And>a b g. \<lbrakk> B.obj a; B.obj b; \<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>; ide g \<rbrakk> \<Longrightarrow>
                         \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
       proof -
         fix a b g
         assume a: "B.obj a" and b: "B.obj b"
         assume g_in_hhom: "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
         assume ide_g: "ide g"
         have 1: "B.ide (Map g)"
           using ide_g ide_char by blast
         have "arr (UP a)"
           using a by auto
         have "arr (UP b)"
           using b by auto
         have Map_g_eq: "Map g = \<lbrace>Dom g\<rbrace>"
           using ide_g by simp
         have Map_g_in_hhom: "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
           using a b ide_g g_in_hhom Map_reflects_hhom by simp
 
         let ?\<phi> = "MkArr \<^bold>\<langle>Map g\<^bold>\<rangle> (Dom g) (Map g)"
         have \<phi>: "arr ?\<phi>"
         proof -
           have "\<guillemotleft>Map ?\<phi> : \<lbrace>Dom ?\<phi>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<phi>\<rbrace>\<guillemotright>"
             using 1 Map_g_eq by auto
           moreover have "E.Ide \<^bold>\<langle>Map g\<^bold>\<rangle> \<and> E.Nml \<^bold>\<langle>Map g\<^bold>\<rangle>"
             using 1 by simp
           moreover have "E.Ide (Dom g) \<and> E.Nml (Dom g)"
             using ide_g arr_char ide_char by blast
           moreover have "E.Src \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Src (Dom g)"
             using ide_g g_in_hhom src_def Map_g_in_hhom
             by (metis (no_types, lifting) B.ideD(2) B.in_hhom_def B.objE B.obj_def'
                 Dom.simps(1) E.Src.simps(2) UP.map\<^sub>0_def \<open>arr (UP a)\<close> a in_hhomE UP_def)
           moreover have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Trg (Dom g)"
           proof -
             have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
               using Map_g_in_hhom by auto
             also have "... = E.Trg (Dom g)"
             proof -
               have "E.Trg (Dom g) = Dom (trg g)"
                 using ide_g trg_def by simp
               also have "... = Dom (UP.map\<^sub>0 b)"
                 using g_in_hhom by auto
               also have "... = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
                 using b \<open>arr (UP b)\<close> UP.map\<^sub>0_def src_def UP_def B.objE by auto
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
           ultimately show ?thesis
             using arr_char by simp
         qed
         have "\<guillemotleft>?\<phi> : UP (Map g) \<Rightarrow> g\<guillemotright>"
           by (simp add: "1" \<phi> ide_g in_hom_char)
         moreover have "iso ?\<phi>"
           using \<phi> 1 iso_char by simp
         ultimately have "isomorphic (UP (Map g)) g"
           using isomorphic_def by auto
         thus "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
           using 1 Map_g_in_hhom by auto
       qed
     qed
 
     theorem UP_is_equivalence_pseudofunctor:
     shows "equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg
              UP cmp\<^sub>U\<^sub>P"
       ..
 
     text \<open>
       Next, we work out the details of the equivalence pseudofunctor \<open>DN\<close> in the
       converse direction.
     \<close>
 
     definition DN
     where "DN \<mu> \<equiv> if arr \<mu> then Map \<mu> else B.null"
 
     lemma DN_in_hom [intro]:
     assumes "arr \<mu>"
     shows "\<guillemotleft>DN \<mu> : DN (src \<mu>) \<rightarrow>\<^sub>B DN (trg \<mu>)\<guillemotright>"
     and "\<guillemotleft>DN \<mu> : DN (dom \<mu>) \<Rightarrow>\<^sub>B DN (cod \<mu>)\<guillemotright>"
       using assms DN_def arr_char [of \<mu>] B.vconn_implies_hpar(1-2) E.eval_in_hom(1)
             B.in_hhom_def
       by auto
 
     lemma DN_simps [simp]:
     assumes "arr \<mu>"
     shows "B.arr (DN \<mu>)"
     and "src\<^sub>B (DN \<mu>) = DN (src \<mu>)" and "trg\<^sub>B (DN \<mu>) = DN (trg \<mu>)"
     and "B.dom (DN \<mu>) = DN (dom \<mu>)" and "B.cod (DN \<mu>) = DN (cod \<mu>)"
       using assms DN_in_hom by auto
 
     interpretation "functor" vcomp V\<^sub>B DN
       using DN_def seqE Map_comp seq_char
       by unfold_locales auto
 
     interpretation DN: weak_arrow_of_homs vcomp src trg V\<^sub>B src\<^sub>B trg\<^sub>B DN
     proof
       fix \<mu>
       assume \<mu>: "arr \<mu>"
       show "B.isomorphic (DN (src \<mu>)) (src\<^sub>B (DN \<mu>))"
       proof -
         have "DN (src \<mu>) = src\<^sub>B (DN \<mu>)"
           using B.src.is_extensional DN_def DN_simps(2) by auto
         moreover have "B.ide (DN (src \<mu>))"
           using \<mu> by simp
         ultimately show ?thesis
           using \<mu> B.isomorphic_reflexive by auto
       qed
       show "B.isomorphic (DN (trg \<mu>)) (trg\<^sub>B (DN \<mu>))"
       proof -
         have "DN (trg \<mu>) = trg\<^sub>B (DN \<mu>)"
           using \<open>B.isomorphic (DN (src \<mu>)) (src\<^sub>B (DN \<mu>))\<close> by fastforce
         moreover have "B.ide (DN (trg \<mu>))"
           using \<mu> by simp
         ultimately show ?thesis
           using B.isomorphic_reflexive by auto
       qed
     qed
 
     interpretation "functor" VV.comp B.VV.comp DN.FF
       using DN.functor_FF by auto
     interpretation HoDN_DN: composite_functor VV.comp B.VV.comp V\<^sub>B
                       DN.FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>B (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
     interpretation DNoH: composite_functor VV.comp vcomp V\<^sub>B
                       \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> DN ..
 
     abbreviation \<Psi>\<^sub>o
     where "\<Psi>\<^sub>o fg \<equiv> B.can (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
 
     abbreviation \<Psi>\<^sub>o'
     where "\<Psi>\<^sub>o' fg \<equiv> B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
 
     lemma \<Psi>\<^sub>o_in_hom:
     assumes "VV.ide fg"
     shows "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
     and "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
     and "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
     proof -
       have 1: "E.Ide (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
         unfolding E.Ide.simps(3)
         apply (intro conjI)
         using assms VV.ide_char VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char
           apply simp
         using VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ideD(1) assms
          apply blast
         by (metis (no_types, lifting) VV.arrE VV.ideD(1) assms src_simps(1) trg_simps(1))
       have 2: "E.Ide (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
         using 1
         by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ideD(1) arr_char assms)
       have 3: "\<^bold>\<lfloor>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<^bold>\<rfloor>"
         by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
             E.Nmlize_Nml VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ideD(1) arr_char assms 1)
       have 4: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
         using assms VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char by simp
       show "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
         using 1 2 3 4 by auto
       show "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
         using 1 2 3 4 by auto
       show "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
         using 1 2 3 B.inverse_arrows_can by blast
     qed
 
     interpretation \<Psi>: transformation_by_components
                          VV.comp V\<^sub>B HoDN_DN.map DNoH.map \<Psi>\<^sub>o
     proof
       fix fg
       assume fg: "VV.ide fg"
       have 1: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
         using fg VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char by simp
       show "\<guillemotleft>\<Psi>\<^sub>o fg : HoDN_DN.map fg \<Rightarrow>\<^sub>B DNoH.map fg\<guillemotright>"
       proof
         show "B.arr (\<Psi>\<^sub>o fg)"
           using fg \<Psi>\<^sub>o_in_hom by blast
         show "B.dom (\<Psi>\<^sub>o fg) = HoDN_DN.map fg"
         proof -
           have "B.dom (\<Psi>\<^sub>o fg) = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
             using fg \<Psi>\<^sub>o_in_hom by blast
           also have "... = HoDN_DN.map fg"
             using fg DN.FF_def DN_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C src_def trg_def VV.ide_char\<^sub>S\<^sub>b\<^sub>C by auto
           finally show ?thesis by simp
         qed
         show "B.cod (\<Psi>\<^sub>o fg) = DNoH.map fg"
         proof -
           have "B.cod (\<Psi>\<^sub>o fg) = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
             using fg \<Psi>\<^sub>o_in_hom by blast
           also have "... = DNoH.map fg"
           proof -
             have "DNoH.map fg = 
                   B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
                     (Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
                       B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
               using fg DN_def Map_hcomp VV.arr_char\<^sub>S\<^sub>b\<^sub>C
               apply simp
               using VV.ideD(1) by blast
             also have "... =
                        B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
                          B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
             proof -
               have "(Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
                       B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) =
                     B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
                 using fg 1 \<Psi>\<^sub>o_in_hom B.comp_cod_arr by blast
               thus ?thesis by simp
             qed
             also have "... = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
             proof -
               have "B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) = \<Psi>\<^sub>o fg"
                 using fg VV.ide_char\<^sub>S\<^sub>b\<^sub>C Cod_ide by simp
               thus ?thesis
                 using fg 1 \<Psi>\<^sub>o_in_hom [of fg] B.comp_arr_inv' by fastforce
             qed
             finally show ?thesis by simp
           qed
           finally show ?thesis by blast
         qed
       qed
       next
       show "\<And>f. VV.arr f \<Longrightarrow>
                    \<Psi>\<^sub>o (VV.cod f) \<cdot>\<^sub>B HoDN_DN.map f = DNoH.map f \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom f)"
       proof -
         fix \<mu>\<nu>
         assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
         show "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
         proof -
           have 1: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>))"
             unfolding E.Ide.simps(3)
             by (metis (no_types, lifting) VV.arrE \<mu>\<nu> arrE src_simps(2) trg_simps(2))
           have 2: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>))"
             using 1
             by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ideD(1) arr_char \<mu>\<nu>)
           have 3: "\<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor>"
             by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                E.Nmlize_Nml VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char \<mu>\<nu> 1)
           have 4: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>))"
             unfolding E.Ide.simps(3)
             by (metis (no_types, lifting) "1" E.Ide.simps(3) VV.arrE \<mu>\<nu> arr_char)
           have 5: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))"
             using 4
             by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.ideD(1) arr_char \<mu>\<nu>)
           have 6: "\<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor>"
             by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                E.Nmlize_Nml VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char \<mu>\<nu> 1)
           have A: "\<guillemotleft>\<Psi>\<^sub>o' \<mu>\<nu> : \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<rbrace>
                                  \<Rightarrow>\<^sub>B \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
             using 1 2 3 by auto
           have B: "\<guillemotleft>Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>) :
                      \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
             using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char src_def trg_def E.Nml_implies_Arr E.eval_simps'(2-3)
             by auto
           have C: "\<guillemotleft>B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) :
                      \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
             using 4 5 6 by auto
           have "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> =
                 B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
                   (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>))"
             using \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.cod_char\<^sub>S\<^sub>b\<^sub>C arr_char src_def trg_def cod_char DN.FF_def DN_def
             by auto
           also have "... = B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))
                                  (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
                              (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o \<mu>\<nu>"
             using B \<mu>\<nu> VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char src_def trg_def
                   E.Ide_HcompNml E.Nml_HcompNml(1) B.can_Ide_self B.comp_arr_dom
             by auto
           also have "... = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
           proof -
             have "DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>) =
                   B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
                     (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
               using \<mu>\<nu> DN_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C B.comp_assoc by simp
             moreover have "\<Psi>\<^sub>o (VV.dom \<mu>\<nu>) = \<Psi>\<^sub>o \<mu>\<nu>"
               using \<mu>\<nu> VV.dom_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by auto
             ultimately show ?thesis
               using B.comp_assoc by simp
           qed
           finally show ?thesis by blast
         qed
       qed
     qed
 
     abbreviation cmp\<^sub>D\<^sub>N
     where "cmp\<^sub>D\<^sub>N \<equiv> \<Psi>.map"
 
     interpretation \<Psi>: natural_isomorphism VV.comp V\<^sub>B HoDN_DN.map DNoH.map cmp\<^sub>D\<^sub>N
       using \<Psi>\<^sub>o_in_hom B.iso_def \<Psi>.map_simp_ide
       apply unfold_locales
         apply auto
       by blast
 
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     lemma cmp\<^sub>D\<^sub>N_in_hom [intro]:
     assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
     shows "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
     and "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
                     \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
     proof -
       have 1: "VV.arr \<mu>\<nu>"
         using assms VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
       show 2: "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
                           \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
       proof -
         have "HoDN_DN.map (VV.dom \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
           using assms 1 DN.FF_def VV.dom_simp by auto
         moreover have "DNoH.map (VV.cod \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
           using assms 1 VV.cod_simp by simp
         ultimately show ?thesis
           using assms 1 \<Psi>.preserves_hom by auto
       qed
       show "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
         using assms 2 B.src_dom [of "cmp\<^sub>D\<^sub>N \<mu>\<nu>"] B.trg_dom [of "cmp\<^sub>D\<^sub>N \<mu>\<nu>"]
         by (elim B.in_homE, intro B.in_hhomI) auto
     qed
 
     lemma cmp\<^sub>D\<^sub>N_simps [simp]:
     assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
     shows "B.arr (cmp\<^sub>D\<^sub>N \<mu>\<nu>)"
     and "src\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))" and "trg\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
     and "B.dom (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
     and "B.cod (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
     proof
       show "VV.arr \<mu>\<nu>"
         using assms by blast
       have 1: "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
         using assms by blast
       show "src\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))"
         using 1 by fast
       show "trg\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
         using 1 by fast
       have 2: "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
                           \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
         using assms by blast
       show "B.dom (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
         using 2 by fast
       show "B.cod (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
         using 2 by fast
     qed
 
     interpretation DN: pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
                          DN cmp\<^sub>D\<^sub>N
     proof
       show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
                        DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
                        cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
       proof -
         fix f g h
         assume f: "ide f" and g: "ide g" and h: "ide h"
         and fg: "src f = trg g" and gh: "src g = trg h"
         show "DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
               cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
         proof -
           have 1: "E.Trg (Dom g) = E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<and>
                    \<lbrace>E.Trg (Dom g)\<rbrace> = \<lbrace>E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<rbrace>"
             using f g h fg gh arr_char src_def trg_def E.Trg_HcompNml
             by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
           have 2: "arr (MkArr (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
                        (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
                           (Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                           (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
                           B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
           proof -
             have "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
                      (Map f \<star>\<^sub>B
                         B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                           (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
                           B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                      EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)
                        \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
             proof (intro B.comp_in_homI)
               show 2: "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                           EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B
                             EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<guillemotright>"
                 using f g h fg gh 1
                 apply (intro B.can_in_hom)
                   apply (metis (no_types, lifting) E.Ide_HcompNml E.Nml_HcompNml(1)
                     arr_char ideD(1) src_simps(1) trg_simps(1))
                  apply (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml ideD(1)
                     arr_char src_simps(1) trg_simps(1))
                 by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                     E.Nmlize_Nml ideD(1) arr_char src_simps(1) trg_simps(1))
               show "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) :
                        EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<Rightarrow>\<^sub>B
                          EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
               proof -
                 have "E.Ide (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                   using f g h fg gh 1 Cod_ide E.Ide_HcompNml arr_char
                   apply simp
                   by (metis (no_types, lifting) ideD(1) src_simps(1) trg_simps(1))
                 moreover have "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                   using f g h fg gh
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
                       arr_char calculation ideD(1) src_simps(1) trg_simps(1))
                 moreover have "E.Nmlize (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) =
                                E.Nmlize (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                   using f g h fg gh
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                       E.Nmlize_Nml arr_char calculation(1) ideD(1) src_simps(1) trg_simps(1))
                 ultimately show ?thesis
                   using B.can_in_hom [of "Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h"]
                   by blast
               qed
               show "\<guillemotleft>Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                      (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                        EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
                 using f g h fg gh B.can_in_hom
                 apply simp
               proof (intro B.hcomp_in_vhom B.comp_in_homI)
                 show 1: "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                             EVAL (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Dom g \<^bold>\<star> Dom h)\<guillemotright>"
                   using g h gh B.can_in_hom
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
                       E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1) src_simps(1) trg_simps(1))
                 show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
                          EVAL (Cod g \<^bold>\<star> Cod h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
                   using g h gh B.can_in_hom
                   by (metis (no_types, lifting) Cod_ide E.Ide.simps(3) E.Ide_HcompNml
                       E.Nml_HcompNml(1) E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1)
                       src_simps(2) trg_simps(2))
                 show "\<guillemotleft>Map g \<star>\<^sub>B Map h : EVAL (Dom g \<^bold>\<star> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<star> Cod h)\<guillemotright>"
                 proof
                   show 2: "B.hseq (Map g) (Map h)"
                     using g h gh
                     by (metis (no_types, lifting) B.comp_null(1-2) B.hseq_char'
                         B.ideD(1) Map_hcomp ideE ide_hcomp)
                   show "B.dom (Map g \<star>\<^sub>B Map h) = EVAL (Dom g \<^bold>\<star> Dom h)"
                     using g h gh 2 by fastforce
                   show "B.cod (Map g \<star>\<^sub>B Map h) = EVAL (Cod g \<^bold>\<star> Cod h)"
                     using g h gh 2 by fastforce
                 qed
                 show "\<guillemotleft>Map f : Map f \<Rightarrow>\<^sub>B EVAL (Cod f)\<guillemotright>"
                   using f arr_char Cod_ide by auto
                 show "src\<^sub>B (Map f) = trg\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                   using f g h fg gh 1 2 src_def trg_def B.arrI B.hseqE B.not_arr_null
                         B.trg.is_extensional B.trg.preserves_hom B.vconn_implies_hpar(2)
                         B.vconn_implies_hpar(4) E.eval.simps(3)
                   by (metis (no_types, lifting) Map_ide(1))
               qed
             qed
             thus ?thesis
               using f g h fg gh arr_char src_def trg_def E.Nml_HcompNml E.Ide_HcompNml
                     ideD(1)
               apply (intro arr_MkArr) by auto
           qed
           have 3: "E.Ide (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using g h gh ide_char arr_char src_def trg_def E.Ide_HcompNml Cod_ide
             by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
           have 4: "E.Ide (Dom g \<^bold>\<star> Dom h)"
             by (metis (no_types, lifting) E.Ide.simps(3) arrE g gh h ideE src_simps(1) trg_simps(1))
           have 5: "E.Nmlize (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Nmlize (Dom g \<^bold>\<star> Dom h)"
             using g h gh ide_char arr_char src_def trg_def E.Nml_HcompNml
             by (metis (no_types, lifting) 4 E.Ide.simps(3) E.Nmlize.simps(3) E.Nmlize_Nml
                 ideD(1))
           have 6: "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using f g h fg gh arr_char src_def trg_def
             by (metis (no_types, lifting) 1 E.Nml_HcompNml(1) E.Ide_HcompNml ideD(1)
                 src_simps(2) trg_simps(2))
           have 7: "E.Ide (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using f g h fg gh arr_char src_def trg_def
             by (metis (no_types, lifting) 1 3 E.Ide.simps(3) ideD(1) src_simps(2) trg_simps(2))
           have 8: "E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                    E.Nmlize (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using f g h fg gh arr_char src_def trg_def
                   7 E.Nml_HcompNml(1) ideD(1)
             by auto
           have "DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
                 B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
           proof -
             have 9: "VVV.arr (f, g, h)"
               using f g h fg gh VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C arr_char ideD by simp
             have 10: "VV.ide (f, g)"
               using f g fg VV.ide_char\<^sub>S\<^sub>b\<^sub>C by auto
             have 11: "VV.ide (hcomp f g, h)"
               using f g h fg gh VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C by simp
             have 12: "arr (MkArr (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
                                 (B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                                   (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
                                   B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
             proof (intro arr_MkArr)
               show "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE"
                 using g h gh
                 by (metis (no_types, lifting) 3 E.Nml_HcompNml(1) arr_char ideD(1)
                     mem_Collect_eq src_simps(2) trg_simps(2))
               show "Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h \<in> IDE"
                 using g h gh Cod_ide \<open>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE\<close> by auto
               show "B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                       (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
                       B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)
                     \<in> HOM (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
               proof
                 show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
                       E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
                       \<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                          (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                          \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
                 proof (intro conjI)
                   show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                     using g h gh Cod_ide by simp
                   show "E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                     using g h gh Cod_ide by simp
                   show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                            (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                            \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
                   proof (intro B.comp_in_homI)
                     show "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                              \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace>\<guillemotright>"
                       using 3 4 5 by blast
                     show "\<guillemotleft>Map g \<star>\<^sub>B Map h : \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace>\<guillemotright>"
                       using g h gh
                       by (metis (no_types, lifting) 4 B.ide_in_hom(2) Cod_ide E.eval.simps(3)
                           E.ide_eval_Ide Map_ide(2))
                     show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
                             \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
                       using 3 4 5 Cod_ide g h by auto
                   qed
                 qed
               qed
             qed
             have "DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
             proof -
               have "DN (\<a> f g h) =
                     (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                       ((Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                          (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))) \<cdot>\<^sub>B
                       B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))"
                 using f g h fg gh 1 2 9 12 DN_def \<a>_def Cod_ide by simp
               also have
                 "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                          (Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
                            B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
               proof -
                 have "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                                     \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map g \<star>\<^sub>B Map h\<guillemotright>"
                   using g h 3 4 5 B.can_in_hom [of "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom g \<^bold>\<star> Dom h"]
                   by simp
                 hence "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                        Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                                  B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using B.comp_cod_arr by auto
                 also have "... = Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                   using f g h fg gh 3 4 5 B.can_Ide_self by auto
                 finally have "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                               Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                   by simp
                 thus ?thesis by simp
               qed
               also have
                 "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                          B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
               proof -
                 have "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                                \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<guillemotright>"
                   using f g h 6 7 8
                         B.can_in_hom [of "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h"]
                   by simp
                 hence "(Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
                          B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                        B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using B.comp_cod_arr by auto
                 thus ?thesis by simp
               qed
               also have
                 "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h fg gh 6 7 8 by auto
               also have "... = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                 using f g h fg gh 6 B.can_Ide_self by blast
               finally show ?thesis by simp
             qed
             have "DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
                   B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                   B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                     (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
             proof -
               have "DN (\<a> f g h) =
                     B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h fg gh DN_def 1 4 6 7 B.can_Ide_self E.HcompNml_assoc
                       E.Ide.simps(3) \<open>DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<close> ide_char
                 by (metis (no_types, lifting) arr_char ideD(1))
               thus ?thesis
                 using f g h fg gh 10 11 DN_def \<Psi>.map_simp_ide by simp
             qed
             also have
               "... = (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                        B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)) \<cdot>\<^sub>B
                         (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
               using B.comp_assoc by simp
             also have
               "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                        B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
             proof -
               have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
                     B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
               proof -
                 have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
                       B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B B.can (Dom h) (Dom h)"
                   using h B.can_Ide_self by fastforce
                 also have "... = B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
                   using f g h 1 4 7 arr_char E.Nml_HcompNml(1) E.Src_HcompNml
                         B.hcomp_can [of "Dom f \<^bold>\<star> Dom g" "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g" "Dom h" "Dom h"]
                   by (metis (no_types, lifting) E.Nmlize.simps(3) E.Nmlize_Nml
                       E.Ide.simps(3) E.Ide_HcompNml E.Src.simps(3) arrE ideD(1))
                 finally show ?thesis by simp
               qed
               moreover have
                 "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                    B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
                      B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
               proof -
                 have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
                   using f g h 1 4 7
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
                       arrE ideD(1))
                 moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 7 E.Ide_HcompNml E.Nml_HcompNml(1) arr_char calculation
                         ideD(1)
                   by auto
                 moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 4 6 by blast
                 moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
                                E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 4 7
                   by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                       E.Nmlize_Nml E.Ide.simps(3) arrE calculation(1) ideD(1))
                 moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                                E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 4 7 E.HcompNml_assoc by fastforce
                 ultimately show ?thesis
                   using B.vcomp_can by simp
               qed
               ultimately show ?thesis by simp
             qed
             also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
             proof -
               have "E.Ide ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
                 using 1 4 7 by simp
               moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
                 using f g 1 4 7
                 by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
                     arrE ideD(1))
               moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h 6 by blast
               moreover have "E.Nmlize ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h) =
                              E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
                 using f g h 1 7 E.Nml_HcompNml(1) by fastforce
               moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
                              E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h 1 4 7
                 by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                     E.Nmlize_Nml E.HcompNml_assoc E.Ide.simps(3) arrE ideD(1))
               ultimately show ?thesis
                 using B.vcomp_can by simp
             qed
             finally show ?thesis by simp
           qed
           also have "... = cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B
                            \<a>\<^sub>B[DN f, DN g, DN h]"
           proof -
             have "cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h] =
                   (cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h))) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
               using B.comp_assoc by simp
             also have
               "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                        B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
             proof -
               have "cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) =
                     B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
               proof -
                 have "cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) =
                       B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                             (Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
                   using f g h fg gh VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C DN_def by simp
                 also have
                   "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                            (B.can (Dom f) (Dom f) \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
                 proof -
                   have "Map f = B.can (Dom f) (Dom f)"
                     using f arr_char B.can_Ide_self [of "Dom f"] Map_ide
                     by (metis (no_types, lifting) ide_char')
                   thus ?thesis by simp
                 qed
                 also have
                   "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                          B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
                   using 1 4 5 7 B.hcomp_can by auto
                 also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
                   using 1 4 5 6 7 8 B.vcomp_can by auto
                 finally show ?thesis by simp
               qed
               moreover have "\<a>\<^sub>B[DN f, DN g, DN h] =
                              B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
                 using f g h 1 4 7 DN_def B.canE_associator(1) by auto
               ultimately show ?thesis by simp
             qed
             also have  "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
               using 1 4 5 6 7 8 E.Nmlize_Hcomp_Hcomp B.vcomp_can by simp
             finally show ?thesis by simp
           qed
           finally show ?thesis by blast
         qed
       qed
     qed
 
     lemma DN_is_pseudofunctor:
     shows "pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN cmp\<^sub>D\<^sub>N"
       ..
 
     interpretation faithful_functor vcomp V\<^sub>B DN
       using arr_char dom_char cod_char DN_def
       apply unfold_locales
       by (metis (no_types, lifting) Cod_dom Dom_cod MkArr_Map)
 
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     lemma DN_UP:
     assumes "B.arr \<mu>"
     shows "DN (UP \<mu>) = \<mu>"
       using assms UP_def DN_def arr_UP by auto
 
     interpretation DN: equivalence_pseudofunctor
                          vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN cmp\<^sub>D\<^sub>N
     proof
       (* DN is locally (but not globally) full. *)
       show "\<And>f f' \<nu>. \<lbrakk> ide f; ide f'; src f = src f'; trg f = trg f'; \<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright> \<rbrakk>
                          \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
       proof -
         fix f f' \<nu>
         assume f: "ide f" and f': "ide f'"
         and eq_src: "src f = src f'" and eq_trg: "trg f = trg f'"
         and \<nu>: "\<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright>"
         show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
         proof -
           let ?\<mu> = "MkArr (Dom f) (Dom f') \<nu>"
           have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright>"
           proof
             have "Map f = \<lbrace>Dom f\<rbrace>"
               using f by simp
             have "Map f' = \<lbrace>Dom f'\<rbrace>"
               using f' by simp
             have "Dom f' = Cod f'"
               using f' Cod_ide by simp
             show \<mu>: "arr ?\<mu>"
             proof -
               have "E.Nml (Dom ?\<mu>) \<and> E.Ide (Dom ?\<mu>)"
               proof -
                 have "E.Nml (Dom f) \<and> E.Ide (Dom f)"
                   using f ide_char arr_char by blast
                 thus ?thesis
                   using f by simp
               qed
               moreover have "E.Nml (Cod ?\<mu>) \<and> E.Ide (Cod ?\<mu>)"
               proof -
                 have "E.Nml (Dom f') \<and> E.Ide (Dom f')"
                   using f' ide_char arr_char by blast
                 thus ?thesis
                   using f' by simp
               qed
               moreover have "E.Src (Dom ?\<mu>) = E.Src (Cod ?\<mu>)"
                 using f f' \<nu> arr_char src_def eq_src ideD(1) by auto
               moreover have "E.Trg (Dom ?\<mu>) = E.Trg (Cod ?\<mu>)"
                 using f f' \<nu> arr_char trg_def eq_trg ideD(1) by auto
               moreover have "\<guillemotleft>Map ?\<mu> : \<lbrace>Dom ?\<mu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<mu>\<rbrace>\<guillemotright>"
               proof -
                 have "\<guillemotleft>\<nu> : \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f'\<rbrace>\<guillemotright>"
                   using f f' \<nu> ide_char arr_char DN_def Cod_ide Map_ide
                   by (metis (no_types, lifting) ideD(1))
                 thus ?thesis by simp
               qed
               ultimately show ?thesis
                 using f f' \<nu> ide_char arr_char by blast
             qed
             show "dom ?\<mu> = f"
               using f \<mu> dom_char MkArr_Map MkIde_Dom' by simp
             show "cod ?\<mu> = f'"
             proof -
               have "cod ?\<mu> = MkIde (Dom f')"
                 using \<mu> cod_char by simp
               also have "... = MkArr (Dom f') (Cod f') (Map f')"
                 using f' by auto
               also have "... = f'"
                 using f' MkArr_Map by simp
               finally show ?thesis by simp
             qed
           qed
           moreover have "DN ?\<mu> = \<nu>"
             using \<mu> DN_def by auto
           ultimately show ?thesis by blast
         qed
       qed
       (* DN is biessentially surjective on objects. *)
       show "\<And>a'. B.obj a' \<Longrightarrow> \<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
       proof -
         fix a'
         assume a': "B.obj a'"
         have "obj (UP.map\<^sub>0 a')"
           using a' UP.map\<^sub>0_simps(1) by simp
         moreover have "B.equivalent_objects (DN.map\<^sub>0 (UP.map\<^sub>0 a')) a'"
         proof -
           have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle> \<^bold>\<langle>a'\<^bold>\<rangle> a')"
             using a' UP_def [of a'] UP.preserves_reflects_arr [of a'] by auto
           moreover have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 a')"
             using a' arr_char obj_simps by auto
           ultimately have "DN.map\<^sub>0 (UP.map\<^sub>0 a') = a'"
             using a' UP.map\<^sub>0_def DN.map\<^sub>0_def DN_def src_def by auto
           thus ?thesis
             using a' B.equivalent_objects_reflexive by simp
         qed
         ultimately show "\<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
           by blast
       qed
       (* DN is locally essentially surjective. *)
       show "\<And>a b g. \<lbrakk> obj a; obj b; \<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>; B.ide g \<rbrakk> \<Longrightarrow>
                        \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
       proof -
         fix a b g
         assume a: "obj a" and b: "obj b"
         and g: "\<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>" and ide_g: "B.ide g"
         have "ide (UP g)"
           using ide_g UP.preserves_ide by simp
         moreover have "B.isomorphic (DN (UP g)) g"
           using ide_g DN_UP B.isomorphic_reflexive by simp
         moreover have "\<guillemotleft>UP g : a \<rightarrow> b\<guillemotright>"
         proof
           show "arr (UP g)"
             using g UP.preserves_reflects_arr by auto
           show "src (UP g) = a"
           proof -
             have "src (UP g) = MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g)"
               using ide_g src_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
             also have "... = a"
             proof -
               have "src\<^sub>B g = src\<^sub>B (DN.map\<^sub>0 a)"
                 using a g B.in_hhom_def by simp
               also have "... = Map a"
                 using a Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src B.obj_simps
                 by auto
               finally have "src\<^sub>B g = Map a" by simp
               hence "MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g) = MkArr \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 (Map a)"
                 by simp
               also have "... = a"
                 using a obj_char [of a] MkIde_Dom [of a]
                 apply (cases "Dom a")
                          apply force
                 by simp_all
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
           show "trg (UP g) = b"
           proof -
             have "trg (UP g) = MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g)"
               using ide_g trg_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
             also have "... = b"
             proof -
               have "trg\<^sub>B g = trg\<^sub>B (DN.map\<^sub>0 b)"
                 using b g B.in_hhom_def by simp
               also have "... = Map b"
                 using b Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src B.obj_simps
                 by auto
               finally have "trg\<^sub>B g = Map b" by simp
               hence "MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
                 by simp
               also have "... = b"
                 using b obj_char [of b] MkIde_Dom [of b]
                 apply (cases "Dom b")
                          apply force
                 by simp_all
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
         qed
         ultimately show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
           by blast
       qed
     qed
 
     theorem DN_is_equivalence_pseudofunctor:
     shows "equivalence_pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
              DN cmp\<^sub>D\<^sub>N"
       ..
 
     text \<open>
       The following gives an explicit formula for a component of the unit isomorphism of
       the pseudofunctor \<open>UP\<close> from a bicategory to its strictification.
       It is not currently being used -- I originally proved it in order to establish something
       that I later proved in a more abstract setting -- but it might be useful at some point.
     \<close>
     interpretation UP: equivalence_pseudofunctor
                          V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P
       using UP_is_equivalence_pseudofunctor by auto
 
     lemma UP_unit_char:
     assumes "B.obj a"
     shows "UP.unit a = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
     proof -
       have " MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a = UP.unit a"
       proof (intro UP.unit_eqI)
         show "B.obj a"
           using assms by simp
         have 0: "\<guillemotleft>a : a \<Rightarrow>\<^sub>B a\<guillemotright>"
           using assms by auto
         have 1: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
           apply (unfold arr_char, intro conjI)
           using assms by auto
         have 2: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> a)"
           apply (unfold arr_char, intro conjI)
           using assms by auto
         have 3: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a)"
           apply (unfold arr_char, intro conjI)
           using assms by auto
         show "\<guillemotleft>MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a : UP.map\<^sub>0 a \<Rightarrow> UP a\<guillemotright>"
         proof
           show "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)" by fact
           show "dom (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP.map\<^sub>0 a"
             using assms 1 2 dom_char UP.map\<^sub>0_def UP_def src_def by auto
           show "cod (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP a"
             using assms 1 2 cod_char UP.map\<^sub>0_def UP_def src_def by auto
         qed
         show "iso (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
           using assms 1 iso_char by auto
         show "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) =
               (UP \<i>\<^sub>B[a] \<cdot> cmp\<^sub>U\<^sub>P (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
         proof -
           have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
             unfolding \<i>_def UP.map\<^sub>0_def UP_def
             using assms 0 1 2 src_def by auto
           also have "... = (UP \<i>\<^sub>B[a] \<cdot> cmp\<^sub>U\<^sub>P (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
           proof -
             have "(UP \<i>\<^sub>B[a] \<cdot> cmp\<^sub>U\<^sub>P (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) =
                   (MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a))
                      \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
               using assms UP_def cmp\<^sub>U\<^sub>P_ide_simp by auto
             also have "... = (MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a))
                                \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
               using assms 0 1 2 3 hcomp_def B.comp_cod_arr src_def trg_def
                     B.can_Ide_self B.canE_unitor [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] B.comp_cod_arr
               by auto
             also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> ((\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a)) \<cdot>\<^sub>B B.runit' a)"
             proof -
               have "MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a) =
                     MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> (\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a))"
                 using assms
                 by (intro comp_MkArr arr_MkArr) auto
               moreover have "MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> (\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a))
                                \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a) =
                              MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> ((\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a)) \<cdot>\<^sub>B B.runit' a)"
                 using assms 0 B.comp_arr_dom
                 by (intro comp_MkArr arr_MkArr, auto)
               ultimately show ?thesis by argo
             qed
             also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
               using assms B.comp_arr_dom B.comp_arr_inv' B.iso_unit B.unitor_coincidence(2)
               by simp
             finally show ?thesis by argo
           qed
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis by simp
     qed
 
   end
 
   subsection "Pseudofunctors into a Strict Bicategory"
 
   text \<open>
     In the special case of a pseudofunctor into a strict bicategory, we can obtain
     explicit formulas for the images of the units and associativities under the pseudofunctor,
     which only involve the structure maps of the pseudofunctor, since the units and associativities
     in the target bicategory are all identities.  This is useful in applying strictification.
   \<close>
 
   locale pseudofunctor_into_strict_bicategory =
     pseudofunctor +
     D: strict_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
   begin
 
     lemma image_of_unitor:
     assumes "C.ide g"
     shows "F \<l>\<^sub>C[g] = (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
     and "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
     and "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)"
     and "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))"
     proof -
       show A: "F \<l>\<^sub>C[g] = (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
       proof -
         have 1: "\<guillemotleft>(D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) :
                      F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
         proof
           show "\<guillemotleft>D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g : F (trg\<^sub>C g) \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F g\<guillemotright>"
             using assms unit_char by (auto simp add: D.hcomp_obj_arr)
           show "\<guillemotleft>D.inv (\<Phi> (trg\<^sub>C g, g)) : F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C g) \<star>\<^sub>D F g\<guillemotright>"
             using assms cmp_in_hom(2) D.inv_is_inverse by simp
         qed
         have "(D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) =
               F g \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
           using 1 D.comp_cod_arr by auto
         also have "... = (F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
                            (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
           using assms lunit_coherence [of g] D.strict_lunit by simp
         also have "... = F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D
                                     ((unit (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
                                    D.inv (\<Phi> (trg\<^sub>C g, g))"
           using D.comp_assoc by simp
         also have "... = F \<l>\<^sub>C[g]"
         proof -
           have "(unit (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) = F (trg\<^sub>C g) \<star>\<^sub>D F g"
             using assms unit_char D.whisker_right
             by (metis C.ideD(1) C.obj_trg C.trg.preserves_reflects_arr D.comp_arr_inv'
                 unit_simps(5) preserves_arr preserves_ide)
           moreover have "\<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) = F (trg\<^sub>C g \<star>\<^sub>C g)"
             using assms D.comp_arr_inv D.inv_is_inverse by simp
           ultimately show ?thesis
             using assms D.comp_arr_dom D.comp_cod_arr unit_char by auto
         qed
         finally show ?thesis by simp
       qed
       show B: "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
       proof -
         have 1: "\<guillemotleft>(F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) :
                     F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
         proof
           show "\<guillemotleft>F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g)) : F g \<star>\<^sub>D F (src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
             using assms unit_char by (auto simp add: D.hcomp_arr_obj)
           show "\<guillemotleft>D.inv (\<Phi> (g, src\<^sub>C g)) : F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F (src\<^sub>C g)\<guillemotright>"
             using assms cmp_in_hom(2) by simp
         qed
         have "(F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) =
               F g \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
           using 1 D.comp_cod_arr by auto
         also have "... = (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))) \<cdot>\<^sub>D
                            (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
            using assms runit_coherence [of g] D.strict_runit by simp
         also have "... = F \<r>\<^sub>C[g] \<cdot>\<^sub>D (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D ((F g \<star>\<^sub>D unit (src\<^sub>C g)) \<cdot>\<^sub>D
                            (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
            using D.comp_assoc by simp
         also have "... = F \<r>\<^sub>C[g]"
         proof -
           have "(F g \<star>\<^sub>D unit (src\<^sub>C g)) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) = F g \<star>\<^sub>D F (src\<^sub>C g)"
             using assms D.whisker_left unit_char
             by (metis C.ideD(1) C.obj_src C.src.preserves_ide D.comp_arr_inv' D.ideD(1)
                 unit_simps(5) preserves_ide)
           moreover have "\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) = F (g \<star>\<^sub>C src\<^sub>C g)"
             using assms D.comp_arr_inv D.inv_is_inverse by simp
           ultimately show ?thesis
             using assms D.comp_arr_dom D.comp_cod_arr unit_char cmp_in_hom(2) [of g "src\<^sub>C g"]
             by auto
         qed
         finally show ?thesis by simp
       qed
       show "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)"
       proof -
         have "F (C.lunit' g) = D.inv (F \<l>\<^sub>C[g])"
           using assms C.iso_lunit preserves_inv by simp
         also have "... = D.inv ((D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)))"
           using A by simp
         also have "... = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)"
         proof -
           have "D.iso (D.inv (\<Phi> (trg\<^sub>C g, g))) \<and> D.inv (D.inv (\<Phi> (trg\<^sub>C g, g))) = \<Phi> (trg\<^sub>C g, g)"
             using assms by simp
           moreover have "D.iso (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<and>
                          D.inv (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) = unit (trg\<^sub>C g) \<star>\<^sub>D F g"
             using assms unit_char by simp
           moreover have "D.seq (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) (D.inv (\<Phi> (trg\<^sub>C g, g)))"
             using assms unit_char by (metis A C.lunit_simps(1) preserves_arr)
           ultimately show ?thesis
             using D.inv_comp by simp
         qed
         finally show ?thesis by simp
       qed
       show "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))"
       proof -
         have "F (C.runit' g) = D.inv (F \<r>\<^sub>C[g])"
           using assms C.iso_runit preserves_inv by simp
         also have "... = D.inv ((F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)))"
           using B by simp
         also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))"
         proof -
           have "D.iso (D.inv (\<Phi> (g, src\<^sub>C g))) \<and> D.inv (D.inv (\<Phi> (g, src\<^sub>C g))) = \<Phi> (g, src\<^sub>C g)"
             using assms by simp
           moreover have "D.iso (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<and>
                          D.inv (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) = F g \<star>\<^sub>D unit (src\<^sub>C g)"
             using assms unit_char by simp
           moreover have "D.seq (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) (D.inv (\<Phi> (g, src\<^sub>C g)))"
             using assms unit_char by (metis B C.runit_simps(1) preserves_arr)
           ultimately show ?thesis
             using D.inv_comp by simp
         qed
         finally show ?thesis by simp
       qed
     qed
 
     lemma image_of_associator:
     assumes "C.ide f" and "C.ide g" and "C.ide h" and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C h"
     shows "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                              (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
     and "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
                                 (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
     proof -
       show 1: "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                                  (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
       proof -
         have 2: "D.seq (\<Phi> (f, g \<star>\<^sub>C h)) ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
           using assms D.assoc_in_hom(2) [of "F f" "F g" "F h"] cmp_simps(1,4) C.VV.cod_simp
           by (intro D.seqI) auto
         moreover have 3: "F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
                           \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
           using assms assoc_coherence [of f g h] by blast
         moreover have "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
           using assms 2 3 C.VV.arr_char\<^sub>S\<^sub>b\<^sub>C C.VV.dom_char\<^sub>S\<^sub>b\<^sub>C C.VV.cod_char\<^sub>S\<^sub>b\<^sub>C FF_def D.isos_compose
           by auto
         ultimately have "F \<a>\<^sub>C[f, g, h] =
                          (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])) \<cdot>\<^sub>D
                            D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
           using D.invert_side_of_triangle(2)
                   [of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
                       "F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
           by presburger
         also have "... = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                             (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
         proof -
           have "D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)) =
                 (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
           proof -
             have "D.seq (\<Phi> (f \<star>\<^sub>C g, h)) (\<Phi> (f, g) \<star>\<^sub>D F h)"
               using assms by fastforce
             thus ?thesis
               using assms D.inv_comp by simp
           qed
           moreover have "(F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] = (F f \<star>\<^sub>D \<Phi> (g, h))"
             using assms D.comp_arr_dom D.assoc_in_hom [of "F f" "F g" "F h"] cmp_in_hom
             by (metis "2" "3" D.comp_arr_ide D.hseq_char D.seqE D.strict_assoc
                 cmp_simps(2) cmp_simps(3) preserves_ide)
           ultimately show ?thesis
             using D.comp_assoc by simp
         qed
         finally show ?thesis
           by simp
       qed
       show "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
                                (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
       proof -
         have "F (C.\<a>' f g h) = D.inv (F \<a>\<^sub>C[f, g, h])"
           using assms preserves_inv by simp
         also have "... = D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                                   (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
           using 1 by simp
         also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
                                    (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
           using assms C.VV.arr_char\<^sub>S\<^sub>b\<^sub>C FF_def D.hcomp_assoc D.comp_assoc
                 C.VV.dom_simp C.VV.cod_simp
           (* OK, this is pretty cool, but not as cool as if I didn't have to direct it. *)
           by (simp add: D.inv_comp D.isos_compose)
         finally show ?thesis by simp
       qed
     qed
 
   end
 
   subsection "Internal Equivalences in a Strict Bicategory"
 
   text \<open>
     In this section we prove a useful fact about internal equivalences in a strict bicategory:
     namely, that if the ``right'' triangle identity holds for such an equivalence then the
     ``left'' does, as well.  Later we will dualize this property, and use strictification to
     extend it to arbitrary bicategories.
   \<close>
 
   locale equivalence_in_strict_bicategory =
     strict_bicategory +
     equivalence_in_bicategory
   begin
 
     lemma triangle_right_implies_left:
     shows "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g \<Longrightarrow> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
     proof -
       text \<open>
         The formal proof here was constructed following the string diagram sketch below,
         which appears in \cite{nlab-zigzag-diagram}
         (see it also in context in \cite{nlab-adjoint-equivalence}).
         The diagram is reproduced here by permission of its author, Mike Shulman,
         who says (private communication):
         ``Just don't give the impression that the proof itself is due to me, because it's not.
         I don't know who first gave that proof; it's probably folklore.''
         \begin{figure}[h]
           \includegraphics[width=6.5in]{triangle_right_implies_left.png}
         \end{figure}
       \<close>
       assume 1: "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
       have 2: "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = g"
       proof -
         have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = inv ((g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g))"
           using antipar inv_comp hcomp_assoc by simp
         also have "... = g"
           using 1 by simp
         finally show ?thesis by blast
       qed
       have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) = f \<star> \<eta>"
           using 2 ide_left ide_right antipar whisker_left
           by (metis comp_cod_arr unit_simps(1) unit_simps(3))
         thus ?thesis by simp
       qed
       also have "... = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) \<star> (inv \<eta> \<cdot> \<eta>)"
       proof -
         have "inv \<eta> \<cdot> \<eta> = src f"
           by (simp add: comp_inv_arr')
         thus ?thesis
           by (metis antipar(1) antipar(2) arrI calculation
               comp_ide_arr hcomp_arr_obj ideD(1) ide_left ide_right obj_src seqE
               strict_assoc' triangle_in_hom(1) vconn_implies_hpar(1))
       qed
       also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> ((f \<star> inv \<eta>) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
         using ide_left ide_right antipar unit_is_iso
         by (metis "2" arr_inv calculation comp_arr_dom comp_inv_arr' counit_simps(1)
             counit_simps(2) dom_inv hcomp_arr_obj ideD(1) unit_simps(1) unit_simps(2)
             unit_simps(5) obj_trg seqI whisker_left)
       also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star>
                          ((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (f \<star> g) \<star> f"
           using whisker_right [of f "inv \<epsilon>" \<epsilon>] counit_in_hom
           by (simp add: antipar(1) comp_inv_arr')
         thus ?thesis
           using hcomp_assoc comp_arr_dom
           by (metis comp_cod_arr ide_left local.unit_simps(1) local.unit_simps(3)
               whisker_left)
       qed
       also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<cdot> (f \<star> g)) \<star>
                          (((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
                            (f \<star> \<eta>)"
         using ide_left ide_right antipar comp_assoc whisker_right comp_cod_arr
         by (metis "2" comp_arr_dom counit_simps(1-2))
       also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
                          ((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
                            (f \<star> \<eta>)"
       proof -
         have 3: "seq (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) (f \<star> g)"
           using 2 antipar by auto
         moreover have 4: "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) ((\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))"
           using antipar hcomp_assoc by auto
         ultimately show ?thesis
           using interchange by simp
       qed
       also have "... = ((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
                         ((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>)"
         using comp_assoc by presburger
       also have "... = ((\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
                          ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)) \<cdot>
                            (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) =
               (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)"
         proof -
           have "seq \<epsilon> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))"
             using 2 antipar by simp
           moreover have "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) f"
             using antipar hcomp_assoc hcomp_obj_arr by auto
           ultimately show ?thesis
             using comp_assoc comp_arr_dom hcomp_obj_arr
                   interchange [of \<epsilon> "f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)" "(f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)" f]
             by simp
         qed
         moreover have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
                        (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
         proof -
           have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
                 (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) \<cdot> (f \<star> \<eta> \<star> src f)"
             using antipar comp_assoc hcomp_assoc whisker_left hcomp_arr_obj by simp
           also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> ((g \<star> f) \<star> \<eta>) \<cdot> (\<eta> \<cdot> src f))"
             using antipar comp_arr_dom whisker_left hcomp_arr_obj by simp
           also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> \<eta>)"
             using antipar comp_arr_dom comp_cod_arr hcomp_arr_obj
                   interchange [of "g \<star> f" \<eta> \<eta> "src f"]
             by simp
           also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f) \<cdot> (f \<star> src f \<star> \<eta>)"
             using antipar comp_arr_dom comp_cod_arr whisker_left
                   interchange [of \<eta> "src f" "g \<star> f" \<eta>]
             by simp
           also have "... = ((f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f)) \<cdot> (f \<star> \<eta>)"
             using antipar comp_assoc by (simp add: hcomp_obj_arr)
           also have "... = (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
             using antipar comp_assoc whisker_left whisker_right hcomp_assoc by simp
           finally show ?thesis by blast
         qed
         ultimately show ?thesis by simp
       qed
       also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
                          ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot>
                            (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot> (f \<star> \<eta>)"
         using comp_assoc hcomp_assoc antipar(1) antipar(2) by auto
       also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
                          ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot>
                            (f \<star> \<eta>)"
         using ide_left ide_right antipar comp_cod_arr comp_assoc whisker_left
         by (metis "1" "2" comp_ide_self unit_simps(1) unit_simps(3))
       also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
           using ide_left ide_right antipar comp_arr_dom comp_assoc
           by (metis "1" "2" comp_ide_self)
         thus ?thesis
           using antipar comp_cod_arr by simp
       qed
       also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
               (trg f \<cdot> \<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
           using hcomp_obj_arr comp_cod_arr by simp
         also have "... = ((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
           using antipar hcomp_arr_obj hcomp_assoc interchange by auto
         also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
         proof -
           have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (trg f \<star> inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> trg f \<star> f)"
             using hseqI' by (simp add: hcomp_obj_arr)
           also have "... = \<epsilon> \<star> inv \<epsilon> \<star> f"
             using antipar comp_arr_dom comp_cod_arr
                   interchange [of "trg f" \<epsilon> "inv \<epsilon> \<star> f" "trg f \<star> f"]
             by force
           finally have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = \<epsilon> \<star> inv \<epsilon> \<star> f" by simp
           moreover have "trg f \<star> f \<star> inv \<eta> = f \<star> inv \<eta>"
             using hcomp_obj_arr [of "trg f" "f \<star> inv \<eta>"] by fastforce
           ultimately have "((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
                            ((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f))) \<cdot> (f \<star> \<eta>)"
             by simp
           thus ?thesis
             using comp_assoc by simp
         qed
         finally show ?thesis by simp
       qed
       also have "... = f \<star> inv \<eta> \<cdot> \<eta>"
       proof -
         have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = f \<star> g \<star> f"
           using ide_left ide_right antipar counit_is_iso whisker_right hcomp_assoc
           by (metis comp_arr_dom comp_inv_arr' counit_simps(1) counit_simps(2) seqE)
         thus ?thesis
           using ide_left ide_right antipar unit_is_iso comp_cod_arr
           by (metis arr_inv dom_inv unit_simps(1) unit_simps(3) seqI whisker_left)
       qed
       also have "... = f \<star> src f"
         using antipar by (simp add: comp_inv_arr')
       also have "... = f"
         using hcomp_arr_obj by simp
       finally show ?thesis by simp
     qed
 
   end
 
   text \<open>
     Now we use strictification to generalize the preceding result to arbitrary bicategories.
     I originally attempted to generalize this proof directly from the strict case, by filling
     in the necessary canonical isomorphisms, but it turned out to be too daunting.
     The proof using strictification is still fairly tedious, but it is manageable.
   \<close>
 
   context equivalence_in_bicategory
   begin
 
     interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
 
     notation S.vcomp  (infixr "\<cdot>\<^sub>S" 55)
     notation S.hcomp  (infixr "\<star>\<^sub>S" 53)
     notation S.in_hom  ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
     notation S.in_hhom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
 
     interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
                           S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.cmp\<^sub>U\<^sub>P
       using S.UP_is_equivalence_pseudofunctor by auto
     interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
                           S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.cmp\<^sub>U\<^sub>P
       ..
     interpretation E: equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
                         \<open>S.UP f\<close> \<open>S.UP g\<close>
                         \<open>S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f)\<close>
                         \<open>S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)\<close>
       using equivalence_in_bicategory_axioms UP.preserves_equivalence [of f g \<eta> \<epsilon>] by auto
     interpretation E: equivalence_in_strict_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
                         \<open>S.UP f\<close> \<open>S.UP g\<close>
                         \<open>S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f)\<close>
                         \<open>S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)\<close>
       ..
 
     lemma UP_triangle:
     shows "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
             S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
               (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
     and "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
             (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.unit (src g))) \<cdot>\<^sub>S
                (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
     and "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
             S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
     and "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
             (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
     and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
             S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                  (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
                (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                  (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
     proof -
       show T1: "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
                 S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                   (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
       proof -
         have "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
                 S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.UP \<a>[g, f, g] \<cdot>\<^sub>S S.UP (\<eta> \<star> g)"
           using antipar by simp
         also have "... =
                    (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S
                    ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S
                      (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                    (((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.inv (S.cmp\<^sub>U\<^sub>P (g \<star> f, g)))) \<cdot>\<^sub>S
                    S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
         proof -
           have "S.UP \<a>[g, f, g] =
                 S.cmp\<^sub>U\<^sub>P (g, f \<star> g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                 (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g \<star> f, g))"
             using ide_left ide_right antipar UP.image_of_associator [of g f g] by simp
           moreover have
             "S.UP (g \<star> \<epsilon>) =
              S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g))"
           proof -
             have "S.seq (S.cmp\<^sub>U\<^sub>P (g, src g)) (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
               using antipar UP.FF_def UP.cmp_in_hom [of g "src g"]
               apply (intro S.seqI) by auto
             moreover have
               "S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g) = S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
               using antipar UP.\<Phi>.naturality [of "(g, \<epsilon>)"] UP.FF_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.iso (S.cmp\<^sub>U\<^sub>P (g, f \<star> g))"
               using antipar by simp
             ultimately show ?thesis
               using S.invert_side_of_triangle(2)
                       [of "S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)" "S.UP (g \<star> \<epsilon>)"
                           "S.cmp\<^sub>U\<^sub>P (g, f \<star> g)"] S.comp_assoc
               by presburger
           qed
           moreover have "S.UP (\<eta> \<star> g) =
                          (S.cmp\<^sub>U\<^sub>P (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
           proof -
             have "S.UP (\<eta> \<star> g) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (trg g, g) =
                   S.cmp\<^sub>U\<^sub>P (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)"
               using antipar UP.\<Phi>.naturality [of "(\<eta>, g)"] UP.FF_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.seq (S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) (S.UP \<eta> \<star>\<^sub>S S.UP g)"
               using antipar UP.cmp_in_hom(2) by (intro S.seqI, auto)
             ultimately show ?thesis
               using antipar S.invert_side_of_triangle(2) by simp
           qed
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S
                            ((S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                            ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                            S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
         proof -
           have "(S.inv (S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g) =
                 (S.UP \<eta> \<star>\<^sub>S S.UP g)"
             using antipar S.comp_inv_arr' S.comp_cod_arr by auto
           moreover have "(S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S
                          (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))
                            = (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))"
           proof -
             have "S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g) = S.UP g \<star>\<^sub>S S.UP (f \<star> g)"
               using antipar S.comp_inv_arr' UP.cmp_in_hom by auto
             thus ?thesis
               using antipar VV.arr_char\<^sub>S\<^sub>b\<^sub>C S.comp_cod_arr by simp
           qed
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                            (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                            S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
             using antipar VV.arr_char\<^sub>S\<^sub>b\<^sub>C S.whisker_left S.whisker_right by auto
         finally show ?thesis by simp
       qed
       show T2: "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
                 (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.unit (src g))) \<cdot>\<^sub>S
                    (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
         using UP.image_of_unitor by simp
       show "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
             S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
       proof -
         have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
                  S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.UP \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>S S.UP (f \<star> \<eta>)"
           using antipar by simp
         also have "... = S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                           (S.inv (S.cmp\<^sub>U\<^sub>P (f \<star> g, f)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f \<star> g, f) \<cdot>\<^sub>S
                            (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                          (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f))) \<cdot>\<^sub>S (S.inv (S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) \<cdot>\<^sub>S
                          S.cmp\<^sub>U\<^sub>P (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         proof -
           have "S.UP \<a>\<^sup>-\<^sup>1[f, g, f] =
                 S.cmp\<^sub>U\<^sub>P (f \<star> g, f) \<cdot>\<^sub>S (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f))) \<cdot>\<^sub>S
                    S.inv (S.cmp\<^sub>U\<^sub>P (f, g \<star> f))"
             using ide_left ide_right antipar UP.image_of_associator by simp
           moreover have "S.UP (\<epsilon> \<star> f) =
                          S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f \<star> g, f))"
           proof -
             have "S.seq (S.cmp\<^sub>U\<^sub>P (trg f, f)) (S.UP \<epsilon> \<star>\<^sub>S S.UP f)"
               using antipar UP.FF_def VV.ide_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C UP.cmp_in_hom [of "trg f" f]
               apply (intro S.seqI) by auto
             moreover have
               "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) = S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f \<star> g, f)"
               using antipar UP.\<Phi>.naturality [of "(\<epsilon>, f)"] UP.FF_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.iso (S.cmp\<^sub>U\<^sub>P (f \<star> g, f))"
               using antipar by simp
             ultimately show ?thesis
               using antipar S.comp_assoc
                     S.invert_side_of_triangle(2)
                       [of "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f)" "S.UP (\<epsilon> \<star> f)"
                           "S.cmp\<^sub>U\<^sub>P (f \<star> g, f)"]
               by metis
           qed
           moreover have "S.UP (f \<star> \<eta>) =
                         (S.cmp\<^sub>U\<^sub>P (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
           proof -
             have "S.cmp\<^sub>U\<^sub>P (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
                   S.UP (f \<star> \<eta>) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, src f)"
               using antipar UP.\<Phi>.naturality [of "(f, \<eta>)"] UP.FF_def VV.arr_char\<^sub>S\<^sub>b\<^sub>C
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.seq (S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) (S.UP f \<star>\<^sub>S S.UP \<eta>)"
               using antipar by (intro S.seqI, auto)
             ultimately show ?thesis
               using antipar S.invert_side_of_triangle(2) by auto
           qed
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S
                            ((S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                            ((S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                            S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         proof -
           have "(S.inv (S.cmp\<^sub>U\<^sub>P (f \<star> g, f)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f \<star> g, f)) \<cdot>\<^sub>S (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) =
                 (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)"
             using antipar S.comp_cod_arr VV.arr_char\<^sub>S\<^sub>b\<^sub>C S.comp_inv_arr' by auto
           moreover have "(S.inv (S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) \<cdot>\<^sub>S
                          (S.UP f \<star>\<^sub>S S.UP \<eta>)
                          = (S.UP f \<star>\<^sub>S S.UP \<eta>)"
             using antipar S.comp_inv_arr' S.comp_cod_arr by auto
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                            (S.UP f \<star>\<^sub>S
                               S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
             using antipar VV.arr_char\<^sub>S\<^sub>b\<^sub>C S.whisker_left S.whisker_right by auto
         finally show ?thesis by simp
       qed
       show "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
             (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         using UP.image_of_unitor by simp
       show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
               S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                   (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
               (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                   (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
       proof -
         assume A: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         have B: "(S.UP g \<star>\<^sub>S S.inv (UP.unit (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                    (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
         proof -
           show "(S.UP g \<star>\<^sub>S S.inv (UP.unit (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                 (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
           proof -
             have 2: "S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                        (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                        S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))
                      = (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.unit (src g))) \<cdot>\<^sub>S
                          (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
               using A T1 T2 by simp
             show ?thesis
             proof -
               have 8: "S.seq (S.cmp\<^sub>U\<^sub>P (g, src g))
                              ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                                S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                 using antipar VV.arr_char\<^sub>S\<^sub>b\<^sub>C S.hcomp_assoc
                 by (metis (no_types, lifting) S.arr_UP T1 arrI triangle_in_hom(2))
               have 7: "S.seq (S.cmp\<^sub>U\<^sub>P (g, src g))
                              ((S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                                S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                 using antipar 2 8 S.comp_assoc by auto
               have 5: "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                          (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
                        (S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g)"
               proof -
                 have "((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S
                         S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)) =
                       ((S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                         S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
                 proof -
                   have "S.mono (S.cmp\<^sub>U\<^sub>P (g, src g))"
                     using antipar S.iso_is_section S.section_is_mono by simp
                   thus ?thesis
                     using 2 8 7 S.monoE S.comp_assoc by presburger
                 qed
                 moreover have "S.epi (S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                   using antipar S.iso_is_retraction S.retraction_is_epi by simp
                 moreover have "S.seq ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                       (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S
                                       S.UP \<eta> \<star>\<^sub>S S.UP g))
                                      (S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                   using S.comp_assoc S.seq_char 8 by presburger
                 moreover have
                   "S.seq ((S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g))
                          (S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                   using antipar calculation(1,3) by presburger
                 ultimately show ?thesis
                   using 2 S.epiE by blast
               qed
               have 6: "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))
                              (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                 using antipar VV.arr_char\<^sub>S\<^sub>b\<^sub>C S.hcomp_assoc by auto
               have 3: "(S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                        (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
                        (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g)"
               proof -
                 have "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))
                             (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                   using 6 by simp
                 moreover have "(S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) =
                                (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                  (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                   using 5 by argo
                 moreover have "S.iso (S.UP g \<star>\<^sub>S UP.unit (src g))"
                   using antipar UP.unit_char S.UP_map\<^sub>0_obj by simp
                 moreover have "S.inv (S.UP g \<star>\<^sub>S UP.unit (src g)) =
                                S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))"
                   using antipar UP.unit_char S.UP_map\<^sub>0_obj by simp
                 ultimately show ?thesis
                   using S.invert_side_of_triangle(1)
                           [of "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                  (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                               "S.UP g \<star>\<^sub>S UP.unit (src g)" "S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g"]
                   by presburger
               qed
               have 4: "((S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S
                          (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                          ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                          (UP.unit (trg g) \<star>\<^sub>S S.UP g)
                        = S.UP g"
               proof -
                 have "(((S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                          ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                          (UP.unit (trg g) \<star>\<^sub>S S.UP g)) =
                       (((S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S
                          (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                          ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g))) \<cdot>\<^sub>S
                          (UP.unit (trg g) \<star>\<^sub>S S.UP g)"
                   using S.comp_assoc by simp
                 also have "... =
                            (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (UP.unit (trg g) \<star>\<^sub>S S.UP g)"
                   using 3 S.comp_assoc by auto
                 also have "... = S.inv (UP.unit (trg g)) \<cdot>\<^sub>S UP.unit (trg g) \<star>\<^sub>S S.UP g"
                   using UP.unit_char(2) S.whisker_right by auto
                 also have "... = UP.map\<^sub>0 (trg g) \<star>\<^sub>S S.UP g"
                   using UP.unit_char [of "trg g"] S.comp_inv_arr S.inv_is_inverse by simp
                 also have "... = S.UP g"
                   using S.UP_map\<^sub>0_obj by (simp add: S.hcomp_obj_arr)
                 finally show ?thesis by blast
               qed
               thus ?thesis
                 using antipar S.whisker_left S.whisker_right UP.unit_char S.comp_assoc by simp
             qed
           qed
         qed
         show "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                 (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
               (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                 (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         proof -
           have "(S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
                    (UP.unit (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f)))"
           proof -
             have 2: "(S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                         ((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                           (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                         (S.UP f \<star>\<^sub>S UP.unit (src f)) =
                      S.UP f"
             proof -
               have "S.UP f = (S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S 
                                S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f))"
                 using B antipar E.triangle_right_implies_left by argo
               also have "... = (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                  ((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                     (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                                  (S.UP f \<star>\<^sub>S UP.unit (src f))"
               proof -
                 have "S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f =
                         (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                         (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)"
                   using UP.unit_char S.whisker_right by simp
                 moreover have "S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f) =
                                  (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
                                    (S.UP f \<star>\<^sub>S UP.unit (src f))"
                   using antipar UP.unit_char S.whisker_left S.comp_assoc by simp
                 ultimately show ?thesis
                   using S.comp_assoc by presburger
               qed
               finally show ?thesis by argo
             qed
             show ?thesis
             proof -
               have "((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                         (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                         (S.UP f \<star>\<^sub>S UP.unit (src f)) =
                      (UP.unit (trg f) \<star>\<^sub>S S.UP f)"
               proof -
                 have "S.inv (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.UP f =
                       UP.unit (trg f) \<star>\<^sub>S S.UP f"
                   using UP.unit_char S.comp_arr_dom S.UP_map\<^sub>0_obj
                   by (simp add: S.hcomp_obj_arr)
                 moreover have "S.arr (S.UP f)"
                   by simp
                 moreover have "S.iso (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f)"
                   using S.UP_map\<^sub>0_obj by (simp add: UP.unit_char(2))
                 ultimately show ?thesis
                   using 2 S.invert_side_of_triangle(1)
                             [of "S.UP f" "S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f"
                                 "((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                    (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                                  (S.UP f \<star>\<^sub>S UP.unit (src f))"]
                   by presburger
               qed
               moreover have "S.hseq (UP.unit (trg f)) (S.UP f) \<and>
                              S.iso (S.UP f \<star>\<^sub>S UP.unit (src f)) \<and>
                              S.inv (S.UP f \<star>\<^sub>S UP.unit (src f)) = S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))"
                 using UP.unit_char S.UP_map\<^sub>0_obj by simp
               ultimately show ?thesis
                 using S.invert_side_of_triangle(2)
                         [of "UP.unit (trg f) \<star>\<^sub>S S.UP f"
                             "(S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
                             "S.UP f \<star>\<^sub>S UP.unit (src f)"]
                 by presburger
             qed
           qed
           hence "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S ((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                    (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
                  S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S ((UP.unit (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                    (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f)))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
             by simp
           thus ?thesis
             using S.comp_assoc by simp
         qed
       qed
     qed
 
     lemma triangle_right_implies_left:
     assumes "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
     shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
     proof -
       have "par ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
         using antipar by simp
       moreover have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
         using assms UP_triangle(3-5) by simp
       ultimately show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
         using UP.is_faithful by blast
     qed
 
     text \<open>
       We \emph{really} don't want to go through the ordeal of proving a dual version of
       \<open>UP_triangle(5)\<close>, do we?  So let's be smart and dualize via the opposite bicategory.
     \<close>
 
     lemma triangle_left_implies_right:
     assumes "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
     shows "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
     proof -
       interpret Cop: op_bicategory V H \<a> \<i> src trg ..
       interpret Eop: equivalence_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f \<eta> \<epsilon>
         using antipar unit_in_hom counit_in_hom
         by (unfold_locales) simp_all
       have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<Longrightarrow>
             (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         using antipar Cop.lunit_ide_simp Cop.runit_ide_simp Cop.assoc_ide_simp
               VVV.ide_char VVV.arr_char\<^sub>S\<^sub>b\<^sub>C VV.arr_char\<^sub>S\<^sub>b\<^sub>C Eop.triangle_right_implies_left
         by simp
       thus ?thesis
         using assms by simp
     qed
 
     lemma triangle_left_iff_right:
     shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
            (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
       using triangle_left_implies_right triangle_right_implies_left by auto
 
   end
 
   text \<open>
     We might as well specialize the dual result back to the strict case while we are at it.
   \<close>
 
   context equivalence_in_strict_bicategory
   begin
 
     lemma triangle_left_iff_right:
     shows "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
     proof -
       have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
       proof -
         have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = f"
           using strict_lunit strict_runit by simp
         moreover have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)"
           using antipar strict_assoc assoc'_in_hom(2) [of f g f] comp_cod_arr
           by auto
         ultimately show ?thesis by simp
       qed
       also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         using triangle_left_iff_right by blast
       also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
       proof -
         have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = g"
           using strict_lunit strict_runit by simp
         moreover have "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g)"
           using antipar strict_assoc assoc_in_hom(2) [of g f g] comp_cod_arr
           by auto
         ultimately show ?thesis by simp
       qed
       finally show ?thesis by simp
     qed
 
   end
 
 end
diff --git a/thys/Category3/CartesianCategory.thy b/thys/Category3/CartesianCategory.thy
--- a/thys/Category3/CartesianCategory.thy
+++ b/thys/Category3/CartesianCategory.thy
@@ -1,2444 +1,2444 @@
 (*  Title:       CartesianCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "Cartesian Category"
 
 text\<open>
   In this chapter, we explore the notion of a ``cartesian category'', which we define
   to be a category having binary products and a terminal object.
   We show that every cartesian category extends to an ``elementary cartesian category'',
   whose definition assumes that specific choices have been made for projections and
   terminal object.
   Conversely, the underlying category of an elementary cartesian category is a
   cartesian category.
   We also show that cartesian categories are the same thing as categories with
   finite products.
 \<close>
 
 theory CartesianCategory
 imports Limit SetCat CategoryWithPullbacks
 begin
 
   section "Category with Binary Products"
 
   subsection "Binary Product Diagrams"
 
   text \<open>
     The ``shape'' of a binary product diagram is a category having two distinct identity arrows
     and no non-identity arrows.
   \<close>
 
   locale binary_product_shape
   begin
 
     sublocale concrete_category \<open>UNIV :: bool set\<close> \<open>\<lambda>a b. if a = b then {()} else {}\<close>
                                 \<open>\<lambda>_. ()\<close> \<open>\<lambda>_ _ _ _ _. ()\<close>
       apply (unfold_locales, auto)
        apply (meson empty_iff)
       by (meson empty_iff)
 
     abbreviation comp
     where "comp \<equiv> COMP"
 
     abbreviation FF
     where "FF \<equiv> MkIde False"
 
     abbreviation TT
     where "TT \<equiv> MkIde True"
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> f = FF \<or> f = TT"
       using arr_char by (cases f, simp_all)
 
     lemma ide_char:
     shows "ide f \<longleftrightarrow> f = FF \<or> f = TT"
-      using ide_char ide_MkIde by (cases f, auto)
+      using ide_char\<^sub>C\<^sub>C ide_MkIde by (cases f, auto)
 
     lemma is_discrete:
     shows "ide f \<longleftrightarrow> arr f"
       using arr_char ide_char by simp
 
     lemma dom_simp [simp]:
     assumes "arr f"
     shows "dom f = f"
       using assms is_discrete by simp
 
     lemma cod_simp [simp]:
     assumes "arr f"
     shows "cod f = f"
       using assms is_discrete by simp
 
     lemma seq_char:
     shows "seq f g \<longleftrightarrow> arr f \<and> f = g"
       by auto
 
     lemma comp_simp [simp]:
     assumes "seq f g"
     shows "comp f g = f"
       using assms seq_char by fastforce
 
   end
 
   locale binary_product_diagram =
     J: binary_product_shape +
     C: category C
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and a0 :: 'c
   and a1 :: 'c +
   assumes is_discrete: "C.ide a0 \<and> C.ide a1"
   begin
 
     notation J.comp      (infixr "\<cdot>\<^sub>J" 55)
 
     fun map
     where "map J.FF = a0"
         | "map J.TT = a1"
         | "map _ = C.null"
 
     sublocale diagram J.comp C map
     proof
       show "\<And>f. \<not> J.arr f \<Longrightarrow> map f = C.null"
         using J.arr_char map.elims by auto
       fix f
       assume f: "J.arr f"
       show "C.arr (map f)"
         using f J.arr_char is_discrete C.ideD(1) map.simps(1-2) by metis
       show "C.dom (map f) = map (J.dom f)"
         using f J.arr_char J.dom_char is_discrete by force
       show "C.cod (map f) = map (J.cod f)"
         using f J.arr_char J.cod_char is_discrete by force
       next
       fix f g
       assume fg: "J.seq g f"
       show "map (g \<cdot>\<^sub>J f) = map g \<cdot> map f"
         using fg J.arr_char J.seq_char J.null_char J.not_arr_null is_discrete
         by (metis (no_types, lifting) C.comp_ide_self J.comp_simp map.simps(1-2))
     qed
 
   end
 
   subsection "Category with Binary Products"
 
   text \<open>
     A \emph{binary product} in a category @{term C} is a limit of a binary product diagram
     in @{term C}.
   \<close>
 
   context binary_product_diagram
   begin
 
     definition mkCone
     where "mkCone p0 p1 \<equiv> \<lambda>j. if j = J.FF then p0 else if j = J.TT then p1 else C.null"
 
     abbreviation is_rendered_commutative_by
     where "is_rendered_commutative_by p0 p1 \<equiv>
            C.seq a0 p0 \<and> C.seq a1 p1 \<and> C.dom p0 = C.dom p1"
 
     abbreviation has_as_binary_product
     where "has_as_binary_product p0 p1 \<equiv> limit_cone (C.dom p0) (mkCone p0 p1)"
 
     lemma cone_mkCone:
     assumes "is_rendered_commutative_by p0 p1"
     shows "cone (C.dom p0) (mkCone p0 p1)"
     proof -
       interpret E: constant_functor J.comp C \<open>C.dom p0\<close>
         using assms by unfold_locales auto
       show "cone (C.dom p0) (mkCone p0 p1)"
         using assms mkCone_def J.arr_char E.map_simp is_discrete C.comp_ide_arr C.comp_arr_dom
         by unfold_locales auto
     qed
 
     lemma is_rendered_commutative_by_cone:
     assumes "cone a \<chi>"
     shows "is_rendered_commutative_by (\<chi> J.FF) (\<chi> J.TT)"
     proof -
       interpret \<chi>: cone J.comp C map a \<chi>
         using assms by auto
       show ?thesis
         using is_discrete by simp
     qed
 
     lemma mkCone_cone:
     assumes "cone a \<chi>"
     shows "mkCone (\<chi> J.FF) (\<chi> J.TT) = \<chi>"
     proof -
       interpret \<chi>: cone J.comp C map a \<chi>
         using assms by auto
       interpret mkCone_\<chi>: cone J.comp C map \<open>C.dom (\<chi> J.FF)\<close> \<open>mkCone (\<chi> J.FF) (\<chi> J.TT)\<close>
         using assms is_rendered_commutative_by_cone cone_mkCone by blast
       show ?thesis
         using mkCone_def \<chi>.is_extensional J.ide_char mkCone_def
               NaturalTransformation.eqI [of J.comp C]
               \<chi>.natural_transformation_axioms mkCone_\<chi>.natural_transformation_axioms
         by fastforce
     qed
 
     lemma cone_iff_span:
     shows "cone (C.dom h) (mkCone h k) \<longleftrightarrow> C.span h k \<and> C.cod h = a0 \<and> C.cod k = a1"
       using cone_mkCone mkCone_def J.arr_char J.ide_char is_rendered_commutative_by_cone
       apply (intro iffI)
         apply (metis (no_types, lifting) C.cod_eqI C.comp_ide_arr J.arr.inject is_discrete)
       by auto
 
     lemma cones_map_mkCone_eq_iff:
     assumes "is_rendered_commutative_by p0 p1" and "is_rendered_commutative_by p0' p1'"
     and "\<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
     shows "cones_map h (mkCone p0 p1) = mkCone p0' p1' \<longleftrightarrow> p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
     proof -
       interpret \<chi>: cone J.comp C map \<open>C.dom p0\<close> \<open>mkCone p0 p1\<close>
         using assms(1) cone_mkCone [of p0 p1] by blast
       interpret \<chi>': cone J.comp C map \<open>C.dom p0'\<close> \<open>mkCone p0' p1'\<close>
         using assms(2) cone_mkCone [of p0' p1'] by blast
       show ?thesis
       proof
         assume 3: "cones_map h (mkCone p0 p1) = mkCone p0' p1'"
         show "p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
         proof
           show "p0 \<cdot> h = p0'"
           proof -
             have "p0' = cones_map h (mkCone p0 p1) J.FF"
               using 3 mkCone_def J.arr_char by simp
             also have "... = p0 \<cdot> h"
               using assms mkCone_def J.arr_char \<chi>.cone_axioms by auto
             finally show ?thesis by auto
           qed
           show "p1 \<cdot> h = p1'"
           proof -
             have "p1' = cones_map h (mkCone p0 p1) J.TT"
               using 3 mkCone_def J.arr_char by simp
             also have "... = p1 \<cdot> h"
               using assms mkCone_def J.arr_char \<chi>.cone_axioms by auto
             finally show ?thesis by auto
           qed
         qed
         next
         assume "p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
         thus "cones_map h (mkCone p0 p1) = mkCone p0' p1'"
           using assms \<chi>.cone_axioms mkCone_def J.arr_char by auto
       qed
     qed
 
   end
 
   locale binary_product_cone =
     J: binary_product_shape +
     C: category C +
     D: binary_product_diagram C f0 f1 +
     limit_cone J.comp C D.map \<open>C.dom p0\<close> \<open>D.mkCone p0 p1\<close>
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and f0 :: 'c
   and f1 :: 'c
   and p0 :: 'c
   and p1 :: 'c
   begin
 
     lemma renders_commutative:
     shows "D.is_rendered_commutative_by p0 p1"
       using cone_axioms D.is_rendered_commutative_by_cone D.mkCone_def D.cone_iff_span
       by force
 
     lemma is_universal':
     assumes "D.is_rendered_commutative_by p0' p1'"
     shows "\<exists>!h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<and> p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
     proof -
       have "D.cone (C.dom p0') (D.mkCone p0' p1')"
         using assms D.cone_mkCone by blast
       hence "\<exists>!h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<and>
                   D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
         using is_universal by simp
       moreover have "\<And>h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<Longrightarrow>
                            D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' \<longleftrightarrow>
                            p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
         using assms D.cones_map_mkCone_eq_iff [of p0 p1 p0' p1'] renders_commutative
         by blast
       ultimately show ?thesis by blast
     qed
 
     lemma induced_arrowI':
     assumes "D.is_rendered_commutative_by p0' p1'"
     shows "\<guillemotleft>induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
     and "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
     and "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
     proof -
       interpret A': constant_functor J.comp C \<open>C.dom p0'\<close>
         using assms by (unfold_locales, auto)
       have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
         using assms D.cone_mkCone [of p0' p1'] by blast
       show 0: "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
       proof -
         have "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') =
                 D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                             (D.mkCone p0 p1) J.FF"
           using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
         also have "... = p0'"
         proof -
           have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                             (D.mkCone p0 p1) =
                 D.mkCone p0' p1'"
             using cone induced_arrowI by blast
           thus ?thesis
             using J.arr_char D.mkCone_def by simp
         qed
         finally show ?thesis by auto
       qed
       show "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
       proof -
         have "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') =
                 D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                             (D.mkCone p0 p1) J.TT"
           using assms cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by fastforce
         also have "... = p1'"
         proof -
           have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                             (D.mkCone p0 p1) =
                 D.mkCone p0' p1'"
             using cone induced_arrowI by blast
           thus ?thesis
             using J.arr_char D.mkCone_def by simp
         qed
         finally show ?thesis by auto
       qed
       show "\<guillemotleft>induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
         using 0 cone induced_arrowI by simp
     qed
 
   end
 
   context category
   begin
 
     definition has_as_binary_product
     where "has_as_binary_product a0 a1 p0 p1 \<equiv>
            ide a0 \<and> ide a1 \<and> binary_product_diagram.has_as_binary_product C a0 a1 p0 p1"
 
     definition has_binary_products
     where "has_binary_products =
            (\<forall>a0 a1. ide a0 \<and> ide a1 \<longrightarrow> (\<exists>p0 p1. has_as_binary_product a0 a1 p0 p1))"
 
     lemma has_as_binary_productI [intro]:
     assumes "ide a" and "ide b"
     and "\<guillemotleft>p : c \<rightarrow> a\<guillemotright>" and "\<guillemotleft>q : c \<rightarrow> b\<guillemotright>"
     and "\<And>x f g. \<lbrakk>\<guillemotleft>f : x \<rightarrow> a\<guillemotright>; \<guillemotleft>g : x \<rightarrow> b\<guillemotright>\<rbrakk> \<Longrightarrow> \<exists>!h. \<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> p \<cdot> h = f \<and> q \<cdot> h = g"
     shows "has_as_binary_product a b p q"
     proof (unfold has_as_binary_product_def, intro conjI)
       show "ide a" by fact
       show "ide b" by fact
       interpret J: binary_product_shape .
       interpret D: binary_product_diagram C a b
         using assms(1-2) by unfold_locales auto
       show "D.has_as_binary_product p q"
       proof -
         have 2: "D.is_rendered_commutative_by p q"
           using assms ide_in_hom by blast
         let ?\<chi> = "D.mkCone p q"
         interpret \<chi>: cone J.comp C D.map c ?\<chi>
            using assms(4) D.cone_mkCone 2 by auto
         interpret \<chi>: limit_cone J.comp C D.map c ?\<chi>
         proof
           fix x \<chi>'
           assume \<chi>': "D.cone x \<chi>'"
           interpret \<chi>': cone J.comp C D.map x \<chi>'
             using \<chi>' by simp
           have 1: "\<exists>!h. \<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> p \<cdot> h = \<chi>' J.FF \<and> q \<cdot> h = \<chi>' J.TT"
           proof -
             have "\<guillemotleft>\<chi>' J.FF : x \<rightarrow> a\<guillemotright> \<and> \<guillemotleft>\<chi>' J.TT : x \<rightarrow> b\<guillemotright>"
               by auto
             thus ?thesis
               using assms(5) [of "\<chi>' J.FF" x "\<chi>' J.TT"] by simp
           qed
           have 3: "D.is_rendered_commutative_by (\<chi>' J.FF) (\<chi>' J.TT)"
             using assms(1-2) by force
           obtain h where h: "\<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> p \<cdot> h = \<chi>' J.FF \<and> q \<cdot> h = \<chi>' J.TT"
             using 1 by blast
           have 4: "\<guillemotleft>h : dom (\<chi>' (J.MkIde False)) \<rightarrow> dom p\<guillemotright>"
             using assms(3) h by auto
           have "\<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> D.cones_map h (D.mkCone p q) = \<chi>'"
           proof (intro conjI)
             show "\<guillemotleft>h : x \<rightarrow> c\<guillemotright>"
               using h by blast
             show "D.cones_map h (D.mkCone p q) = \<chi>'"
             proof
               fix j
               show "D.cones_map h (D.mkCone p q) j = \<chi>' j"
                 using h 2 3 4 D.cones_map_mkCone_eq_iff [of p q "\<chi>' J.FF" "\<chi>' J.TT"]
                       \<chi>.cone_axioms J.is_discrete \<chi>'.is_extensional
                       D.mkCone_def binary_product_shape.ide_char
                 apply (cases "J.ide j")
                  apply auto[1]
                  by auto
             qed
           qed
           moreover have "\<And>h'. \<guillemotleft>h' : x \<rightarrow> c\<guillemotright> \<and> D.cones_map h' (D.mkCone p q) = \<chi>' \<Longrightarrow> h' = h"
           proof -
             fix h'
             assume 1: "\<guillemotleft>h' : x \<rightarrow> c\<guillemotright> \<and> D.cones_map h' (D.mkCone p q) = \<chi>'"
             have "\<exists>!h. \<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> p \<cdot> h = \<chi>' J.FF \<and> q \<cdot> h = \<chi>' J.TT"
             proof -
               have "\<guillemotleft>\<chi>' J.FF : x \<rightarrow> a\<guillemotright> \<and> \<guillemotleft>\<chi>' J.TT : x \<rightarrow> b\<guillemotright>"
                 by auto
               thus ?thesis
                 using h assms(5) [of "\<chi>' J.FF" x "\<chi>' J.TT"] J.ide_char by auto
             qed
             moreover have "\<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> \<chi>' J.FF = p \<cdot> h \<and> q \<cdot> h = \<chi>' J.TT"
               using h by simp
             moreover have "\<guillemotleft>h' : x \<rightarrow> c\<guillemotright> \<and> \<chi>' J.FF = p \<cdot> h' \<and> q \<cdot> h' = \<chi>' J.TT"
               using 1 \<chi>.cone_axioms D.mkCone_def [of p q] by auto
             ultimately show "h' = h" by auto
           qed
           ultimately show "\<exists>!h. \<guillemotleft>h : x \<rightarrow> c\<guillemotright> \<and> D.cones_map h (D.mkCone p q) = \<chi>'"
             by blast
         qed
         show "D.has_as_binary_product p q"
           using assms \<chi>.limit_cone_axioms by blast
       qed
     qed
 
     lemma has_as_binary_productE [elim]:
     assumes "has_as_binary_product a b p q"
     and "\<lbrakk>\<guillemotleft>p : dom p \<rightarrow> a\<guillemotright>; \<guillemotleft>q : dom p \<rightarrow> b\<guillemotright>;
           \<And>x f g. \<lbrakk>\<guillemotleft>f : x \<rightarrow> a\<guillemotright>; \<guillemotleft>g : x \<rightarrow> b\<guillemotright>\<rbrakk> \<Longrightarrow> \<exists>!h. p \<cdot> h = f \<and> q \<cdot> h = g\<rbrakk> \<Longrightarrow> T"
     shows T
     proof -
       interpret J: binary_product_shape .
       interpret D: binary_product_diagram C a b
         using assms(1) has_as_binary_product_def
         by (simp add: binary_product_diagram.intro binary_product_diagram_axioms.intro
                       category_axioms)
       have 1: "\<And>h k. span h k \<and> cod h = a \<and> cod k = b \<longleftrightarrow> D.cone (dom h) (D.mkCone h k)"
         using D.cone_iff_span by presburger
       let ?\<chi> = "D.mkCone p q"
       interpret \<chi>: limit_cone J.comp C D.map \<open>dom p\<close> ?\<chi>
         using assms(1) has_as_binary_product_def D.cone_mkCone by blast
       have span: "span p q"
         using 1 \<chi>.cone_axioms by blast
       moreover have "\<guillemotleft>p : dom p \<rightarrow> a\<guillemotright> \<and> \<guillemotleft>q : dom p \<rightarrow> b\<guillemotright>"
         using span \<chi>.preserves_hom \<chi>.cone_axioms binary_product_shape.arr_char
         by (metis D.cone_iff_span arr_iff_in_hom)
       moreover have "\<And>x f g. \<lbrakk>\<guillemotleft>f : x \<rightarrow> a\<guillemotright>; \<guillemotleft>g : x \<rightarrow> b\<guillemotright>\<rbrakk> \<Longrightarrow> \<exists>!l. p \<cdot> l = f \<and> q \<cdot> l = g"
       proof -
         fix x f g
         assume f: "\<guillemotleft>f : x \<rightarrow> a\<guillemotright>" and g: "\<guillemotleft>g : x \<rightarrow> b\<guillemotright>"
         let ?\<chi>' = "D.mkCone f g"
         interpret \<chi>': cone J.comp C D.map x ?\<chi>'
           using 1 f g by blast
         have 3: "\<exists>!l. \<guillemotleft>l : x \<rightarrow> dom p\<guillemotright> \<and> D.cones_map l ?\<chi> = ?\<chi>'"
           using 1 f g \<chi>.is_universal [of x "D.mkCone f g"] \<chi>'.cone_axioms by fastforce
         obtain l where l: "\<guillemotleft>l : x \<rightarrow> dom p\<guillemotright> \<and> D.cones_map l ?\<chi> = ?\<chi>'"
           using 3 by blast
         have "p \<cdot> l = f \<and> q \<cdot> l = g"
         proof
           have "p \<cdot> l = ?\<chi> J.FF \<cdot> l"
             using D.mkCone_def by presburger
           also have "... = D.cones_map l ?\<chi> J.FF"
             using \<chi>.cone_axioms
             apply simp
             using l by fastforce
           also have "... = f"
             using D.mkCone_def l by presburger
           finally show "p \<cdot> l = f" by blast
           have "q \<cdot> l = ?\<chi> J.TT \<cdot> l"
             using D.mkCone_def by simp
           also have "... = D.cones_map l ?\<chi> J.TT"
             using \<chi>.cone_axioms
             apply simp
             using l by fastforce
           also have "... = g"
             using D.mkCone_def l by simp
           finally show "q \<cdot> l = g" by blast
         qed
         moreover have "\<And>l'. p \<cdot> l' = f \<and> q \<cdot> l' = g\<Longrightarrow> l' = l"
         proof -
           fix l'
           assume 1: "p \<cdot> l' = f \<and> q \<cdot> l' = g"
           have 2: "\<guillemotleft>l' : x \<rightarrow> dom p\<guillemotright>"
             using 1 f by blast
           moreover have "D.cones_map l' ?\<chi> = ?\<chi>'"
             using 1 2 D.cones_map_mkCone_eq_iff [of p q f g l']
             by (metis (no_types, lifting) f g \<open>\<guillemotleft>p : dom p \<rightarrow> a\<guillemotright> \<and> \<guillemotleft>q : dom p \<rightarrow> b\<guillemotright>\<close>
                       comp_cod_arr in_homE)
           ultimately show "l' = l"
             using l \<chi>.is_universal \<chi>'.cone_axioms by blast
         qed
         ultimately show "\<exists>!l. p \<cdot> l = f \<and> q \<cdot> l = g" by blast
       qed
       ultimately show T
         using assms(2) by simp
     qed
 
   end
 
   locale category_with_binary_products =
     category +
   assumes has_binary_products: has_binary_products
 
   subsection "Elementary Category with Binary Products"
 
   text \<open>
     An \emph{elementary category with binary products} is a category equipped with a specific
     way of mapping each pair of objects \<open>a\<close> and \<open>b\<close> to a pair of arrows \<open>\<pp>\<^sub>1[a, b]\<close> and \<open>\<pp>\<^sub>0[a, b]\<close>
     that comprise a universal span.  It is useful to assume that the mappings that produce
     \<open>\<pp>\<^sub>1[a, b]\<close> and \<open>\<pp>\<^sub>0[a, b]\<close> from \<open>a\<close> and \<open>b\<close> are extensional; that is, if either \<open>a\<close> or \<open>b\<close>
     is not an identity, then \<open>\<pp>\<^sub>1[a, b]\<close> and \<open>\<pp>\<^sub>0[a, b]\<close> are \<open>null\<close>.
   \<close>
 
   locale elementary_category_with_binary_products =
     category C
   for C :: "'a comp"                             (infixr "\<cdot>" 55)
   and pr0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"                    ("\<pp>\<^sub>0[_, _]")
   and pr1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"                    ("\<pp>\<^sub>1[_, _]") +
   assumes pr0_ext: "\<not> (ide a \<and> ide b) \<Longrightarrow> \<pp>\<^sub>0[a, b] = null"
   and pr1_ext: "\<not> (ide a \<and> ide b) \<Longrightarrow> \<pp>\<^sub>1[a, b] = null"
   and span_pr: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> span \<pp>\<^sub>1[a, b] \<pp>\<^sub>0[a, b]"
   and cod_pr0: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> cod \<pp>\<^sub>0[a, b] = b"
   and cod_pr1: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> cod \<pp>\<^sub>1[a, b] = a"
   and universal: "span f g \<Longrightarrow> \<exists>!l. \<pp>\<^sub>1[cod f, cod g] \<cdot> l = f \<and> \<pp>\<^sub>0[cod f, cod g] \<cdot> l = g"
   begin
 
     lemma pr0_in_hom':
     assumes "ide a" and "ide b"
     shows "\<guillemotleft>\<pp>\<^sub>0[a, b] : dom \<pp>\<^sub>0[a, b] \<rightarrow> b\<guillemotright>"
       using assms span_pr cod_pr0 by auto
 
     lemma pr1_in_hom':
     assumes "ide a" and "ide b"
     shows "\<guillemotleft>\<pp>\<^sub>1[a, b] : dom \<pp>\<^sub>0[a, b] \<rightarrow> a\<guillemotright>"
       using assms span_pr cod_pr1 by auto
 
     text \<open>
       We introduce a notation for tupling, which denotes the arrow into a product that
       is induced by a span.
     \<close>
 
     definition tuple         ("\<langle>_, _\<rangle>")
     where "\<langle>f, g\<rangle> \<equiv> if span f g then
                       THE l. \<pp>\<^sub>1[cod f, cod g] \<cdot> l = f \<and> \<pp>\<^sub>0[cod f, cod g] \<cdot> l = g
                     else null"
 
     text \<open>
       The following defines product of arrows (not just of objects).  It will take a little
       while before we can prove that it is functorial, but for right now it is nice to have
       it as a notation for the apex of a product cone.  We have to go through some slightly
       unnatural contortions in the development here, though, to avoid having to introduce a
       separate preliminary notation just for the product of objects.
     \<close>
     (* TODO: I want to use \<times> but it has already been commandeered for product types. *)
     definition prod         (infixr "\<otimes>" 51)
     where "f \<otimes> g \<equiv> \<langle>f \<cdot> \<pp>\<^sub>1[dom f, dom g], g \<cdot> \<pp>\<^sub>0[dom f, dom g]\<rangle>"
 
     lemma seq_pr_tuple:
     assumes "span f g"
     shows "seq \<pp>\<^sub>0[cod f, cod g] \<langle>f, g\<rangle>"
     proof -
       have "\<pp>\<^sub>0[cod f, cod g] \<cdot> \<langle>f, g\<rangle> = g"
         unfolding tuple_def
         using assms universal theI [of "\<lambda>l. \<pp>\<^sub>1[cod f, cod g] \<cdot> l = f \<and> \<pp>\<^sub>0[cod f, cod g] \<cdot> l = g"]
         by simp meson
       thus ?thesis
         using assms by simp
     qed
 
     lemma tuple_pr_arr:
     assumes "ide a" and "ide b" and "seq \<pp>\<^sub>0[a, b] h"
     shows "\<langle>\<pp>\<^sub>1[a, b] \<cdot> h, \<pp>\<^sub>0[a, b] \<cdot> h\<rangle> = h"
       unfolding tuple_def
       using assms span_pr cod_pr0 cod_pr1 universal [of "\<pp>\<^sub>1[a, b] \<cdot> h" "\<pp>\<^sub>0[a, b] \<cdot> h"]
             theI_unique [of "\<lambda>l. \<pp>\<^sub>1[a, b] \<cdot> l = \<pp>\<^sub>1[a, b] \<cdot> h \<and> \<pp>\<^sub>0[a, b] \<cdot> l = \<pp>\<^sub>0[a, b] \<cdot> h" h]
       by auto
 
     lemma pr_tuple [simp]:
     assumes "span f g" and "cod f = a" and "cod g = b"
     shows "\<pp>\<^sub>1[a, b] \<cdot> \<langle>f, g\<rangle> = f" and "\<pp>\<^sub>0[a, b] \<cdot> \<langle>f, g\<rangle> = g"
     proof -
       have 1: "\<pp>\<^sub>1[a, b] \<cdot> \<langle>f, g\<rangle> = f \<and> \<pp>\<^sub>0[a, b] \<cdot> \<langle>f, g\<rangle> = g"
         unfolding tuple_def
         using assms universal theI [of "\<lambda>l. \<pp>\<^sub>1[a, b] \<cdot> l = f \<and> \<pp>\<^sub>0[a, b] \<cdot> l = g"]
         by simp meson
       show "\<pp>\<^sub>1[a, b] \<cdot> \<langle>f, g\<rangle> = f" using 1 by simp
       show "\<pp>\<^sub>0[a, b] \<cdot> \<langle>f, g\<rangle> = g" using 1 by simp
     qed
 
     lemma cod_tuple:
     assumes "span f g"
     shows "cod \<langle>f, g\<rangle> = cod f \<otimes> cod g"
     proof -
       have "cod f \<otimes> cod g = \<langle>\<pp>\<^sub>1[cod f, cod g], \<pp>\<^sub>0[cod f, cod g]\<rangle>"
         unfolding prod_def
         using assms comp_cod_arr span_pr cod_pr0 cod_pr1 by simp
       also have "... = \<langle>\<pp>\<^sub>1[cod f, cod g] \<cdot> dom \<pp>\<^sub>0[cod f, cod g],
                         \<pp>\<^sub>0[cod f, cod g] \<cdot> dom \<pp>\<^sub>0[cod f, cod g]\<rangle>"
         using assms span_pr comp_arr_dom by simp
       also have "... = dom \<pp>\<^sub>0[cod f, cod g]"
         using assms tuple_pr_arr span_pr by simp
       also have "... = cod \<langle>f, g\<rangle>"
         using assms seq_pr_tuple by blast
       finally show ?thesis by simp
     qed
 
     lemma tuple_in_hom [intro]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : a \<rightarrow> c\<guillemotright>"
     shows "\<guillemotleft>\<langle>f, g\<rangle> : a \<rightarrow> b \<otimes> c\<guillemotright>"
       using assms pr_tuple dom_comp cod_tuple
       apply (elim in_homE, intro in_homI)
         apply (metis seqE)
       by metis+
 
     lemma tuple_in_hom' [simp]:
     assumes "arr f" and "dom f = a" and "cod f = b"
     and "arr g" and "dom g = a" and "cod g = c"
     shows "\<guillemotleft>\<langle>f, g\<rangle> : a \<rightarrow> b \<otimes> c\<guillemotright>"
       using assms by auto
 
     lemma tuple_ext:
     assumes "\<not> span f g"
     shows "\<langle>f, g\<rangle> = null"
       unfolding tuple_def
       by (simp add: assms)
 
     lemma tuple_simps [simp]:
     assumes "span f g"
     shows "arr \<langle>f, g\<rangle>" and "dom \<langle>f, g\<rangle> = dom f" and "cod \<langle>f, g\<rangle> = cod f \<otimes> cod g"
     proof -
       show "arr \<langle>f, g\<rangle>"
         using assms tuple_in_hom by blast
       show "dom \<langle>f, g\<rangle> = dom f"
         using assms tuple_in_hom
         by (metis dom_comp pr_tuple(1))
       show "cod \<langle>f, g\<rangle> = cod f \<otimes> cod g"
         using assms cod_tuple by auto
     qed
 
     lemma tuple_pr [simp]:
     assumes "ide a" and "ide b"
     shows "\<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle> = a \<otimes> b"
     proof -
       have 1: "dom \<pp>\<^sub>0[a, b] = a \<otimes> b"
         using assms seq_pr_tuple cod_tuple [of "\<pp>\<^sub>1[a, b]" "\<pp>\<^sub>0[a, b]"] span_pr
               pr0_in_hom' pr1_in_hom'
         by (metis cod_pr0 cod_pr1 seqE)
       hence "\<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle> = \<langle>\<pp>\<^sub>1[a, b] \<cdot> (a \<otimes> b), \<pp>\<^sub>0[a, b] \<cdot> (a \<otimes> b)\<rangle>"
         using assms pr0_in_hom' pr1_in_hom' comp_arr_dom span_pr by simp
       thus ?thesis
         using assms 1 tuple_pr_arr span_pr
         by (metis comp_arr_dom)
     qed
 
     lemma pr_in_hom [intro, simp]:
     assumes "ide a" and "ide b"
     shows "\<guillemotleft>\<pp>\<^sub>0[a, b] : a \<otimes> b \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<pp>\<^sub>1[a, b] : a \<otimes> b \<rightarrow> a\<guillemotright>"
     proof -
       show 0: "\<guillemotleft>\<pp>\<^sub>0[a, b] : a \<otimes> b \<rightarrow> b\<guillemotright>"
         using assms pr0_in_hom' seq_pr_tuple [of "\<pp>\<^sub>1[a, b]" "\<pp>\<^sub>0[a, b]"]
               cod_tuple [of "\<pp>\<^sub>1[a, b]" "\<pp>\<^sub>0[a, b]"] span_pr cod_pr0 cod_pr1
         by (intro in_homI, auto)
       show "\<guillemotleft>\<pp>\<^sub>1[a, b] : a \<otimes> b \<rightarrow> a\<guillemotright>"
         using assms 0 span_pr pr1_in_hom' by fastforce
     qed
 
     lemma pr_simps [simp]:
     assumes "ide a" and "ide b"
     shows "arr \<pp>\<^sub>0[a, b]" and "dom \<pp>\<^sub>0[a, b] = a \<otimes> b" and "cod \<pp>\<^sub>0[a, b] = b"
     and "arr \<pp>\<^sub>1[a, b]" and "dom \<pp>\<^sub>1[a, b] = a \<otimes> b" and "cod \<pp>\<^sub>1[a, b] = a"
       using assms pr_in_hom by blast+
 
     lemma arr_pr0_iff [iff]:
     shows "arr \<pp>\<^sub>0[a, b] \<longleftrightarrow> ide a \<and> ide b"
     proof
       show "ide a \<and> ide b \<Longrightarrow> arr \<pp>\<^sub>0[a, b]"
         using pr_in_hom by auto
       show "arr \<pp>\<^sub>0[a, b] \<Longrightarrow> ide a \<and> ide b"
         using pr0_ext not_arr_null by metis
     qed
 
     lemma arr_pr1_iff [iff]:
     shows "arr \<pp>\<^sub>1[a, b] \<longleftrightarrow> ide a \<and> ide b"
     proof
       show "ide a \<and> ide b \<Longrightarrow> arr \<pp>\<^sub>1[a, b]"
         using pr_in_hom by auto
       show "arr \<pp>\<^sub>1[a, b] \<Longrightarrow> ide a \<and> ide b"
         using pr1_ext not_arr_null by metis
     qed
 
     lemma pr_joint_monic:
     assumes "seq \<pp>\<^sub>0[a, b] h"
     and "\<pp>\<^sub>0[a, b] \<cdot> h = \<pp>\<^sub>0[a, b] \<cdot> h'" and "\<pp>\<^sub>1[a, b] \<cdot> h = \<pp>\<^sub>1[a, b] \<cdot> h'"
     shows "h = h'"
       using assms
       by (metis arr_pr0_iff seqE tuple_pr_arr)
 
     lemma comp_tuple_arr [simp]:
     assumes "span f g" and "arr h" and "dom f = cod h"
     shows "\<langle>f, g\<rangle> \<cdot> h = \<langle>f \<cdot> h, g \<cdot> h\<rangle>"
     proof (intro pr_joint_monic [where h = "\<langle>f, g\<rangle> \<cdot> h"])
       show "seq \<pp>\<^sub>0[cod f, cod g] (\<langle>f, g\<rangle> \<cdot> h)"
         using assms by fastforce
       show "\<pp>\<^sub>0[cod f, cod g] \<cdot> \<langle>f, g\<rangle> \<cdot> h = \<pp>\<^sub>0[cod f, cod g] \<cdot> \<langle>f \<cdot> h, g \<cdot> h\<rangle>"
       proof -
         have "\<pp>\<^sub>0[cod f, cod g] \<cdot> \<langle>f, g\<rangle> \<cdot> h = (\<pp>\<^sub>0[cod f, cod g] \<cdot> \<langle>f, g\<rangle>) \<cdot> h"
           using comp_assoc by simp
         thus ?thesis
           using assms by simp
       qed
       show "\<pp>\<^sub>1[cod f, cod g] \<cdot> \<langle>f, g\<rangle> \<cdot> h = \<pp>\<^sub>1[cod f, cod g] \<cdot> \<langle>f \<cdot> h, g \<cdot> h\<rangle>"
       proof -
         have "\<pp>\<^sub>1[cod f, cod g] \<cdot> \<langle>f, g\<rangle> \<cdot> h = (\<pp>\<^sub>1[cod f, cod g] \<cdot> \<langle>f, g\<rangle>) \<cdot> h"
           using comp_assoc by simp
         thus ?thesis
           using assms by simp
       qed
     qed
 
     lemma ide_prod [intro, simp]:
     assumes "ide a" and "ide b"
     shows "ide (a \<otimes> b)"
       using assms pr_simps ide_dom [of "\<pp>\<^sub>0[a, b]"] by simp
 
     lemma prod_in_hom [intro]:
     assumes "\<guillemotleft>f : a \<rightarrow> c\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> d\<guillemotright>"
     shows "\<guillemotleft>f \<otimes> g : a \<otimes> b \<rightarrow> c \<otimes> d\<guillemotright>"
       using assms prod_def by fastforce
 
     lemma prod_in_hom' [simp]:
     assumes "arr f" and "dom f = a" and "cod f = c"
     and "arr g" and "dom g = b" and "cod g = d"
     shows "\<guillemotleft>f \<otimes> g : a \<otimes> b \<rightarrow> c \<otimes> d\<guillemotright>"
       using assms by blast
 
     lemma prod_simps [simp]:
     assumes "arr f0" and "arr f1"
     shows "arr (f0 \<otimes> f1)"
     and "dom (f0 \<otimes> f1) = dom f0 \<otimes> dom f1"
     and "cod (f0 \<otimes> f1) = cod f0 \<otimes> cod f1"
       using assms prod_in_hom by blast+
 
   end
 
   subsection "Agreement between the Definitions"
 
   text \<open>
     We now show that a category with binary products extends (by making a choice)
     to an elementary category with binary products, and that the underlying category
     of an elementary category with binary products is a category with binary products.
   \<close>
 
   context category_with_binary_products
   begin
 
     definition pr1
     where "pr1 a b \<equiv> if ide a \<and> ide b then
                         fst (SOME x. has_as_binary_product a b (fst x) (snd x))
                       else null"
 
     definition pr0
     where "pr0 a b \<equiv> if ide a \<and> ide b then
                         snd (SOME x. has_as_binary_product a b (fst x) (snd x))
                       else null"
 
     lemma pr_yields_binary_product:
     assumes "ide a" and "ide b"
     shows "has_as_binary_product a b (pr1 a b) (pr0 a b)"
     proof -
       have "\<exists>x. has_as_binary_product a b (fst x) (snd x)"
         using assms has_binary_products has_binary_products_def has_as_binary_product_def
         by simp
       thus ?thesis
         using assms has_binary_products has_binary_products_def pr0_def pr1_def
               someI_ex [of "\<lambda>x. has_as_binary_product a b (fst x) (snd x)"]
         by simp
     qed
 
     interpretation elementary_category_with_binary_products C pr0 pr1
     proof
       show "\<And>a b. \<not> (ide a \<and> ide b) \<Longrightarrow> pr0 a b = null"
         using pr0_def by auto
       show "\<And>a b. \<not> (ide a \<and> ide b) \<Longrightarrow> pr1 a b = null"
         using pr1_def by auto
       fix a b
       assume a: "ide a" and b: "ide b"
       interpret J: binary_product_shape .
       interpret D: binary_product_diagram C a b
         using a b by unfold_locales auto
       let ?\<chi> = "D.mkCone (pr1 a b) (pr0 a b)"
       interpret \<chi>: limit_cone J.comp C D.map \<open>dom (pr1 a b)\<close> ?\<chi>
         using a b pr_yields_binary_product
         by (simp add: has_as_binary_product_def)
       have 1: "pr1 a b = ?\<chi> J.FF \<and> pr0 a b = ?\<chi> J.TT"
         using D.mkCone_def by simp
       show "span (pr1 a b) (pr0 a b)"
         using 1 \<chi>.preserves_reflects_arr J.seqE J.arr_char J.seq_char J.is_category
               D.is_rendered_commutative_by_cone \<chi>.cone_axioms
         by metis
       show "cod (pr1 a b) = a"
         using 1 \<chi>.preserves_cod [of J.FF] J.cod_char J.arr_char by auto
       show "cod (pr0 a b) = b"
         using 1 \<chi>.preserves_cod [of J.TT] J.cod_char J.arr_char by auto
       next
       fix f g
       assume fg: "span f g"
       show "\<exists>!l. pr1 (cod f) (cod g) \<cdot> l = f \<and> pr0 (cod f) (cod g) \<cdot> l = g"
       proof -
         interpret J: binary_product_shape .
         interpret D: binary_product_diagram C \<open>cod f\<close> \<open>cod g\<close>
           using fg by unfold_locales auto
         let ?\<chi> = "D.mkCone (pr1 (cod f) (cod g)) (pr0 (cod f) (cod g))"
         interpret \<chi>: limit_cone J.comp C D.map \<open>dom (pr1 (cod f) (cod g))\<close> ?\<chi>
           using fg pr_yields_binary_product [of "cod f" "cod g"] has_as_binary_product_def
           by simp
         interpret \<chi>: binary_product_cone C \<open>cod f\<close> \<open>cod g\<close>
                        \<open>pr1 (cod f) (cod g)\<close> \<open>pr0 (cod f) (cod g)\<close> ..
         have 1: "pr1 (cod f) (cod g) = ?\<chi> J.FF \<and> pr0 (cod f) (cod g) = ?\<chi> J.TT"
           using D.mkCone_def by simp
         show "\<exists>!l. pr1 (cod f) (cod g) \<cdot> l = f \<and> pr0 (cod f) (cod g) \<cdot> l = g"
         proof -
           have "\<exists>!l. \<guillemotleft>l : dom f \<rightarrow> dom (pr1 (cod f) (cod g))\<guillemotright> \<and>
                      pr1 (cod f) (cod g) \<cdot> l = f \<and> pr0 (cod f) (cod g) \<cdot> l = g"
             using fg \<chi>.is_universal' by simp
           moreover have "\<And>l. pr1 (cod f) (cod g) \<cdot> l = f
                                 \<Longrightarrow> \<guillemotleft>l : dom f \<rightarrow> dom (pr1 (cod f) (cod g))\<guillemotright>"
             using fg dom_comp in_homI seqE seqI by metis
           ultimately show ?thesis by auto
         qed
       qed
     qed
 
     proposition extends_to_elementary_category_with_binary_products:
     shows "elementary_category_with_binary_products C pr0 pr1"
       ..
 
   end
 
   context elementary_category_with_binary_products
   begin
 
     interpretation category_with_binary_products C
     proof
       show "has_binary_products"
       proof (unfold has_binary_products_def, intro allI impI)
         show "\<And>a b. ide a \<and> ide b \<Longrightarrow> \<exists>p0 p1. has_as_binary_product a b p0 p1"
         proof -
           fix a b
           assume ab: "ide a \<and> ide b"
           have "has_as_binary_product a b \<pp>\<^sub>1[a, b] \<pp>\<^sub>0[a, b]"
           proof
             show "ide a" and "ide b" and "\<guillemotleft>\<pp>\<^sub>1[a, b] : a \<otimes> b \<rightarrow> a\<guillemotright>" and "\<guillemotleft>\<pp>\<^sub>0[a, b] : a \<otimes> b \<rightarrow> b\<guillemotright>"
               using ab by auto
             show "\<And>x f g. \<lbrakk>\<guillemotleft>f : x \<rightarrow> a\<guillemotright>; \<guillemotleft>g : x \<rightarrow> b\<guillemotright>\<rbrakk>
                              \<Longrightarrow> \<exists>!h. \<guillemotleft>h : x \<rightarrow> a \<otimes> b\<guillemotright> \<and> \<pp>\<^sub>1[a, b] \<cdot> h = f \<and> \<pp>\<^sub>0[a, b] \<cdot> h = g"
             proof -
               fix x f g
               assume f: "\<guillemotleft>f : x \<rightarrow> a\<guillemotright>" and g: "\<guillemotleft>g : x \<rightarrow> b\<guillemotright>"
               show "\<exists>!h. \<guillemotleft>h : x \<rightarrow> a \<otimes> b\<guillemotright> \<and> \<pp>\<^sub>1[a, b] \<cdot> h = f \<and> \<pp>\<^sub>0[a, b] \<cdot> h = g"
                 using ab f g tuple_pr_arr pr_tuple [of f g a b] tuple_in_hom'
                 by (metis in_homE)
             qed
           qed
           thus "\<exists>p0 p1. has_as_binary_product a b p0 p1" by blast
         qed
       qed
     qed
 
     proposition is_category_with_binary_products:
     shows "category_with_binary_products C"
       ..
 
   end
 
   subsection "Further Properties"
 
   context elementary_category_with_binary_products
   begin
 
     lemma interchange:
     assumes "seq h f" and "seq k g"
     shows "(h \<otimes> k) \<cdot> (f \<otimes> g) = h \<cdot> f \<otimes> k \<cdot> g"
       using assms prod_def comp_tuple_arr comp_assoc by fastforce
 
     lemma pr_naturality [simp]:
     assumes "arr g" and "dom g = b" and "cod g = d"
         and "arr f" and "dom f = a" and "cod f = c"
     shows "\<pp>\<^sub>0[c, d] \<cdot> (f \<otimes> g) = g \<cdot> \<pp>\<^sub>0[a, b]"
     and "\<pp>\<^sub>1[c, d] \<cdot> (f \<otimes> g) = f \<cdot> \<pp>\<^sub>1[a, b]"
       using assms prod_def by fastforce+
 
     abbreviation dup ("\<d>[_]")
     where "\<d>[f] \<equiv> \<langle>f, f\<rangle>"
 
     lemma dup_in_hom [intro, simp]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
     shows "\<guillemotleft>\<d>[f] : a \<rightarrow> b \<otimes> b\<guillemotright>"
       using assms by fastforce
 
     lemma dup_simps [simp]:
     assumes "arr f"
     shows "arr \<d>[f]" and "dom \<d>[f] = dom f" and "cod \<d>[f] = cod f \<otimes> cod f"
       using assms dup_in_hom by auto
 
     lemma dup_naturality:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
     shows "\<d>[b] \<cdot> f = (f \<otimes> f) \<cdot> \<d>[a]"
       using assms prod_def comp_arr_dom comp_cod_arr comp_tuple_arr comp_assoc
       by fastforce
 
     lemma pr_dup [simp]:
     assumes "ide a"
     shows "\<pp>\<^sub>0[a, a] \<cdot> \<d>[a] = a" and "\<pp>\<^sub>1[a, a] \<cdot> \<d>[a] = a"
       using assms by simp_all
 
     lemma prod_tuple:
     assumes "span f g" and "seq h f" and "seq k g"
     shows "(h \<otimes> k) \<cdot> \<langle>f, g\<rangle> = \<langle>h \<cdot> f, k \<cdot> g\<rangle>"
       using assms prod_def comp_assoc comp_tuple_arr by fastforce
 
     lemma tuple_eqI:
     assumes "seq \<pp>\<^sub>0[b, c] f" and "seq \<pp>\<^sub>1[b, c] f"
     and "\<pp>\<^sub>0[b, c] \<cdot> f = f0" and "\<pp>\<^sub>1[b, c] \<cdot> f = f1"
     shows "f = \<langle>f1, f0\<rangle>"
       using assms pr_joint_monic [of b c "\<langle>f1, f0\<rangle>" f] pr_tuple by auto
 
     definition assoc ("\<a>[_, _, _]")
     where "\<a>[a, b, c] \<equiv> \<langle>\<pp>\<^sub>1[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c], \<langle>\<pp>\<^sub>0[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c], \<pp>\<^sub>0[a \<otimes> b, c]\<rangle>\<rangle>"
 
     definition assoc' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
     where "\<a>\<^sup>-\<^sup>1[a, b, c] \<equiv> \<langle>\<langle>\<pp>\<^sub>1[a, b \<otimes> c], \<pp>\<^sub>1[b, c] \<cdot> \<pp>\<^sub>0[a, b \<otimes> c]\<rangle>, \<pp>\<^sub>0[b, c] \<cdot> \<pp>\<^sub>0[a, b \<otimes> c]\<rangle>"
 
     lemma assoc_in_hom [intro]:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> (b \<otimes> c)\<guillemotright>"
       using assms assoc_def by auto
 
     lemma assoc_simps [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "arr \<a>[a, b, c]"
     and "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
     and "cod \<a>[a, b, c] = a \<otimes> (b \<otimes> c)"
       using assms assoc_in_hom by auto
 
     lemma assoc'_in_hom [intro]:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<guillemotleft>\<a>\<^sup>-\<^sup>1[a, b, c] : a \<otimes> (b \<otimes> c) \<rightarrow> (a \<otimes> b) \<otimes> c\<guillemotright>"
       using assms assoc'_def by auto
 
     lemma assoc'_simps [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "arr \<a>\<^sup>-\<^sup>1[a, b, c]"
     and "dom \<a>\<^sup>-\<^sup>1[a, b, c] = a \<otimes> (b \<otimes> c)"
     and "cod \<a>\<^sup>-\<^sup>1[a, b, c] = (a \<otimes> b) \<otimes> c"
       using assms assoc'_in_hom by auto
 
     lemma assoc_naturality:
     assumes "\<guillemotleft>f0 : a0 \<rightarrow> b0\<guillemotright>" and "\<guillemotleft>f1 : a1 \<rightarrow> b1\<guillemotright>" and "\<guillemotleft>f2 : a2 \<rightarrow> b2\<guillemotright>"
     shows "\<a>[b0, b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) = (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2]"
     proof -
       have "\<pp>\<^sub>0[b0, b1 \<otimes> b2] \<cdot> \<a>[b0, b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) =
             \<pp>\<^sub>0[b0, b1 \<otimes> b2] \<cdot> (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2]"
       proof -
         have "\<pp>\<^sub>0[b0, b1 \<otimes> b2] \<cdot> \<a>[b0, b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) =
               (\<pp>\<^sub>0[b0, b1 \<otimes> b2] \<cdot> \<a>[b0, b1, b2]) \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
           using comp_assoc by simp
         also have "... = \<langle>\<pp>\<^sub>0[b0, b1] \<cdot> \<pp>\<^sub>1[b0 \<otimes> b1, b2], \<pp>\<^sub>0[b0 \<otimes> b1, b2]\<rangle> \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
           using assms assoc_def by fastforce
         also have "... = \<langle>(\<pp>\<^sub>0[b0, b1] \<cdot> \<pp>\<^sub>1[b0 \<otimes> b1, b2]) \<cdot> ((f0 \<otimes> f1) \<otimes> f2),
                           \<pp>\<^sub>0[b0 \<otimes> b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)\<rangle>"
           using assms comp_tuple_arr by fastforce
         also have "... = \<langle>(\<pp>\<^sub>0[b0, b1] \<cdot> (f0 \<otimes> f1)) \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2], f2 \<cdot> \<pp>\<^sub>0[a0 \<otimes> a1, a2]\<rangle>"
           using assms comp_assoc by fastforce
         also have "... = \<langle>f1 \<cdot> \<pp>\<^sub>0[a0, a1] \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2], f2 \<cdot> \<pp>\<^sub>0[a0 \<otimes> a1, a2]\<rangle>"
           using assms comp_assoc
           by (metis in_homE pr_naturality(1))
         also have "... = \<pp>\<^sub>0[b0, b1 \<otimes> b2] \<cdot> (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2]"
           using assms comp_assoc assoc_def prod_tuple by fastforce
         finally show ?thesis by blast
       qed
       moreover have "\<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> \<a>[b0, b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) =
                      \<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2]"
       proof -
         have "\<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> \<a>[b0, b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) =
               (\<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> \<a>[b0, b1, b2]) \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
           using comp_assoc by simp
         also have "... = (\<pp>\<^sub>1[b0, b1] \<cdot> \<pp>\<^sub>1[b0 \<otimes> b1, b2]) \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
           using assms assoc_def by fastforce
         also have "... = (\<pp>\<^sub>1[b0, b1] \<cdot> (f0 \<otimes> f1)) \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2]"
           using assms comp_assoc by fastforce
         also have "... = f0 \<cdot> \<pp>\<^sub>1[a0, a1] \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2]"
           using assms comp_assoc
           by (metis in_homE pr_naturality(2))
         also have "... = \<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2]"
         proof -
           have "\<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2] =
                 (\<pp>\<^sub>1[b0, b1 \<otimes> b2] \<cdot> (f0 \<otimes> (f1 \<otimes> f2))) \<cdot> \<a>[a0, a1, a2]"
             using comp_assoc by simp
           also have "... = f0 \<cdot> \<pp>\<^sub>1[a0, a1 \<otimes> a2] \<cdot> \<a>[a0, a1, a2]"
             using assms comp_assoc by fastforce
           also have "... = f0 \<cdot> \<pp>\<^sub>1[a0, a1] \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2]"
             using assms assoc_def by fastforce
           finally show ?thesis by simp
         qed
         finally show ?thesis by blast
       qed
       ultimately show ?thesis
         using assms pr_joint_monic [of b0 "b1 \<otimes> b2" "\<a>[b0, b1, b2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
                                        "(f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[a0, a1, a2]"]
         by fastforce
     qed
 
     lemma pentagon:
     assumes "ide a" and "ide b" and "ide c" and "ide d"
     shows "((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d) = \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
     proof (intro pr_joint_monic
                    [where h = "((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d)"
                       and h' = "\<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"])
       show "seq \<pp>\<^sub>0[a, b \<otimes> (c \<otimes> d)] (((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d))"
         using assms by simp
       show "\<pp>\<^sub>1[a, b \<otimes> c \<otimes> d] \<cdot> ((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d) =
             \<pp>\<^sub>1[a, b \<otimes> c \<otimes> d] \<cdot> \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
       proof -
         have "\<pp>\<^sub>1[a, b \<otimes> c \<otimes> d] \<cdot> ((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d) =
               ((\<pp>\<^sub>1[a, b \<otimes> c \<otimes> d] \<cdot> (a \<otimes> \<a>[b, c, d])) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d)"
           using comp_assoc by simp
         also have "... = (\<pp>\<^sub>1[a, (b \<otimes> c) \<otimes> d] \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d)"
           using assms pr_naturality(2) comp_cod_arr by force
         also have "... = \<pp>\<^sub>1[a, b \<otimes> c] \<cdot> \<pp>\<^sub>1[a \<otimes> b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)"
           using assms assoc_def comp_assoc by simp
         also have "... = (\<pp>\<^sub>1[a, b \<otimes> c] \<cdot> \<a>[a, b, c]) \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d]"
           using assms pr_naturality(2) comp_assoc by fastforce
         also have "... = \<pp>\<^sub>1[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c] \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d]"
           using assms assoc_def comp_assoc by simp
         finally have "\<pp>\<^sub>1[a, b \<otimes> c \<otimes> d] \<cdot> ((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d) =
                       \<pp>\<^sub>1[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c] \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d]"
           by blast
         also have "... = \<pp>\<^sub>1[a, b \<otimes> c \<otimes> d] \<cdot> \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
           using assms assoc_def comp_assoc by auto
         finally show ?thesis by blast
       qed
       show "\<pp>\<^sub>0[a, b \<otimes> (c \<otimes> d)] \<cdot> ((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d) =
             \<pp>\<^sub>0[a, b \<otimes> (c \<otimes> d)] \<cdot> \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
       proof -
         have "\<pp>\<^sub>0[a, b \<otimes> (c \<otimes> d)] \<cdot> ((a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d]) \<cdot> (\<a>[a, b, c] \<otimes> d) =
               \<pp>\<^sub>0[a, b \<otimes> c \<otimes> d] \<cdot>
                 ((a \<otimes> \<langle>\<pp>\<^sub>1[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<langle>\<pp>\<^sub>0[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<pp>\<^sub>0[b \<otimes> c, d]\<rangle>\<rangle>) \<cdot>
                  \<langle>\<pp>\<^sub>1[a, b \<otimes> c] \<cdot> \<pp>\<^sub>1[a \<otimes> b \<otimes> c, d],
                   \<langle>\<pp>\<^sub>0[a, b \<otimes> c] \<cdot> \<pp>\<^sub>1[a \<otimes> b \<otimes> c, d], \<pp>\<^sub>0[a \<otimes> b \<otimes> c, d]\<rangle>\<rangle>) \<cdot>
                 (\<langle>\<pp>\<^sub>1[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c], \<langle>\<pp>\<^sub>0[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c], \<pp>\<^sub>0[a \<otimes> b, c]\<rangle>\<rangle> \<otimes> d)"
           using assms assoc_def by simp
         also have "... = \<langle>\<pp>\<^sub>1[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d],
                           \<langle>\<pp>\<^sub>0[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<pp>\<^sub>0[b \<otimes> c, d]\<rangle>\<rangle> \<cdot> (\<pp>\<^sub>0[a, (b \<otimes> c) \<otimes> d] \<cdot>
                             \<langle>\<pp>\<^sub>1[a, b \<otimes> c] \<cdot> \<pp>\<^sub>1[a \<otimes> b \<otimes> c, d],
                              \<langle>\<pp>\<^sub>0[a, b \<otimes> c] \<cdot> \<pp>\<^sub>1[a \<otimes> b \<otimes> c, d], \<pp>\<^sub>0[a \<otimes> b \<otimes> c, d]\<rangle>\<rangle>) \<cdot>
                             (\<langle>\<pp>\<^sub>1[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c],
                               \<langle>\<pp>\<^sub>0[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c], \<pp>\<^sub>0[a \<otimes> b, c]\<rangle>\<rangle> \<otimes> d)"
         proof -
           have "\<pp>\<^sub>0[a, b \<otimes> c \<otimes> d] \<cdot>
                   (a \<otimes> \<langle>\<pp>\<^sub>1[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<langle>\<pp>\<^sub>0[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<pp>\<^sub>0[b \<otimes> c, d]\<rangle>\<rangle>) =
                 \<langle>\<pp>\<^sub>1[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<langle>\<pp>\<^sub>0[b, c] \<cdot> \<pp>\<^sub>1[b \<otimes> c, d], \<pp>\<^sub>0[b \<otimes> c, d]\<rangle>\<rangle> \<cdot>
                   \<pp>\<^sub>0[a, (b \<otimes> c) \<otimes> d]"
             using assms assoc_def ide_in_hom pr_naturality(1) by auto
           thus ?thesis using comp_assoc by metis
         qed
         also have "... = \<langle>\<pp>\<^sub>0[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c] \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d],
                           \<langle>\<pp>\<^sub>0[a \<otimes> b, c] \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d], d \<cdot> \<pp>\<^sub>0[(a \<otimes> b) \<otimes> c, d]\<rangle>\<rangle>"
           using assms comp_assoc by simp
         also have "... = \<langle>\<pp>\<^sub>0[a, b] \<cdot> \<pp>\<^sub>1[a \<otimes> b, c] \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d],
                           \<langle>\<pp>\<^sub>0[a \<otimes> b, c] \<cdot> \<pp>\<^sub>1[(a \<otimes> b) \<otimes> c, d], \<pp>\<^sub>0[(a \<otimes> b) \<otimes> c, d]\<rangle>\<rangle>"
           using assms comp_cod_arr by simp
         also have "... = \<pp>\<^sub>0[a, b \<otimes> (c \<otimes> d)] \<cdot> \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
           using assms assoc_def comp_assoc by simp
         finally show ?thesis by simp
       qed
     qed
 
     lemma inverse_arrows_assoc:
     assumes "ide a" and "ide b" and "ide c"
     shows "inverse_arrows \<a>[a, b, c] \<a>\<^sup>-\<^sup>1[a, b, c]"
       using assms assoc_def assoc'_def comp_assoc
       by (auto simp add: tuple_pr_arr)
 
     interpretation CC: product_category C C ..
 
     abbreviation Prod
     where "Prod fg \<equiv> fst fg \<otimes> snd fg"
     abbreviation Prod'
     where "Prod' fg \<equiv> snd fg \<otimes> fst fg"
 
     interpretation \<Pi>: binary_functor C C C Prod
       using tuple_ext CC.comp_char interchange
       apply unfold_locales
           apply auto
       by (metis prod_def seqE)+
 
     interpretation Prod': binary_functor C C C Prod'
       using tuple_ext CC.comp_char interchange
       apply unfold_locales
           apply auto
       by (metis prod_def seqE)+
 
     lemma binary_functor_Prod:
     shows "binary_functor C C C Prod" and "binary_functor C C C Prod'"
       ..
 
     definition sym ("\<s>[_, _]")
     where "\<s>[a1, a0] \<equiv> if ide a0 \<and> ide a1 then \<langle>\<pp>\<^sub>0[a1, a0], \<pp>\<^sub>1[a1, a0]\<rangle> else null"
 
     lemma sym_in_hom [intro]:
     assumes "ide a" and "ide b"
     shows "\<guillemotleft>\<s>[a, b] : a \<otimes> b \<rightarrow> b \<otimes> a\<guillemotright>"
       using assms sym_def by auto
 
     lemma sym_simps [simp]:
     assumes "ide a" and "ide b"
     shows "arr \<s>[a, b]" and "dom \<s>[a, b] = a \<otimes> b" and "cod \<s>[a, b] = b \<otimes> a"
       using assms sym_in_hom by auto
 
     lemma comp_sym_tuple [simp]:
     assumes "\<guillemotleft>f0 : a \<rightarrow> b0\<guillemotright>" and "\<guillemotleft>f1 : a \<rightarrow> b1\<guillemotright>"
     shows "\<s>[b0, b1] \<cdot> \<langle>f0, f1\<rangle> = \<langle>f1, f0\<rangle>"
       using assms sym_def comp_tuple_arr by fastforce
 
     lemma prj_sym [simp]:
     assumes "ide a0" and "ide a1"
     shows "\<pp>\<^sub>0[a1, a0] \<cdot> \<s>[a0, a1] = \<pp>\<^sub>1[a0, a1]"
     and "\<pp>\<^sub>1[a1, a0] \<cdot> \<s>[a0, a1] = \<pp>\<^sub>0[a0, a1]"
       using assms sym_def by auto
 
     lemma comp_sym_sym [simp]:
     assumes "ide a0" and "ide a1"
     shows "\<s>[a1, a0] \<cdot> \<s>[a0, a1] = (a0 \<otimes> a1)"
       using assms sym_def comp_tuple_arr by auto
 
     lemma sym_inverse_arrows:
     assumes "ide a0" and "ide a1"
     shows "inverse_arrows \<s>[a0, a1] \<s>[a1, a0]"
       using assms sym_in_hom comp_sym_sym by auto
 
     lemma sym_assoc_coherence:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<a>[b, c, a] \<cdot> \<s>[a, b \<otimes> c] \<cdot> \<a>[a, b, c] = (b \<otimes> \<s>[a, c]) \<cdot> \<a>[b, a, c] \<cdot> (\<s>[a, b] \<otimes> c)"
       using assms sym_def assoc_def comp_assoc prod_tuple comp_cod_arr by simp
 
     lemma sym_naturality:
     assumes "\<guillemotleft>f0 : a0 \<rightarrow> b0\<guillemotright>" and "\<guillemotleft>f1 : a1 \<rightarrow> b1\<guillemotright>"
     shows "\<s>[b0, b1] \<cdot> (f0 \<otimes> f1) = (f1 \<otimes> f0) \<cdot> \<s>[a0, a1]"
       using assms sym_def comp_assoc prod_tuple by fastforce
 
     abbreviation \<sigma>
     where "\<sigma> fg \<equiv> \<s>[cod (fst fg), cod (snd fg)] \<cdot> (fst fg \<otimes> snd fg)"
 
     interpretation \<sigma>: natural_transformation CC.comp C Prod Prod' \<sigma>
       using sym_def CC.arr_char CC.null_char comp_arr_dom comp_cod_arr
       apply unfold_locales
           apply auto
       using arr_cod_iff_arr ideD(1)
         apply metis
       using arr_cod_iff_arr ideD(1)
        apply metis
       using prod_tuple by simp
 
     lemma \<sigma>_is_natural_transformation:
     shows "natural_transformation CC.comp C Prod Prod' \<sigma>"
       ..
 
     abbreviation Diag
     where "Diag f \<equiv> if arr f then (f, f) else CC.null"
 
     interpretation \<Delta>: "functor" C CC.comp Diag
       by (unfold_locales, auto)
 
     lemma functor_Diag:
     shows "functor C CC.comp Diag"
       ..
 
     interpretation \<Delta>o\<Pi>: composite_functor CC.comp C CC.comp Prod Diag ..
     interpretation \<Pi>o\<Delta>: composite_functor C CC.comp C Diag Prod ..
 
     abbreviation \<pi>
     where "\<pi> \<equiv> \<lambda>(f, g). (\<pp>\<^sub>1[cod f, cod g] \<cdot> (f \<otimes> g), \<pp>\<^sub>0[cod f, cod g] \<cdot> (f \<otimes> g))"
 
     interpretation \<pi>: transformation_by_components CC.comp CC.comp \<Delta>o\<Pi>.map CC.map \<pi>
       using pr_naturality comp_arr_dom comp_cod_arr
       by unfold_locales auto
 
     lemma \<pi>_is_natural_transformation:
     shows "natural_transformation CC.comp CC.comp \<Delta>o\<Pi>.map CC.map \<pi>"
     proof -
       have "\<pi>.map = \<pi>"
         using \<pi>.map_def ext \<Pi>.is_extensional comp_arr_dom comp_cod_arr by auto
       thus "natural_transformation CC.comp CC.comp \<Delta>o\<Pi>.map CC.map \<pi>"
         using \<pi>.natural_transformation_axioms by simp
     qed
 
     interpretation \<delta>: natural_transformation C C map \<Pi>o\<Delta>.map dup
       using dup_naturality comp_arr_dom comp_cod_arr prod_tuple tuple_ext
       by unfold_locales auto
 
     lemma dup_is_natural_transformation:
     shows "natural_transformation C C map \<Pi>o\<Delta>.map dup"
       ..
 
     interpretation \<Delta>o\<Pi>o\<Delta>: composite_functor C CC.comp CC.comp Diag \<Delta>o\<Pi>.map ..
     interpretation \<Pi>o\<Delta>o\<Pi>: composite_functor CC.comp C C Prod \<Pi>o\<Delta>.map ..
 
     interpretation \<Delta>o\<delta>: natural_transformation C CC.comp Diag \<Delta>o\<Pi>o\<Delta>.map \<open>Diag \<circ> dup\<close>
     proof -
       have "Diag \<circ> map = Diag"
         by auto
       thus "natural_transformation C CC.comp Diag \<Delta>o\<Pi>o\<Delta>.map (Diag \<circ> dup)"
         using \<Delta>.as_nat_trans.natural_transformation_axioms \<delta>.natural_transformation_axioms
               o_assoc horizontal_composite [of C C map \<Pi>o\<Delta>.map dup CC.comp Diag Diag Diag]
         by metis
     qed
 
     interpretation \<delta>o\<Pi>: natural_transformation CC.comp C Prod \<Pi>o\<Delta>o\<Pi>.map \<open>dup \<circ> Prod\<close>
       using \<delta>.natural_transformation_axioms \<Pi>.as_nat_trans.natural_transformation_axioms
             o_assoc horizontal_composite [of CC.comp C Prod Prod Prod C map \<Pi>o\<Delta>.map dup]
       by simp
 
     interpretation \<pi>o\<Delta>: natural_transformation C CC.comp \<Delta>o\<Pi>o\<Delta>.map Diag \<open>\<pi>.map \<circ> Diag\<close>
       using \<pi>.natural_transformation_axioms \<Delta>.as_nat_trans.natural_transformation_axioms
             horizontal_composite
               [of C CC.comp Diag Diag Diag CC.comp \<Delta>o\<Pi>.map CC.map \<pi>.map]
       by simp
 
     interpretation \<Pi>o\<pi>: natural_transformation CC.comp C \<Pi>o\<Delta>o\<Pi>.map Prod \<open>Prod \<circ> \<pi>.map\<close>
     proof -
       have "Prod \<circ> \<Delta>o\<Pi>.map = \<Pi>o\<Delta>o\<Pi>.map"
         by auto
       thus "natural_transformation CC.comp C \<Pi>o\<Delta>o\<Pi>.map Prod (Prod \<circ> \<pi>.map)"
         using \<pi>.natural_transformation_axioms \<Pi>.as_nat_trans.natural_transformation_axioms
               o_assoc
               horizontal_composite
                 [of CC.comp CC.comp \<Delta>o\<Pi>.map CC.map \<pi>.map C Prod Prod Prod]
         by simp
     qed
 
     interpretation \<Delta>o\<delta>_\<pi>o\<Delta>: vertical_composite C CC.comp Diag \<Delta>o\<Pi>o\<Delta>.map Diag
                                \<open>Diag \<circ> dup\<close> \<open>\<pi>.map \<circ> Diag\<close>
       ..
     interpretation \<Pi>o\<pi>_\<delta>o\<Pi>: vertical_composite CC.comp C Prod \<Pi>o\<Delta>o\<Pi>.map Prod
                                \<open>dup \<circ> Prod\<close> \<open>Prod \<circ> \<pi>.map\<close>
       ..
 
     interpretation \<Delta>\<Pi>: unit_counit_adjunction CC.comp C Diag Prod dup \<pi>.map
     proof
       show "\<Delta>o\<delta>_\<pi>o\<Delta>.map = Diag"
       proof
         fix f
         have "\<not> arr f \<Longrightarrow> \<Delta>o\<delta>_\<pi>o\<Delta>.map f = Diag f"
           by (simp add: \<Delta>o\<delta>_\<pi>o\<Delta>.is_extensional)
         moreover have "arr f \<Longrightarrow> \<Delta>o\<delta>_\<pi>o\<Delta>.map f = Diag f"
           using comp_cod_arr comp_assoc \<Delta>o\<delta>_\<pi>o\<Delta>.map_def by auto
         ultimately show "\<Delta>o\<delta>_\<pi>o\<Delta>.map f = Diag f" by blast
       qed
       show "\<Pi>o\<pi>_\<delta>o\<Pi>.map = Prod"
       proof
         fix fg
         show "\<Pi>o\<pi>_\<delta>o\<Pi>.map fg = Prod fg"
         proof -
           have "\<not> CC.arr fg \<Longrightarrow> ?thesis"
             by (simp add: \<Pi>.is_extensional \<Pi>o\<pi>_\<delta>o\<Pi>.is_extensional)
           moreover have "CC.arr fg \<Longrightarrow> ?thesis"
           proof -
             assume fg: "CC.arr fg"
             have 1: "dup (Prod fg) = \<langle>cod (fst fg) \<otimes> cod (snd fg), cod (fst fg) \<otimes> cod (snd fg)\<rangle> \<cdot>
                                         (fst fg \<otimes> snd fg)"
               using fg \<delta>.is_natural_2
               apply simp
               by (metis (no_types, lifting) prod_simps(1) prod_simps(3))
             have "\<Pi>o\<pi>_\<delta>o\<Pi>.map fg =
                   (\<pp>\<^sub>1[cod (fst fg), cod (snd fg)] \<otimes> \<pp>\<^sub>0[cod (fst fg), cod (snd fg)]) \<cdot>
                     \<langle>cod (fst fg) \<otimes> cod (snd fg), cod (fst fg) \<otimes> cod (snd fg)\<rangle> \<cdot>
                     (fst fg \<otimes> snd fg)"
               using fg 1 \<Pi>o\<pi>_\<delta>o\<Pi>.map_def comp_cod_arr by simp
             also have "... = ((\<pp>\<^sub>1[cod (fst fg), cod (snd fg)] \<otimes> \<pp>\<^sub>0[cod (fst fg), cod (snd fg)]) \<cdot>
                               \<langle>cod (fst fg) \<otimes> cod (snd fg), cod (fst fg) \<otimes> cod (snd fg)\<rangle>) \<cdot>
                              (fst fg \<otimes> snd fg)"
               using comp_assoc by simp
             also have "... = \<langle>\<pp>\<^sub>1[cod (fst fg), cod (snd fg)] \<cdot> (cod (fst fg) \<otimes> cod (snd fg)),
                               \<pp>\<^sub>0[cod (fst fg), cod (snd fg)] \<cdot> (cod (fst fg) \<otimes> cod (snd fg))\<rangle> \<cdot>
                              (fst fg \<otimes> snd fg)"
               using fg prod_tuple by simp
             also have "... = Prod fg"
               using fg comp_arr_dom \<Pi>.as_nat_trans.is_natural_2 by auto
             finally show ?thesis by simp
           qed
           ultimately show ?thesis by blast
         qed
       qed
     qed
 
     proposition induces_unit_counit_adjunction:
     shows "unit_counit_adjunction CC.comp C Diag Prod dup \<pi>.map"
       using \<Delta>\<Pi>.unit_counit_adjunction_axioms by simp
 
   end
 
   section "Category with Terminal Object"
 
   locale category_with_terminal_object =
     category +
   assumes has_terminal: "\<exists>t. terminal t"
 
   locale elementary_category_with_terminal_object =
     category C
   for C :: "'a comp"                              (infixr "\<cdot>" 55)
   and one :: "'a"                                 ("\<one>")
   and trm :: "'a \<Rightarrow> 'a"                           ("\<t>[_]") +
   assumes ide_one: "ide \<one>"
   and trm_in_hom: "ide a \<Longrightarrow> \<guillemotleft>\<t>[a] : a \<rightarrow> \<one>\<guillemotright>"
   and trm_eqI: "\<lbrakk> ide a; \<guillemotleft>f : a \<rightarrow> \<one>\<guillemotright> \<rbrakk> \<Longrightarrow> f = \<t>[a]"
   begin
 
     lemma trm_simps:
     assumes "ide a"
     shows "arr \<t>[a]" and "dom \<t>[a] = a" and "cod \<t>[a] = \<one>"
       using assms trm_in_hom by auto
 
     lemma trm_one:
     shows "\<t>[\<one>] = \<one>"
     using ide_one trm_in_hom trm_eqI ide_in_hom by auto
 
     lemma terminal_one:
     shows "terminal \<one>"
       using ide_one trm_in_hom trm_eqI terminal_def by metis
 
     lemma trm_naturality:
     assumes "arr f"
     shows "\<t>[cod f] \<cdot> f = \<t>[dom f]"
       using assms trm_eqI
       by (metis comp_in_homI' ide_cod ide_dom in_homE trm_in_hom)
 
     proposition is_category_with_terminal_object:
     shows "category_with_terminal_object C"
       apply unfold_locales
       using terminal_one by auto
 
   end
 
   context category_with_terminal_object
   begin
 
     definition some_terminal ("\<one>")
     where "some_terminal \<equiv> SOME t. terminal t"
 
     definition "trm" ("\<t>[_]")
     where "\<t>[f] \<equiv> if arr f then THE t. \<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright> else null"
 
     lemma terminal_some_terminal [intro]:
     shows "terminal \<one>"
       using some_terminal_def has_terminal someI_ex [of "\<lambda>t. terminal t"] by presburger
 
     lemma ide_some_terminal:
     shows "ide \<one>"
       using terminal_def by blast
 
     lemma trm_in_hom [intro]:
     assumes "arr f"
     shows "\<guillemotleft>\<t>[f] : dom f \<rightarrow> \<one>\<guillemotright>"
     proof -
       have "ide (dom f)" using assms by fastforce
       hence "\<exists>!t. \<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright>"
         using assms trm_def terminal_def terminal_some_terminal by simp
       thus ?thesis
         using assms trm_def [of f] theI' [of "\<lambda>t. \<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright>"] by auto
     qed
 
     lemma trm_simps [simp]:
     assumes "arr f"
     shows "arr \<t>[f]" and "dom \<t>[f] = dom f" and "cod \<t>[f] = \<one>"
       using assms trm_in_hom by auto
 
     lemma trm_eqI:
     assumes "\<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright>"
     shows "t = \<t>[f]"
     proof -
       have "ide (dom f)" using assms
         by (metis ide_dom in_homE)
       hence "\<exists>!t. \<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright>"
         using terminal_def [of \<one>] terminal_some_terminal by auto
       moreover have "\<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright>"
         using assms by simp
       ultimately show ?thesis
         using assms trm_def the1_equality [of "\<lambda>t. \<guillemotleft>t : dom f \<rightarrow> \<one>\<guillemotright>" t]
               \<open>ide (dom f)\<close> arr_dom_iff_arr
         by fastforce
     qed
 
     sublocale elementary_category_with_terminal_object C \<one> trm
       using ide_some_terminal trm_eqI
       by unfold_locales auto
 
     proposition extends_to_elementary_category_with_terminal_object:
       shows "elementary_category_with_terminal_object C \<one> trm"
       ..
 
   end
 
   section "Cartesian Category"
 
   locale cartesian_category =
     category_with_binary_products +
     category_with_terminal_object
 
   locale category_with_pullbacks_and_terminal_object =
     category_with_pullbacks +
     category_with_terminal_object
   begin
 
     sublocale category_with_binary_products C
     proof
       show "has_binary_products"
       proof -
         have "\<And>a0 a1. \<lbrakk>ide a0; ide a1\<rbrakk> \<Longrightarrow> \<exists>p0 p1. has_as_binary_product a0 a1 p0 p1"
         proof -
           fix a0 a1
           assume a0: "ide a0" and a1: "ide a1"
           obtain p0 p1 where p0p1: "has_as_pullback \<t>[a0] \<t>[a1] p0 p1"
             using a0 a1 has_pullbacks has_pullbacks_def by force
           have "has_as_binary_product a0 a1 p0 p1"
             using a0 a1 p0p1
             apply (elim has_as_pullbackE, intro has_as_binary_productI)
                 apply blast
                apply blast
               apply fastforce
              apply fastforce
           proof -
             fix x f g
             assume f: "\<guillemotleft>f : x \<rightarrow> a0\<guillemotright>" and g: "\<guillemotleft>g : x \<rightarrow> a1\<guillemotright>"
             assume "\<And>h k. commutative_square \<t>[a0] \<t>[a1] h k \<Longrightarrow> \<exists>!l. p0 \<cdot> l = h \<and> p1 \<cdot> l = k"
             moreover have "commutative_square \<t>[a0] \<t>[a1] f g"
               using f g
               by (metis a0 commutative_squareI in_homE
                         elementary_category_with_terminal_object.trm_simps(2)
                         extends_to_elementary_category_with_terminal_object
                         has_as_pullbackE p0p1 trm_naturality)
             moreover have "\<And>l. p0 \<cdot> l = f \<and> p1 \<cdot> l = g \<Longrightarrow> \<guillemotleft>l : x \<rightarrow> dom p1\<guillemotright>"
               using f g by blast
             ultimately show "\<exists>!l. \<guillemotleft>l : x \<rightarrow> dom p1\<guillemotright> \<and> p0 \<cdot> l = f \<and> p1 \<cdot> l = g"
               by metis
           qed
           thus "\<exists>p0 p1. has_as_binary_product a0 a1 p0 p1"
             by auto
         qed
         thus ?thesis
           using has_binary_products_def by force
       qed
     qed
 
     sublocale cartesian_category C ..
 
   end
 
   locale elementary_cartesian_category =
     elementary_category_with_binary_products +
     elementary_category_with_terminal_object
   begin
 
     proposition is_cartesian_category:
     shows "cartesian_category C"
       using cartesian_category.intro is_category_with_binary_products
             is_category_with_terminal_object
       by auto
 
   end
 
   context cartesian_category
   begin
 
     proposition extends_to_elementary_cartesian_category:
     shows "elementary_cartesian_category C pr0 pr1 \<one> trm"
       by (simp add: elementary_cartesian_category_def
           elementary_category_with_terminal_object_axioms
           extends_to_elementary_category_with_binary_products)
 
     sublocale elementary_cartesian_category C pr0 pr1 \<one> trm
       using extends_to_elementary_cartesian_category by simp
 
   end
 
   text \<open>
     Here we prove some facts that will later allow us to show that an elementary cartesian
     category is a monoidal category.
   \<close>
 
   context elementary_cartesian_category
   begin
 
     abbreviation \<iota>
     where "\<iota> \<equiv> \<pp>\<^sub>0[\<one>, \<one>]"
 
     lemma pr_coincidence:
     shows "\<iota> = \<pp>\<^sub>1[\<one>, \<one>]"
       using ide_one
       by (simp add: terminal_arr_unique terminal_one)
 
     lemma \<iota>_is_terminal_arr:
     shows "terminal_arr \<iota>"
       using ide_one
       by (simp add: terminal_one)
 
     lemma inverse_arrows_\<iota>:
     shows "inverse_arrows \<iota> \<langle>\<one>, \<one>\<rangle>"
       using ide_one
       by (metis (no_types, lifting) dup_is_natural_transformation \<iota>_is_terminal_arr cod_pr0
           comp_cod_arr pr_dup(1) ide_dom inverse_arrows_def map_simp
           natural_transformation.is_natural_2 pr_simps(2) pr1_in_hom' trm_eqI trm_naturality
           trm_one tuple_pr)
 
     lemma \<iota>_is_iso:
     shows "iso \<iota>"
       using inverse_arrows_\<iota> by auto
 
     lemma trm_tensor:
     assumes "ide a" and "ide b"
     shows "\<t>[a \<otimes> b] = \<iota> \<cdot> (\<t>[a] \<otimes> \<t>[b])"
     proof -
       have "\<t>[a \<otimes> b] = \<t>[a] \<cdot> \<pp>\<^sub>1[a, b]"
         by (metis assms(1-2) cod_pr1 pr_simps(4-6) trm_naturality)
       moreover have "\<guillemotleft>\<t>[b] : b \<rightarrow> \<one>\<guillemotright>"
         using assms(2) trm_in_hom by blast
       ultimately show ?thesis
         using assms(1) pr_coincidence trm_in_hom by fastforce
     qed
 
     abbreviation runit ("\<r>[_]")
     where "\<r>[a] \<equiv> \<pp>\<^sub>1[a, \<one>]"
 
     abbreviation runit' ("\<r>\<^sup>-\<^sup>1[_]")
     where "\<r>\<^sup>-\<^sup>1[a] \<equiv> \<langle>a, \<t>[a]\<rangle>"
 
     abbreviation lunit ("\<l>[_]")
     where "\<l>[a] \<equiv> \<pp>\<^sub>0[\<one>, a]"
 
     abbreviation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
     where "\<l>\<^sup>-\<^sup>1[a] \<equiv> \<langle>\<t>[a], a\<rangle>"
 
     lemma runit_in_hom:
     assumes "ide a"
     shows "\<guillemotleft>\<r>[a] : a \<otimes> \<one> \<rightarrow> a\<guillemotright>"
      using assms ide_one by simp
 
     lemma runit'_in_hom:
     assumes "ide a"
     shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[a] : a \<rightarrow> a \<otimes> \<one>\<guillemotright>"
       using assms ide_in_hom trm_in_hom by blast
 
     lemma lunit_in_hom:
     assumes "ide a"
     shows "\<guillemotleft>\<l>[a] : \<one> \<otimes> a \<rightarrow> a\<guillemotright>"
      using assms ide_one by simp
 
     lemma lunit'_in_hom:
     assumes "ide a"
     shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[a] : a \<rightarrow> \<one> \<otimes> a\<guillemotright>"
       using assms ide_in_hom trm_in_hom by blast
 
     lemma runit_naturality:
     assumes "ide a"
     shows "\<r>[cod a] \<cdot> (a \<otimes> \<one>) = a \<cdot> \<r>[dom a]"
       using assms pr_naturality(2) ide_char ide_one by blast
 
     lemma inverse_arrows_runit:
     assumes "ide a"
     shows "inverse_arrows \<r>[a] \<r>\<^sup>-\<^sup>1[a]"
     proof
       show "ide (\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a])"
       proof -
         have "\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a] = a"
           using assms
           by (metis in_homE ide_char pr_tuple(1) trm_in_hom)
         thus ?thesis
           using assms by presburger
       qed
       show "ide (\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a])"
       proof -
         have "ide (a \<otimes> \<one>)"
           using assms ide_one by blast
         moreover have "\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = a \<otimes> \<one>"
         proof (intro pr_joint_monic [of a \<one> "\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a]" "a \<otimes> \<one>"])
           show "seq \<pp>\<^sub>0[a, \<one>] (\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a])"
             using assms ide_one runit'_in_hom [of a]
             by (intro seqI) auto
           show "\<pp>\<^sub>0[a, \<one>] \<cdot> \<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = \<pp>\<^sub>0[a, \<one>] \<cdot> (a \<otimes> \<one>)"
           proof -
             have "\<pp>\<^sub>0[a, \<one>] \<cdot> \<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = (\<pp>\<^sub>0[a, \<one>] \<cdot> \<r>\<^sup>-\<^sup>1[a]) \<cdot> \<r>[a]"
               using comp_assoc by simp
             also have "... = \<t>[a] \<cdot> \<r>[a]"
               using assms ide_one
               by (metis in_homE pr_tuple(2) ide_char trm_in_hom)
             also have "... = \<t>[a \<otimes> \<one>]"
               using assms ide_one trm_naturality [of "\<r>[a]"] by simp
             also have "... = \<pp>\<^sub>0[a, \<one>] \<cdot> (a \<otimes> \<one>)"
               using assms comp_arr_dom ide_one trm_naturality trm_one by fastforce
             finally show ?thesis by blast
           qed
           show "\<pp>\<^sub>1[a, \<one>] \<cdot> \<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = \<pp>\<^sub>1[a, \<one>] \<cdot> (a \<otimes> \<one>)"
             using assms
             by (metis \<open>ide (\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a])\<close> cod_comp cod_pr1 dom_comp ide_compE ide_one
                 comp_assoc runit_naturality)
         qed
         ultimately show ?thesis by simp
       qed
     qed
 
     lemma lunit_naturality:
     assumes "arr f"
     shows "C \<l>[cod f] (\<one> \<otimes> f) = C f \<l>[dom f]"
       using assms pr_naturality(1) ide_char ide_one by blast
 
     lemma inverse_arrows_lunit:
     assumes "ide a"
     shows "inverse_arrows \<l>[a] \<l>\<^sup>-\<^sup>1[a]"
     proof
       show "ide (C \<l>[a] \<l>\<^sup>-\<^sup>1[a])"
       proof -
         have "C \<l>[a] \<l>\<^sup>-\<^sup>1[a] = a"
           using assms
           by (metis ide_char in_homE pr_tuple(2) trm_in_hom)
         thus ?thesis
           using assms by simp
       qed
       show "ide (\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a])"
       proof -
         have "\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<one> \<otimes> a"
         proof (intro pr_joint_monic [of \<one> a "\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a]" "\<one> \<otimes> a"])
           show "seq \<l>[a] (\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a])"
             using assms \<open>ide (\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a])\<close> by blast
           show "\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<l>[a] \<cdot> (\<one> \<otimes> a)"
             using assms
             by (metis \<open>ide (\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a])\<close> cod_comp cod_pr0 dom_cod ide_compE ide_one
                 comp_assoc lunit_naturality)
           show "\<pp>\<^sub>1[\<one>, a] \<cdot> \<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<pp>\<^sub>1[\<one>, a] \<cdot> (\<one> \<otimes> a)"
           proof -
             have "\<pp>\<^sub>1[\<one>, a] \<cdot> \<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = (\<pp>\<^sub>1[\<one>, a] \<cdot> \<l>\<^sup>-\<^sup>1[a]) \<cdot> \<l>[a]"
               using comp_assoc by simp
             also have "... = \<t>[a] \<cdot> \<l>[a]"
               using assms ide_one
               by (metis pr_tuple(1) ide_char in_homE trm_in_hom)
             also have "... = \<t>[\<one> \<otimes> a]"
               using assms ide_one trm_naturality [of "\<l>[a]"] by simp
             also have "... = \<pp>\<^sub>1[\<one>, a] \<cdot> (\<one> \<otimes> a)"
               using assms comp_arr_dom ide_one trm_naturality trm_one by fastforce
             finally show ?thesis by simp
           qed
         qed
         moreover have "ide (\<one> \<otimes> a)"
           using assms ide_one by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma comp_lunit_term_dup:
     assumes "ide a"
     shows "\<l>[a] \<cdot> (\<t>[a] \<otimes> a) \<cdot> \<d>[a] = a"
     proof -
       have "\<guillemotleft>\<t>[a] : a \<rightarrow> \<one>\<guillemotright>"
         using assms trm_in_hom by blast
       hence "\<l>[a] \<cdot> (\<t>[a] \<otimes> a) = a \<cdot> \<pp>\<^sub>0[a, a]"
         by (metis assms pr_naturality(1) ide_char in_homE)
       thus ?thesis
         by (metis (no_types) assms comp_assoc comp_ide_self pr_dup(1))
     qed
 
     lemma comp_runit_term_dup:
     assumes "ide a"
     shows "\<r>[a] \<cdot> (a \<otimes> \<t>[a]) \<cdot> \<d>[a] = a"
     proof -
       have "\<guillemotleft>\<t>[a] : a \<rightarrow> \<one>\<guillemotright>"
         using assms trm_in_hom by blast
       hence "\<r>[a] \<cdot> (a \<otimes> \<t>[a]) = a \<cdot> \<pp>\<^sub>1[a, a]"
         using assms by auto
       thus ?thesis
         using assms
         by (metis comp_ide_arr pr_dup(2) ide_char comp_assoc seqI)
     qed
 
     lemma comp_proj_assoc:
     assumes "ide a0" and "ide a1" and "ide a2"
     shows "\<pp>\<^sub>1[a0, a1 \<otimes> a2] \<cdot> \<a>[a0, a1, a2] = \<pp>\<^sub>1[a0, a1] \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2]"
     and "\<pp>\<^sub>0[a0, a1 \<otimes> a2] \<cdot> \<a>[a0, a1, a2] = \<langle>\<pp>\<^sub>0[a0, a1] \<cdot> \<pp>\<^sub>1[a0 \<otimes> a1, a2], \<pp>\<^sub>0[a0 \<otimes> a1, a2]\<rangle>"
       using assms assoc_def by auto
 
     lemma dup_coassoc:
     assumes "ide a"
     shows "\<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a] = (a \<otimes> \<d>[a]) \<cdot> \<d>[a]"
     proof (intro pr_joint_monic
                    [of a "a \<otimes> a" "\<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a]" "(a \<otimes> \<d>[a]) \<cdot> \<d>[a]"])
       show "seq \<pp>\<^sub>0[a, a \<otimes> a] (\<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a])"
         using assms by simp
       show "\<pp>\<^sub>0[a, a \<otimes> a] \<cdot> \<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a] = \<pp>\<^sub>0[a, a \<otimes> a] \<cdot> (a \<otimes> \<d>[a]) \<cdot> \<d>[a]"
       proof -
         have "\<pp>\<^sub>0[a, a \<otimes> a] \<cdot> \<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a] =
               ((\<pp>\<^sub>0[a, a \<otimes> a] \<cdot> \<a>[a, a, a]) \<cdot> (\<d>[a] \<otimes> a)) \<cdot> \<d>[a]"
           using comp_assoc by simp
         also have "... = \<langle>((\<pp>\<^sub>0[a, a] \<cdot> \<pp>\<^sub>1[a \<otimes> a, a]) \<cdot> (\<d>[a] \<otimes> a)) \<cdot> \<d>[a], (a \<cdot> \<pp>\<^sub>0[a, a]) \<cdot> \<d>[a]\<rangle>"
           using assms assoc_def by simp
         also have "... = \<d>[a]"
           using assms comp_assoc by simp
         also have "... = (\<pp>\<^sub>0[a, a \<otimes> a] \<cdot> (a \<otimes> \<d>[a])) \<cdot> \<d>[a]"
           using assms assoc_def comp_assoc by simp
         also have "... = \<pp>\<^sub>0[a, a \<otimes> a] \<cdot> (a \<otimes> \<d>[a]) \<cdot> \<d>[a]"
           using comp_assoc by simp
         finally show ?thesis by blast
       qed
       show "\<pp>\<^sub>1[a, a \<otimes> a] \<cdot> \<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a] = \<pp>\<^sub>1[a, a \<otimes> a] \<cdot> (a \<otimes> \<d>[a]) \<cdot> \<d>[a]"
       proof -
         have "\<pp>\<^sub>1[a, a \<otimes> a] \<cdot> \<a>[a, a, a] \<cdot> (\<d>[a] \<otimes> a) \<cdot> \<d>[a] =
               ((\<pp>\<^sub>1[a, a \<otimes> a] \<cdot> \<a>[a, a, a]) \<cdot> (\<d>[a] \<otimes> a)) \<cdot> \<d>[a]"
           using comp_assoc by simp
         also have "... = ((\<pp>\<^sub>1[a, a] \<cdot> \<pp>\<^sub>1[a \<otimes> a, a]) \<cdot> (\<d>[a] \<otimes> a)) \<cdot> \<d>[a]"
           using assms assoc_def by simp
         also have "... = a"
           using assms comp_assoc by simp
         also have "... = (a \<cdot> \<pp>\<^sub>1[a, a]) \<cdot> \<d>[a]"
           using assms comp_assoc by simp
         also have "... = (\<pp>\<^sub>1[a, a \<otimes> a] \<cdot> (a \<otimes> \<d>[a])) \<cdot> \<d>[a]"
           using assms by simp
         also have "... = \<pp>\<^sub>1[a, a \<otimes> a] \<cdot> (a \<otimes> \<d>[a]) \<cdot> \<d>[a]"
           using comp_assoc by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma comp_assoc_tuple:
     assumes "\<guillemotleft>f0 : a \<rightarrow> b0\<guillemotright>" and "\<guillemotleft>f1 : a \<rightarrow> b1\<guillemotright>" and "\<guillemotleft>f2 : a \<rightarrow> b2\<guillemotright>"
     shows "\<a>[b0, b1, b2] \<cdot> \<langle>\<langle>f0, f1\<rangle>, f2\<rangle> = \<langle>f0, \<langle>f1, f2\<rangle>\<rangle>"
     and "\<a>\<^sup>-\<^sup>1[b0, b1, b2] \<cdot> \<langle>f0, \<langle>f1, f2\<rangle>\<rangle> = \<langle>\<langle>f0, f1\<rangle>, f2\<rangle>"
       using assms assoc_def assoc'_def comp_assoc by fastforce+
 
     lemma dup_tensor:
     assumes "ide a" and "ide b"
     shows "\<d>[a \<otimes> b] = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> (a \<otimes> \<a>[b, a, b]) \<cdot> (a \<otimes> \<sigma> (a, b) \<otimes> b) \<cdot>
                         (a \<otimes> \<a>\<^sup>-\<^sup>1[a, b, b]) \<cdot> \<a>[a, a, b \<otimes> b] \<cdot> (\<d>[a] \<otimes> \<d>[b])"
     proof (intro pr_joint_monic [of "a \<otimes> b" "a \<otimes> b" "\<d>[a \<otimes> b]"])
       show "seq \<pp>\<^sub>0[a \<otimes> b, a \<otimes> b] (\<d>[a \<otimes> b])"
         using assms by simp
       have 1: "\<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> (a \<otimes> \<a>[b, a, b]) \<cdot> (a \<otimes> \<sigma> (a, b) \<otimes> b) \<cdot>
                  (a \<otimes> \<a>\<^sup>-\<^sup>1[a, b, b]) \<cdot> \<a>[a, a, b \<otimes> b] \<cdot> (\<d>[a] \<otimes> \<d>[b]) =
                \<langle>a \<otimes> b, a \<otimes> b\<rangle>"
       proof -
         have "\<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> (a \<otimes> \<a>[b, a, b]) \<cdot> (a \<otimes> \<sigma> (a, b) \<otimes> b) \<cdot>
               (a \<otimes> \<a>\<^sup>-\<^sup>1[a, b, b]) \<cdot> \<a>[a, a, b \<otimes> b] \<cdot> (\<d>[a] \<otimes> \<d>[b])
                 = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> (a \<otimes> \<a>[b, a, b]) \<cdot> (a \<otimes> \<sigma> (a, b) \<otimes> b) \<cdot>
                   (a \<otimes> \<a>\<^sup>-\<^sup>1[a, b, b]) \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<langle>\<pp>\<^sub>1[a, b], \<d>[b] \<cdot> \<pp>\<^sub>0[a, b]\<rangle>\<rangle>"
         proof -
           have "\<a>[a, a, b \<otimes> b] \<cdot> (\<d>[a] \<otimes> \<d>[b]) = \<langle>\<pp>\<^sub>1[a, b], \<langle>\<pp>\<^sub>1[a, b], \<d>[b] \<cdot> \<pp>\<^sub>0[a, b]\<rangle>\<rangle>"
             using assms assoc_def comp_assoc pr_naturality comp_cod_arr by simp
           thus ?thesis by presburger
         qed
         also have "... = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot>
         \<langle>a \<cdot> a \<cdot> a \<cdot> \<pp>\<^sub>1[a, b], \<a>[b, a, b] \<cdot> (\<s>[a, b] \<cdot> (a \<otimes> b) \<otimes> b) \<cdot>
                                \<a>\<^sup>-\<^sup>1[a, b, b] \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<d>[b \<cdot> \<pp>\<^sub>0[a, b]]\<rangle>\<rangle>"
           using assms prod_tuple by simp
         also have "... = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot>
         \<langle>\<pp>\<^sub>1[a, b], \<a>[b, a, b] \<cdot> (\<s>[a, b] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[a, b, b] \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<d>[\<pp>\<^sub>0[a, b]]\<rangle>\<rangle>"
         proof -
           have "a \<cdot> a \<cdot> a \<cdot> \<pp>\<^sub>1[a, b] = \<pp>\<^sub>1[a, b]"
             using assms comp_cod_arr by simp
           moreover have "b \<cdot> \<pp>\<^sub>0[a, b] = \<pp>\<^sub>0[a, b]"
             using assms comp_cod_arr by simp
           moreover have "\<s>[a, b] \<cdot> (a \<otimes> b) \<otimes> b = \<s>[a, b] \<otimes> b"
             using assms comp_arr_dom by simp
           ultimately show ?thesis by simp
         qed
         also have "... = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<a>[b, a, b] \<cdot> (\<s>[a, b] \<otimes> b) \<cdot>
                            \<langle>\<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle>, \<pp>\<^sub>0[a, b]\<rangle>\<rangle>"
         proof -
           have "\<a>\<^sup>-\<^sup>1[a, b, b] \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<d>[\<pp>\<^sub>0[a, b]]\<rangle> = \<langle>\<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle>, \<pp>\<^sub>0[a, b]\<rangle>"
             using assms comp_assoc_tuple(2) by blast
           thus ?thesis by simp
         qed
         also have "... = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<a>[b, a, b] \<cdot> \<langle>\<s>[a, b], \<pp>\<^sub>0[a, b]\<rangle>\<rangle>"
           using assms prod_tuple comp_arr_dom comp_cod_arr by simp
         also have "... = \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> \<langle>\<pp>\<^sub>1[a, b], \<langle>\<pp>\<^sub>0[a, b], \<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle>\<rangle>\<rangle>"
           using assms comp_assoc_tuple(1)
           by (metis sym_def pr_in_hom)
         also have "... = \<langle>\<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle>, \<langle>\<pp>\<^sub>1[a, b], \<pp>\<^sub>0[a, b]\<rangle>\<rangle>"
           using assms comp_assoc_tuple(2) by force
         also have "... = \<d>[a \<otimes> b]"
           using assms by simp
         finally show ?thesis by simp
       qed
       show "\<pp>\<^sub>0[a \<otimes> b, a \<otimes> b] \<cdot> \<d>[a \<otimes> b]
               = \<pp>\<^sub>0[a \<otimes> b, a \<otimes> b] \<cdot>
                 \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> (a \<otimes> \<a>[b, a, b]) \<cdot> (a \<otimes> \<sigma> (a, b) \<otimes> b) \<cdot>
                 (a \<otimes> \<a>\<^sup>-\<^sup>1[a, b, b]) \<cdot> \<a>[a, a, b \<otimes> b] \<cdot> (\<d>[a] \<otimes> \<d>[b])"
         using assms 1 by force
       show "\<pp>\<^sub>1[a \<otimes> b, a \<otimes> b] \<cdot> \<d>[a \<otimes> b]
               = \<pp>\<^sub>1[a \<otimes> b, a \<otimes> b] \<cdot>
                 \<a>\<^sup>-\<^sup>1[a, b, a \<otimes> b] \<cdot> (a \<otimes> \<a>[b, a, b]) \<cdot> (a \<otimes> \<sigma> (a, b) \<otimes> b) \<cdot>
                 (a \<otimes> \<a>\<^sup>-\<^sup>1[a, b, b]) \<cdot> \<a>[a, a, b \<otimes> b] \<cdot> (\<d>[a] \<otimes> \<d>[b])"
         using assms 1 by force
     qed
 
     (* TODO: Not sure if the remaining facts are useful. *)
 
     lemma \<iota>_eq_trm:
     shows "\<iota> = \<t>[\<one> \<otimes> \<one>]"
     proof (intro terminal_arr_unique)
       show "par \<iota> \<t>[\<one> \<otimes> \<one>]"
         by (simp add: ide_one trm_one trm_tensor)
       show "terminal_arr \<t>[\<one> \<otimes> \<one>]"
         using ide_one \<iota>_is_terminal_arr \<open>par \<iota> \<t>[\<one> \<otimes> \<one>]\<close> by auto
       show "terminal_arr \<iota>"
         using \<iota>_is_terminal_arr by blast
     qed
 
     lemma terminal_tensor_one_one:
     shows "terminal (\<one> \<otimes> \<one>)"
     proof
       show "ide (\<one> \<otimes> \<one>)"
         using ide_one by simp
       show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright>"
       proof -
         fix a
         assume a: "ide a"
         show "\<exists>!f. \<guillemotleft>f : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright>"
         proof
           show "\<guillemotleft>inv \<iota> \<cdot> \<t>[a] : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright>"
             using a ide_one inverse_arrows_\<iota> inverse_unique trm_in_hom by fastforce
           show "\<And>f. \<guillemotleft>f : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright> \<Longrightarrow> f = inv \<iota> \<cdot> \<t>[a]"
           proof -
             fix f
             assume f: "\<guillemotleft>f : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright>"
             have "\<iota> \<cdot> f = \<t>[a]"
             proof (intro terminal_arr_unique)
               show "par (\<iota> \<cdot> f) \<t>[a]"
                 using a f
                 by (metis \<iota>_is_iso \<iota>_is_terminal_arr \<open>\<guillemotleft>inv \<iota> \<cdot> \<t>[a] : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright>\<close>
                     cod_comp dom_comp dom_inv ide_one in_homE pr_simps(2-3) seqE seqI)
               show "terminal_arr (\<iota> \<cdot> f)"
                 using a f \<iota>_is_terminal_arr cod_comp by force
               show "terminal_arr \<t>[a]"
                 using a \<open>par (\<iota> \<cdot> f) \<t>[a]\<close> \<open>terminal_arr (\<iota> \<cdot> f)\<close> by auto
             qed
             thus "f = inv \<iota> \<cdot> \<t>[a]"
               using a f \<iota>_is_iso invert_side_of_triangle(1)
                     \<open>\<guillemotleft>inv \<iota> \<cdot> \<t>[a] : a \<rightarrow> \<one> \<otimes> \<one>\<guillemotright>\<close>
               by blast
           qed
         qed
       qed
     qed
 
   end
 
   section "Category with Finite Products"
 
   text \<open>
     In this last section, we show that the notion ``cartesian category'', which we defined
     to be a category with binary products and terminal object, coincides with the notion
     ``category with finite products''.  Due to the inability to quantify over types in HOL,
     we content ourselves with defining the latter notion as "has \<open>I\<close>-indexed products
     for every finite set \<open>I\<close> of natural numbers."  We can transfer this property to finite
     sets at other types using the fact that products are preserved under bijections of
     the index sets.
   \<close>
 
   locale category_with_finite_products =
     category C
   for C :: "'c comp" +
   assumes has_finite_products: "finite (I :: nat set) \<Longrightarrow> has_products I"
   begin
 
     lemma has_finite_products':
     assumes "I \<noteq> UNIV"
     shows "finite I \<Longrightarrow> has_products I"
     proof -
       assume I: "finite I"
       obtain n \<phi> where \<phi>: "bij_betw \<phi> {k. k < (n :: nat)} I"
         using I finite_imp_nat_seg_image_inj_on inj_on_imp_bij_betw by fastforce
       show "has_products I"
         using assms(1) \<phi> has_finite_products has_products_preserved_by_bijection
               category_with_finite_products.has_finite_products
         by blast
     qed
 
   end
 
   lemma (in category) has_binary_products_if:
   assumes "has_products ({0, 1} :: nat set)"
   shows "has_binary_products"
   proof (unfold has_binary_products_def)
     show "\<forall>a0 a1. ide a0 \<and> ide a1 \<longrightarrow> (\<exists>p0 p1. has_as_binary_product a0 a1 p0 p1)"
     proof (intro allI impI)
       fix a0 a1
       assume 1: "ide a0 \<and> ide a1"
       show "\<exists>p0 p1. has_as_binary_product a0 a1 p0 p1"
       proof -
         interpret J: binary_product_shape
           by unfold_locales
         interpret D: binary_product_diagram C a0 a1
           using 1 by unfold_locales auto
         interpret discrete_diagram J.comp C D.map
           using J.is_discrete
           by unfold_locales auto
         show "\<exists>p0 p1. has_as_binary_product a0 a1 p0 p1"
         proof (unfold has_as_binary_product_def)
           text \<open>
             Here we have to work around the fact that \<open>has_finite_products\<close> is defined
             in terms of @{typ "nat set"}, whereas \<open>has_as_binary_product\<close> is defined
             in terms of \<open>J.arr set\<close>.
           \<close>
           let ?\<phi> = "(\<lambda>x :: nat. if x = 0 then J.FF else J.TT)"
           let ?\<psi> = "\<lambda>j. if j = J.FF then 0 else 1"
           have "bij_betw ?\<phi> ({0, 1} :: nat set) {J.FF, J.TT}"
             using bij_betwI [of ?\<phi> "{0, 1} :: nat set" "{J.FF, J.TT}" ?\<psi>] by fastforce
           hence "has_products {J.FF, J.TT}"
             using assms has_products_def [of "{J.FF, J.TT}"]
                   has_products_preserved_by_bijection
                     [of "{0, 1} :: nat set" ?\<phi> "{J.FF, J.TT}"]
             by blast
           hence "\<exists>a. has_as_product J.comp D.map a"
             using has_products_def [of "{J.FF, J.TT}"]
                   discrete_diagram_axioms J.arr_char
             by blast
           hence "\<exists>a \<pi>. product_cone J.comp C D.map a \<pi>"
             using has_as_product_def by blast
           hence 2: "\<exists>a \<pi>. D.limit_cone a \<pi>"
             unfolding product_cone_def by simp
           obtain a \<pi> where \<pi>: "D.limit_cone a \<pi>"
             using 2 by auto
           interpret \<pi>: limit_cone J.comp C D.map a \<pi>
             using \<pi> by auto
           have "\<pi> = D.mkCone (\<pi> J.FF) (\<pi> J.TT)"
           proof -
             have "\<And>a. J.ide a \<Longrightarrow> \<pi> a = D.mkCone (\<pi> J.FF) (\<pi> J.TT) a"
               using D.mkCone_def J.ide_char by auto
             moreover have "a = dom (\<pi> J.FF)"
               by simp
             moreover have "D.cone a (D.mkCone (\<pi> (J.MkIde False)) (\<pi> (J.MkIde True)))"
               using 1 D.cone_mkCone [of "\<pi> J.FF" "\<pi> J.TT"] by auto
             ultimately show ?thesis
               using D.mkCone_def \<pi>.natural_transformation_axioms
                     D.cone_mkCone [of "\<pi> J.FF" "\<pi> J.TT"]
                     NaturalTransformation.eqI
                       [of "J.comp" C \<pi>.A.map "D.map" \<pi> "D.mkCone (\<pi> J.FF) (\<pi> J.TT)"]
                     cone_def [of J.comp C D.map a "D.mkCone (\<pi> J.FF) (\<pi> J.TT)"] J.ide_char
               by blast
           qed
           hence "D.limit_cone (dom (\<pi> J.FF)) (D.mkCone (\<pi> J.FF) (\<pi> J.TT))"
             using \<pi>.limit_cone_axioms by simp
           thus "\<exists>p0 p1. ide a0 \<and> ide a1 \<and> D.has_as_binary_product p0 p1"
             using 1 by blast
         qed
       qed
     qed
   qed
 
   sublocale category_with_finite_products \<subseteq> category_with_binary_products C
     using has_binary_products_if has_finite_products
     by (unfold_locales, unfold has_binary_products_def) simp
 
   proposition (in category_with_finite_products) is_category_with_binary_products:
   shows "category_with_binary_products C"
     ..
 
   sublocale category_with_finite_products \<subseteq> category_with_terminal_object C
   proof
     interpret J: discrete_category "{} :: nat set"
       by unfold_locales auto
     interpret D: empty_diagram J.comp C "\<lambda>j. null"
       by unfold_locales auto
     interpret D: discrete_diagram J.comp C "\<lambda>j. null"
       using J.is_discrete by unfold_locales auto
     have "\<And>a. D.has_as_limit a \<longleftrightarrow> has_as_product J.comp (\<lambda>j. null) a"
       using product_cone_def J.category_axioms category_axioms D.discrete_diagram_axioms
             has_as_product_def product_cone_def
       by metis
     moreover have "\<exists>a. has_as_product J.comp (\<lambda>j. null) a"
       using has_finite_products [of "{} :: nat set"] has_products_def [of "{} :: nat set"]
             D.discrete_diagram_axioms
       by blast
     ultimately have "\<exists>a. D.has_as_limit a" by blast
     thus "\<exists>a. terminal a" using D.has_as_limit_iff_terminal by blast
   qed
 
   proposition (in category_with_finite_products) is_category_with_terminal_object:
   shows "category_with_terminal_object C"
     ..
 
   sublocale category_with_finite_products \<subseteq> cartesian_category ..
 
   proposition (in category_with_finite_products) is_cartesian_category:
   shows "cartesian_category C"
     ..
 
   context category
   begin
 
     lemma binary_product_of_products_is_product:
     assumes "has_as_product J0 D0 a0" and "has_as_product J1 D1 a1"
     and "has_as_binary_product a0 a1 p0 p1"
     and "Collect (partial_magma.arr J0) \<inter> Collect (partial_magma.arr J1) = {}"
     and "partial_magma.null J0 = partial_magma.null J1"
     shows "has_as_product
              (discrete_category.comp
                 (Collect (partial_magma.arr J0) \<union> Collect (partial_magma.arr J1))
                 (partial_magma.null J0))
              (\<lambda>i. if i \<in> Collect (partial_magma.arr J0) then D0 i
                   else if i \<in> Collect (partial_magma.arr J1) then D1 i
                   else null)
              (dom p0)"
     proof -
       obtain \<pi>0 where \<pi>0: "product_cone J0 (\<cdot>) D0 a0 \<pi>0"
         using assms(1) has_as_product_def by blast
       obtain \<pi>1 where \<pi>1: "product_cone J1 (\<cdot>) D1 a1 \<pi>1"
         using assms(2) has_as_product_def by blast
       interpret J0: category J0
         using \<pi>0 product_cone.axioms(1) by metis
       interpret J1: category J1
         using \<pi>1 product_cone.axioms(1) by metis
       interpret D0: discrete_diagram J0 C D0
         using \<pi>0 product_cone.axioms(3) by metis
       interpret D1: discrete_diagram J1 C D1
         using \<pi>1 product_cone.axioms(3) by metis
       interpret \<pi>0: product_cone J0 C D0 a0 \<pi>0
         using \<pi>0 by auto
       interpret \<pi>1: product_cone J1 C D1 a1 \<pi>1
         using \<pi>1 by auto
       interpret J: discrete_category \<open>Collect J0.arr \<union> Collect J1.arr\<close> J0.null
         using J0.not_arr_null assms(5) by unfold_locales auto
       interpret X: binary_product_shape .
       interpret a0xa1: binary_product_diagram C a0 a1
         using assms(3) has_as_binary_product_def
         by (simp add: binary_product_diagram.intro binary_product_diagram_axioms.intro
             category_axioms)
       have p0p1: "a0xa1.has_as_binary_product p0 p1"
         using assms(3) has_as_binary_product_def [of a0 a1 p0 p1] by simp
 
       let ?D = "(\<lambda>i. if i \<in> Collect J0.arr then D0 i
                      else if i \<in> Collect J1.arr then D1 i
                      else null)"
       let ?a = "dom p0"
       let ?\<pi> = "\<lambda>i. if i \<in> Collect J0.arr then \<pi>0 i \<cdot> p0
                     else if i \<in> Collect J1.arr then \<pi>1 i \<cdot> p1
                     else null"
 
       let ?p0p1 = "a0xa1.mkCone p0 p1"
       interpret p0p1: limit_cone X.comp C a0xa1.map ?a ?p0p1
         using p0p1 by simp
       have a: "ide ?a"
         using p0p1.ide_apex by simp
       have p0: "\<guillemotleft>p0 : ?a \<rightarrow> a0\<guillemotright>"
         using a0xa1.mkCone_def p0p1.preserves_hom [of X.FF X.FF X.FF] X.ide_char X.ide_in_hom
         by auto
       have p1: "\<guillemotleft>p1 : ?a \<rightarrow> a1\<guillemotright>"
         using a0xa1.mkCone_def p0p1.preserves_hom [of X.TT X.TT X.TT] X.ide_char X.ide_in_hom
         by auto
 
       interpret D: discrete_diagram J.comp C ?D
         using assms J.arr_char J.dom_char J.cod_char J.is_discrete D0.is_discrete D1.is_discrete
               J.cod_comp J.seq_char
         by unfold_locales auto
       interpret A: constant_functor J.comp C ?a
         using p0p1.ide_apex by unfold_locales simp
       interpret \<pi>: natural_transformation J.comp C A.map ?D ?\<pi>
       proof
         fix j
         show "\<not> J.arr j \<Longrightarrow> ?\<pi> j = null"
           by simp
         assume j: "J.arr j"
         have \<pi>0j: "J0.arr j \<Longrightarrow> \<guillemotleft>\<pi>0 j : a0 \<rightarrow> D0 j\<guillemotright>"
           using D0.is_discrete by auto
         have \<pi>1j: "J1.arr j \<Longrightarrow> \<guillemotleft>\<pi>1 j : a1 \<rightarrow> D1 j\<guillemotright>"
           using D1.is_discrete by auto
         show "dom (?\<pi> j) = A.map (J.dom j)"
           using j J.arr_char p0 p1 \<pi>0j \<pi>1j
           by fastforce
         show "cod (?\<pi> j) = ?D (J.cod j)"
           using j J.arr_char p0 p1 \<pi>0j \<pi>1j
           by fastforce
         show "?D j \<cdot> ?\<pi> (J.dom j) = ?\<pi> j"
         proof -
           have 0: "J0.arr j \<Longrightarrow> D0 j \<cdot> \<pi>0 j \<cdot> p0 = \<pi>0 j \<cdot> p0"
           proof -
             have "J0.arr j \<Longrightarrow> (D0 j \<cdot> \<pi>0 j) \<cdot> p0 = \<pi>0 j \<cdot> p0"
               using p0 \<pi>0.is_natural_1 \<pi>0.is_natural_2 D0.is_discrete by simp
             thus "J0.arr j \<Longrightarrow> D0 j \<cdot> \<pi>0 j \<cdot> p0 = \<pi>0 j \<cdot> p0"
               using comp_assoc by simp
           qed
           have 1: "J1.arr j \<Longrightarrow> D1 j \<cdot> \<pi>1 j \<cdot> p1 = \<pi>1 j \<cdot> p1"
           proof -
             have "J1.arr j \<Longrightarrow> (D1 j \<cdot> \<pi>1 j) \<cdot> p1 = \<pi>1 j \<cdot> p1"
               using p1 \<pi>1.is_natural_1 \<pi>1.is_natural_2 D1.is_discrete by simp
             thus "J1.arr j \<Longrightarrow> D1 j \<cdot> \<pi>1 j \<cdot> p1 = \<pi>1 j \<cdot> p1"
               using comp_assoc by simp
           qed
           show ?thesis
             using 0 1 by auto
         qed
         show "?\<pi> (J.cod j) \<cdot> A.map j = ?\<pi> j"
           using j comp_arr_dom p0 p1 comp_assoc by auto
       qed
       interpret \<pi>: cone J.comp C ?D ?a ?\<pi> ..
       interpret \<pi>: product_cone J.comp C ?D ?a ?\<pi>
       proof
         show "\<And>a' \<chi>'. D.cone a' \<chi>' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> ?a\<guillemotright> \<and> D.cones_map f ?\<pi> = \<chi>'"
         proof -
           fix a' \<chi>'
           assume \<chi>': "D.cone a' \<chi>'"
           interpret \<chi>': cone J.comp C ?D a' \<chi>'
             using \<chi>' by simp
           show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> ?a\<guillemotright> \<and> D.cones_map f ?\<pi> = \<chi>'"
           proof
             let ?\<chi>0' = "\<lambda>i. if i \<in> Collect J0.arr then \<chi>' i else null"
             let ?\<chi>1' = "\<lambda>i. if i \<in> Collect J1.arr then \<chi>' i else null"
             have 0: "\<And>i. i \<in> Collect J0.arr \<Longrightarrow> \<chi>' i \<in> hom a' (D0 i)"
               using J.arr_char by auto
             have 1: "\<And>i. i \<in> Collect J1.arr \<Longrightarrow> \<chi>' i \<in> hom a' (D1 i)"
               using J.arr_char \<open>Collect J0.arr \<inter> Collect J1.arr = {}\<close> by force
             interpret A0': constant_functor J0 C a'
               apply unfold_locales using \<chi>'.ide_apex by auto
             interpret A1': constant_functor J1 C a'
               apply unfold_locales using \<chi>'.ide_apex by auto
             interpret \<chi>0': cone J0 C D0 a' ?\<chi>0'
             proof (unfold_locales)
               fix j
               show "\<not> J0.arr j \<Longrightarrow> (if j \<in> Collect J0.arr then \<chi>' j else null) = null"
                 by simp
               assume j: "J0.arr j"
               show 0: "dom (?\<chi>0' j) = A0'.map (J0.dom j)"
                 using j by simp
               show 1: "cod (?\<chi>0' j) = D0 (J0.cod j)"
                 using j J.arr_char J.cod_char D0.is_discrete by simp
               show "D0 j \<cdot> (?\<chi>0' (J0.dom j)) = ?\<chi>0' j"
                 using 1 j J.arr_char D0.is_discrete comp_cod_arr by simp
               show "?\<chi>0' (J0.cod j) \<cdot> A0'.map j = ?\<chi>0' j"
                 using 0 j J.arr_char D0.is_discrete comp_arr_dom by simp
             qed
             interpret \<chi>1': cone J1 C D1 a' ?\<chi>1'
             proof (unfold_locales)
               fix j
               show "\<not> J1.arr j \<Longrightarrow> (if j \<in> Collect J1.arr then \<chi>' j else null) = null"
                 by simp
               assume j: "J1.arr j"
               show 0: "dom (?\<chi>1' j) = A1'.map (J1.dom j)"
                 using j by simp
               show 1: "cod (?\<chi>1' j) = D1 (J1.cod j)"
                 using assms(4) j J.arr_char J.cod_char D1.is_discrete by auto
               show "D1 j \<cdot> (?\<chi>1' (J1.dom j)) = ?\<chi>1' j"
                 using 1 j J.arr_char D1.is_discrete comp_cod_arr by simp
               show "?\<chi>1' (J1.cod j) \<cdot> A1'.map j = ?\<chi>1' j"
                 using 0 j J.arr_char D1.is_discrete comp_arr_dom by simp
             qed
             define f0 where "f0 = \<pi>0.induced_arrow a' ?\<chi>0'"
             define f1 where "f1 = \<pi>1.induced_arrow a' ?\<chi>1'"
             have f0: "\<guillemotleft>f0 : a' \<rightarrow> a0\<guillemotright>"
               using f0_def \<pi>0.induced_arrowI \<chi>0'.cone_axioms by simp
             have f1: "\<guillemotleft>f1 : a' \<rightarrow> a1\<guillemotright>"
               using f1_def \<pi>1.induced_arrowI \<chi>1'.cone_axioms by simp
             have 2: "a0xa1.is_rendered_commutative_by f0 f1"
               using f0 f1 by auto
 
             interpret p0p1: binary_product_cone C a0 a1 p0 p1 ..
             interpret f0f1: cone X.comp C a0xa1.map a' \<open>a0xa1.mkCone f0 f1\<close>
               using 2 f0 f1 a0xa1.cone_mkCone [of f0 f1] by auto
             define f where "f = p0p1.induced_arrow a' (a0xa1.mkCone f0 f1)"
 
             have f: "\<guillemotleft>f : a' \<rightarrow> ?a\<guillemotright>"
               using f_def 2 f0 f1 p0p1.induced_arrowI'(1) by auto
             moreover have \<chi>': "D.cones_map f ?\<pi> = \<chi>'"
             proof
               fix j
               show "D.cones_map f ?\<pi> j = \<chi>' j"
               proof (cases "J0.arr j", cases "J1.arr j")
                 show "\<lbrakk>J0.arr j; J1.arr j\<rbrakk> \<Longrightarrow> D.cones_map f ?\<pi> j = \<chi>' j"
                   using assms(4) by auto
                 show "\<lbrakk>J0.arr j; \<not> J1.arr j\<rbrakk> \<Longrightarrow> D.cones_map f ?\<pi> j = \<chi>' j"
                 proof -
                   assume J0: "J0.arr j" and J1: "\<not> J1.arr j"
                   have "D.cones_map f ?\<pi> j = (\<pi>0 j \<cdot> p0) \<cdot> f"
                     using f J0 J1 \<pi>.cone_axioms by auto
                   also have "... = \<pi>0 j \<cdot> p0 \<cdot> f"
                     using comp_assoc by simp
                   also have "... = \<pi>0 j \<cdot> f0"
                     using 2 f0 f1 f_def p0p1.induced_arrowI' by auto
                   also have "... = \<chi>' j"
                   proof -
                     have "\<pi>0 j \<cdot> f0 = \<pi>0 j \<cdot> \<pi>0.induced_arrow' a' \<chi>'"
                       unfolding f0_def by simp
                     also have "... = (\<lambda>j. if J0.arr j then
                                             \<pi>0 j \<cdot> \<pi>0.induced_arrow a'
                                                     (\<lambda>i. if i \<in> Collect J0.arr then \<chi>' i else null)
                                           else null) j"
                       using J0 by simp
                     also have "... = D0.mkCone \<chi>' j"
                     proof -
                       have "(\<lambda>j. if J0.arr j then
                                     \<pi>0 j \<cdot> \<pi>0.induced_arrow a'
                                              (\<lambda>i. if i \<in> Collect J0.arr then \<chi>' i else null)
                                  else null) =
                             D0.mkCone \<chi>'"
                         using f0 f0_def \<pi>0.induced_arrowI(2) [of ?\<chi>0' a'] J0
                               D0.mkCone_cone \<chi>0'.cone_axioms \<pi>0.cone_axioms J0
                         by auto
                       thus ?thesis by meson
                     qed
                     also have "... = \<chi>' j"
                       using J0 by simp
                     finally show ?thesis by blast
                   qed
                   finally show ?thesis by simp
                 qed
                 show "\<not> J0.arr j \<Longrightarrow> D.cones_map f ?\<pi> j = \<chi>' j"
                 proof (cases "J1.arr j")
                   show "\<lbrakk>\<not> J0.arr j; \<not> J1.arr j\<rbrakk> \<Longrightarrow> D.cones_map f ?\<pi> j = \<chi>' j"
                     using f \<pi>.cone_axioms \<chi>'.is_extensional by auto
                   show "\<lbrakk>\<not> J0.arr j; J1.arr j\<rbrakk> \<Longrightarrow> D.cones_map f ?\<pi> j = \<chi>' j"
                   proof -
                     assume J0: "\<not> J0.arr j" and J1: "J1.arr j"
                     have "D.cones_map f ?\<pi> j = (\<pi>1 j \<cdot> p1) \<cdot> f"
                       using J0 J1 f \<pi>.cone_axioms by auto
                     also have "... = \<pi>1 j \<cdot> p1 \<cdot> f"
                       using comp_assoc by simp
                     also have "... = \<pi>1 j \<cdot> f1"
                       using 2 f0 f1 f_def p0p1.induced_arrowI' by auto
                     also have "... = \<chi>' j"
                     proof -
                       have "\<pi>1 j \<cdot> f1 = \<pi>1 j \<cdot> \<pi>1.induced_arrow' a' \<chi>'"
                         unfolding f1_def by simp
                       also have "... = (\<lambda>j. if J1.arr j then
                                               \<pi>1 j \<cdot> \<pi>1.induced_arrow a'
                                                       (\<lambda>i. if i \<in> Collect J1.arr
                                                            then \<chi>' i else null)
                                             else null) j"
                         using J1 by simp
                       also have "... = D1.mkCone \<chi>' j"
                       proof -
                         have "(\<lambda>j. if J1.arr j then
                                       \<pi>1 j \<cdot> \<pi>1.induced_arrow a'
                                                (\<lambda>i. if i \<in> Collect J1.arr then \<chi>' i else null)
                                    else null) =
                               D1.mkCone \<chi>'"
                           using f1 f1_def \<pi>1.induced_arrowI(2) [of ?\<chi>1' a'] J1
                                 D1.mkCone_cone [of a' \<chi>'] \<chi>1'.cone_axioms \<pi>1.cone_axioms J1
                           by auto
                         thus ?thesis by meson
                       qed
                       also have "... = \<chi>' j"
                         using J1 by simp
                       finally show ?thesis by blast
                     qed
                     finally show ?thesis by simp
                   qed
                 qed
               qed
             qed
             ultimately show "\<guillemotleft>f : a' \<rightarrow> ?a\<guillemotright> \<and> D.cones_map f ?\<pi> = \<chi>'" by blast
             show "\<And>f'. \<guillemotleft>f' : a' \<rightarrow> ?a\<guillemotright> \<and> D.cones_map f' ?\<pi> = \<chi>' \<Longrightarrow> f' = f"
             proof -
               fix f'
               assume f': "\<guillemotleft>f' : a' \<rightarrow> ?a\<guillemotright> \<and> D.cones_map f' ?\<pi> = \<chi>'"
               let ?f0' = "p0 \<cdot> f'"
               let ?f1' = "p1 \<cdot> f'"
               have 1: "a0xa1.is_rendered_commutative_by ?f0' ?f1'"
                 using f' p0 p1 p0p1.renders_commutative seqI' by auto
               have f0': "\<guillemotleft>?f0' : a' \<rightarrow> a0\<guillemotright>"
                 using f' p0 by auto
               have f1': "\<guillemotleft>?f1' : a' \<rightarrow> a1\<guillemotright>"
                 using f' p1 by auto
               have "p0 \<cdot> f = p0 \<cdot> f'"
               proof -
                 have "D0.cones_map (p0 \<cdot> f) \<pi>0 = ?\<chi>0'"
                   using f p0 \<pi>0.cone_axioms \<chi>' \<pi>.cone_axioms comp_assoc assms(4) seqI'
                   by fastforce
                 moreover have "D0.cones_map (p0 \<cdot> f') \<pi>0 = ?\<chi>0'"
                   using f' p0 \<pi>0.cone_axioms \<pi>.cone_axioms comp_assoc assms(4) seqI'
                   by fastforce
                 moreover have "p0 \<cdot> f = f0"
                   using 2 f0 f_def p0p1.induced_arrowI'(2) by blast
                 ultimately show ?thesis
                   using f0 f0' \<chi>0'.cone_axioms \<pi>0.is_universal [of a'] by auto
               qed
               moreover have "p1 \<cdot> f = p1 \<cdot> f'"
               proof -
                 have "D1.cones_map (p1 \<cdot> f) \<pi>1 = ?\<chi>1'"
                 proof
                   fix j
                   show "D1.cones_map (p1 \<cdot> f) \<pi>1 j = ?\<chi>1' j"
                     using f p1 \<pi>1.cone_axioms \<chi>' \<pi>.cone_axioms comp_assoc assms(4) seqI'
                     apply auto
                     by auto
                 qed
                 moreover have "D1.cones_map (p1 \<cdot> f') \<pi>1 = ?\<chi>1'"
                 proof
                   fix j
                   show "D1.cones_map (p1 \<cdot> f') \<pi>1 j = ?\<chi>1' j"
                     using f' p1 \<pi>1.cone_axioms \<pi>.cone_axioms comp_assoc assms(4) seqI'
                     apply auto
                     by auto
                 qed
                 moreover have "p1 \<cdot> f = f1"
                   using 2 f1 f_def p0p1.induced_arrowI'(3) by blast
                   ultimately show ?thesis
                 using f1 f1' \<chi>1'.cone_axioms \<pi>1.is_universal [of a'] by auto
               qed
               ultimately show "f' = f"
                 using f f' p0p1.is_universal' [of a']
                 by (metis (no_types, lifting) "1" dom_comp in_homE p0p1.is_universal' p1 seqI')
             qed
           qed
         qed
       qed
       show "has_as_product J.comp ?D ?a"
         unfolding has_as_product_def
         using \<pi>.product_cone_axioms by auto
     qed
 
   end
 
   sublocale cartesian_category \<subseteq> category_with_finite_products
   proof
     obtain t where t: "terminal t" using has_terminal by blast
     { fix n :: nat
       have "\<And>I :: nat set. finite I \<and> card I = n \<Longrightarrow> has_products I"
       proof (induct n)
         show "\<And>I :: nat set. finite I \<and> card I = 0 \<Longrightarrow> has_products I"
         proof -
           fix I :: "nat set"
           assume "finite I \<and> card I = 0"
           hence I: "I = {}" by force
           thus "has_products I"
           proof -
             interpret J: discrete_category I 0
               apply unfold_locales using I by auto
             have "\<And>D. discrete_diagram J.comp C D \<Longrightarrow> \<exists>a. has_as_product J.comp D a"
             proof -
               fix D
               assume D: "discrete_diagram J.comp C D"
               interpret D: discrete_diagram J.comp C D using D by auto
               interpret D: empty_diagram J.comp C D
                  using I J.arr_char by unfold_locales simp
               have "has_as_product J.comp D t"
                 using t D.has_as_limit_iff_terminal has_as_product_def product_cone_def
                       J.category_axioms category_axioms D.discrete_diagram_axioms
                 by metis
               thus "\<exists>a. has_as_product J.comp D a" by blast
             qed
             moreover have "I \<noteq> UNIV"
               using I by blast
             ultimately show ?thesis
               using I has_products_def
               by (metis category_with_terminal_object.has_terminal discrete_diagram.product_coneI
                   discrete_diagram_def empty_diagram.has_as_limit_iff_terminal empty_diagram.intro
                   empty_diagram_axioms.intro empty_iff has_as_product_def
                   is_category_with_terminal_object mem_Collect_eq)
           qed
         qed
         show "\<And>n I :: nat set.
                 \<lbrakk> (\<And>I :: nat set. finite I \<and> card I = n \<Longrightarrow> has_products I);
                   finite I \<and> card I = Suc n \<rbrakk>
                     \<Longrightarrow> has_products I"
         proof -
           fix n :: nat
           fix I :: "nat set"
           assume IH: "\<And>I :: nat set. finite I \<and> card I = n \<Longrightarrow> has_products I"
           assume I: "finite I \<and> card I = Suc n"
           show "has_products I"
           proof -
             have "card I = 1 \<Longrightarrow> has_products I"
               using I has_unary_products by blast
             moreover have "card I \<noteq> 1 \<Longrightarrow> has_products I"
             proof -
               assume "card I \<noteq> 1"
               hence cardI: "card I > 1" using I by simp
               obtain i where i: "i \<in> I" using cardI by fastforce
               let ?I0 = "{i}" and ?I1 = "I - {i}"
               have 1: "I = ?I0 \<union> ?I1 \<and> ?I0 \<inter> ?I1 = {} \<and> card ?I0 = 1 \<and> card ?I1 = n"
                 using i I cardI by auto
               show "has_products I"
               proof (unfold has_products_def, intro conjI allI impI)
                 show "I \<noteq> UNIV"
                   using I by auto
                 fix J D
                 assume D: "discrete_diagram J C D \<and> Collect (partial_magma.arr J) = I"
                 interpret D: discrete_diagram J C D
                   using D by simp
                 have Null: "D.J.null \<notin> ?I0 \<and> D.J.null \<notin> ?I1"
                   using D D.J.not_arr_null i by blast
                 interpret J0: discrete_category ?I0 D.J.null
                   using 1 Null D by unfold_locales auto
                 interpret J1: discrete_category ?I1 D.J.null
                   using Null by unfold_locales auto
                 interpret J0uJ1: discrete_category \<open>Collect J0.arr \<union> Collect J1.arr\<close> J0.null
                   using Null 1 J0.null_char J1.null_char by unfold_locales auto
                 interpret D0: discrete_diagram_from_map ?I0 C D D.J.null
                   using 1 J0.ide_char D.preserves_ide D D.is_discrete i by unfold_locales auto
                 interpret D1: discrete_diagram_from_map ?I1 C D D.J.null
                   using 1 J1.ide_char D.preserves_ide D D.is_discrete i by unfold_locales auto
                 obtain a0 where a0: "has_as_product J0.comp D0.map a0"
                   using 1 has_unary_products [of ?I0] has_products_def [of ?I0]
                         D0.discrete_diagram_axioms
                   by fastforce
                 obtain a1 where a1: "has_as_product J1.comp D1.map a1"
                   using 1 I IH [of ?I1] has_products_def [of ?I1] D1.discrete_diagram_axioms
                   by blast
                 have 2: "\<exists>p0 p1. has_as_binary_product a0 a1 p0 p1"
                 proof -
                   have "ide a0 \<and> ide a1"
                     using a0 a1 product_is_ide by auto
                   thus ?thesis
                      using a0 a1 has_binary_products has_binary_products_def by simp
                 qed
                 obtain p0 p1 where a: "has_as_binary_product a0 a1 p0 p1"
                   using 2 by auto
                 let ?a = "dom p0"
                 have "has_as_product J D ?a"
                 proof -
                   have "D = (\<lambda>j. if j \<in> Collect J0.arr then D0.map j
                                  else if j \<in> Collect J1.arr then D1.map j
                                  else null)"
                   proof
                     fix j
                     show "D j = (if j \<in> Collect J0.arr then D0.map j
                                  else if j \<in> Collect J1.arr then D1.map j
                                  else null)"
                       using 1 D0.map_def D1.map_def D.is_extensional D J0.arr_char J1.arr_char
                       by auto
                   qed
                   moreover have "J = J0uJ1.comp"
                   proof -
                     have "\<And>j j'. J j j' = J0uJ1.comp j j'"
                     proof -
                       fix j j'
                       show "J j j' = J0uJ1.comp j j'"
                         using D J0uJ1.arr_char J0.arr_char J1.arr_char D.is_discrete i
                         apply (cases "j \<in> ?I0", cases "j' \<in> ?I0")
                           apply simp_all
                           apply auto[1]
                          apply (metis D.J.comp_arr_ide D.J.comp_ide_arr D.J.ext D.J.seqE
                             D.is_discrete J0.null_char J0uJ1.null_char)
                         by (metis D.J.comp_arr_ide D.J.comp_ide_arr D.J.comp_ide_self
                             D.J.ext D.J.seqE D.is_discrete J0.null_char J0uJ1.null_char
                             mem_Collect_eq)
                     qed
                     thus ?thesis by blast
                   qed
                   moreover have "Collect J0.arr \<inter> Collect J1.arr = {}"
                     by auto
                   moreover have "J0.null = J1.null"
                     using J0.null_char J1.null_char by simp
                   ultimately show "has_as_product J D ?a"
                     using binary_product_of_products_is_product
                             [of J0.comp D0.map a0 J1.comp D1.map a1 p0 p1]
                           J0.arr_char J1.arr_char
                           1 a0 a1 a
                     by simp
                 qed
                 thus "\<exists>a. has_as_product J D a" by blast
               qed
             qed
             ultimately show "has_products I" by blast
           qed
         qed
       qed
     }
     hence 1: "\<And>n I :: nat set. finite I \<and> card I = n \<Longrightarrow> has_products I" by simp
     thus "\<And>I :: nat set. finite I \<Longrightarrow> has_products I" by blast
   qed
 
   proposition (in cartesian_category) is_category_with_finite_products:
   shows "category_with_finite_products C"
     ..
 
 end
 
diff --git a/thys/Category3/ConcreteCategory.thy b/thys/Category3/ConcreteCategory.thy
--- a/thys/Category3/ConcreteCategory.thy
+++ b/thys/Category3/ConcreteCategory.thy
@@ -1,454 +1,454 @@
 (*  Title:       ConcreteCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "Concrete Categories"
 
 text \<open>
   In this section we define a locale \<open>concrete_category\<close>, which provides a uniform
   (and more traditional) way to construct a category from specified sets of objects and arrows,
   with specified identity objects and composition of arrows.
   We prove that the identities and arrows of the constructed category are appropriately
   in bijective correspondence with the given sets and that domains, codomains, and composition
   in the constructed category are as expected according to this correspondence.
   In the later theory \<open>Functor\<close>, once we have defined functors and isomorphisms of categories,
   we will show a stronger property of this construction: if \<open>C\<close> is any category,
   then \<open>C\<close> is isomorphic to the concrete category formed from it in the obvious way by taking
   the identities of \<open>C\<close> as objects, the set of arrows of \<open>C\<close> as arrows, the identities of
   \<open>C\<close> as identity objects, and defining composition of arrows using the composition of \<open>C\<close>.
   Thus no information about \<open>C\<close> is lost by extracting its objects, arrows, identities, and
   composition and rebuilding it as a concrete category.
   We note, however, that we do not assume that the composition function given as parameter
   to the concrete category construction is ``extensional'', so in general it will contain
   incidental information about composition of non-composable arrows, and this information
   is not preserved by the concrete category construction.
 \<close>
 
 theory ConcreteCategory
 imports Category
 begin
 
   locale concrete_category =
     fixes Obj :: "'o set"
     and Hom :: "'o \<Rightarrow> 'o \<Rightarrow> 'a set"
     and Id :: "'o \<Rightarrow> 'a"
     and Comp :: "'o \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>'a"
     assumes Id_in_Hom: "A \<in> Obj \<Longrightarrow> Id A \<in> Hom A A"
     and Comp_in_Hom: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; f \<in> Hom A B; g \<in> Hom B C \<rbrakk>
                          \<Longrightarrow> Comp C B A g f \<in> Hom A C"
     and Comp_Hom_Id: "\<lbrakk> A \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B A A f (Id A) = f"
     and Comp_Id_Hom: "\<lbrakk> B \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B B A (Id B) f = f"
     and Comp_assoc: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; D \<in> Obj;
                        f \<in> Hom A B; g \<in> Hom B C; h \<in> Hom C D \<rbrakk> \<Longrightarrow>
                         Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
   begin
 
     datatype ('oo, 'aa) arr =
       Null
     | MkArr 'oo 'oo 'aa
 
     abbreviation MkIde :: "'o \<Rightarrow> ('o, 'a) arr"
     where "MkIde A \<equiv> MkArr A A (Id A)"
 
     fun Dom :: "('o, 'a) arr \<Rightarrow> 'o"
     where "Dom (MkArr A _ _) = A"
         | "Dom _ = undefined"
 
     fun Cod
     where "Cod (MkArr _ B _) = B"
         | "Cod _ = undefined"
 
     fun Map
     where "Map (MkArr _ _ F) = F"
         | "Map _ = undefined"
 
     abbreviation Arr
     where "Arr f \<equiv> f \<noteq> Null \<and> Dom f \<in> Obj \<and> Cod f \<in> Obj \<and> Map f \<in> Hom (Dom f) (Cod f)"
 
     abbreviation Ide
     where "Ide a \<equiv> a \<noteq> Null \<and> Dom a \<in> Obj \<and> Cod a = Dom a \<and> Map a = Id (Dom a)"
 
     (*
      * Here we use COMP in order that uses of this locale can declare themselves as
      * sublocales and then define the abbreviation comp \<equiv> COMP.
      *)
     definition COMP :: "('o, 'a) arr comp"
     where "COMP g f \<equiv> if Arr f \<and> Arr g \<and> Dom g = Cod f then
                          MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
                       else
                          Null"
 
     interpretation partial_magma COMP
       using COMP_def by (unfold_locales, metis)
 
     lemma null_char:
     shows "null = Null"
     proof -
       let ?P = "\<lambda>n. \<forall>f. COMP n f = n \<and> COMP f n = n"
       have "Null = null"
         using COMP_def null_def the1_equality [of ?P]
         by (metis (no_types, lifting))
       thus ?thesis by simp
     qed
 
-    lemma ide_char:
+    lemma ide_char\<^sub>C\<^sub>C:
     shows "ide f \<longleftrightarrow> Ide f"
     proof
       assume f: "Ide f"
       show "ide f"
       proof -
         have "COMP f f \<noteq> null"
           using f COMP_def null_char Id_in_Hom by auto
         moreover have "\<forall>g. (COMP g f \<noteq> null \<longrightarrow> COMP g f = g) \<and>
                            (COMP f g \<noteq> null \<longrightarrow> COMP f g = g)"
         proof (intro allI conjI)
           fix g
           show "COMP g f \<noteq> null \<longrightarrow> COMP g f = g"
             using f COMP_def null_char Comp_Hom_Id Id_in_Hom
             by (cases g, auto)
           show "COMP f g \<noteq> null \<longrightarrow> COMP f g = g"
             using f COMP_def null_char Comp_Id_Hom Id_in_Hom
             by (cases g, auto)
         qed
         ultimately show ?thesis
           using ide_def by blast
       qed
       next
       assume f: "ide f"
       have 1: "Arr f \<and> Dom f = Cod f"
         using f ide_def COMP_def null_char by metis
       moreover have "Map f = Id (Dom f)"
       proof -
         let ?g = "MkIde (Dom f)"
         have g: "Arr f \<and> Arr ?g \<and> Dom ?g = Cod f"
           using 1 Id_in_Hom
           by (intro conjI, simp_all)
         have "COMP ?g f = MkArr (Dom f) (Dom f) (Map f)"
           using g COMP_def Comp_Id_Hom by auto
         moreover have "COMP ?g f = ?g"
         proof -
           have "COMP ?g f \<noteq> null"
             using g 1 COMP_def null_char by simp
           thus ?thesis
             using f ide_def by blast
         qed
         ultimately show ?thesis by simp
       qed
       ultimately show "Ide f" by auto
     qed
 
     lemma ide_MkIde [simp]:
     assumes "A \<in> Obj"
     shows "ide (MkIde A)"
-      using assms ide_char Id_in_Hom by simp
+      using assms ide_char\<^sub>C\<^sub>C Id_in_Hom by simp
 
     lemma in_domains_char:
     shows "a \<in> domains f \<longleftrightarrow> Arr f \<and> a = MkIde (Dom f)"
     proof
       assume a: "a \<in> domains f"
       have "Ide a"
-        using a domains_def ide_char COMP_def null_char by auto
+        using a domains_def ide_char\<^sub>C\<^sub>C COMP_def null_char by auto
       moreover have "Arr f \<and> Dom f = Cod a"
       proof -
         have "COMP f a \<noteq> null"
           using a domains_def by simp
         thus ?thesis
           using a domains_def COMP_def [of f a] null_char by metis
       qed
       ultimately show "Arr f \<and> a = MkIde (Dom f)"
         by (cases a, auto)
       next
       assume a: "Arr f \<and> a = MkIde (Dom f)"
       show "a \<in> domains f"
         using a Id_in_Hom COMP_def null_char domains_def by auto
     qed
 
     lemma in_codomains_char:
     shows "b \<in> codomains f \<longleftrightarrow> Arr f \<and> b = MkIde (Cod f)"
     proof
       assume b: "b \<in> codomains f"
       have "Ide b"
-        using b codomains_def ide_char COMP_def null_char by auto
+        using b codomains_def ide_char\<^sub>C\<^sub>C COMP_def null_char by auto
       moreover have "Arr f \<and> Dom b = Cod f"
       proof -
         have "COMP b f \<noteq> null"
           using b codomains_def by simp
         thus ?thesis
           using b codomains_def COMP_def [of b f] null_char by metis
       qed
       ultimately show "Arr f \<and> b = MkIde (Cod f)"
         by (cases b, auto)
       next
       assume b: "Arr f \<and> b = MkIde (Cod f)"
       show "b \<in> codomains f"
         using b Id_in_Hom COMP_def null_char codomains_def by auto
     qed
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> Arr f"
       using arr_def in_domains_char in_codomains_char by auto
 
-    lemma arrI:
+    lemma arrI\<^sub>C\<^sub>C:
     assumes "f \<noteq> Null" and "Dom f \<in> Obj" "Cod f \<in> Obj" "Map f \<in> Hom (Dom f) (Cod f)"
     shows "arr f"
       using assms arr_char by blast
 
     lemma arrE:
     assumes "arr f"
     and "\<lbrakk> f \<noteq> Null; Dom f \<in> Obj; Cod f \<in> Obj; Map f \<in> Hom (Dom f) (Cod f) \<rbrakk> \<Longrightarrow> T"
     shows T
       using assms arr_char by simp
 
     lemma arr_MkArr [simp]:
     assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
     shows "arr (MkArr A B f)"
       using assms arr_char by simp
 
     lemma MkArr_Map:
     assumes "arr f"
     shows "MkArr (Dom f) (Cod f) (Map f) = f"
       using assms arr_char by (cases f, auto)
 
     lemma Arr_comp:
     assumes "arr f" and "arr g" and "Dom g = Cod f"
     shows "Arr (COMP g f)"
       unfolding COMP_def
       using assms arr_char Comp_in_Hom by simp
 
     lemma Dom_comp [simp]:
     assumes "arr f" and "arr g" and "Dom g = Cod f"
     shows "Dom (COMP g f) = Dom f"
       unfolding COMP_def
       using assms arr_char by simp
 
     lemma Cod_comp [simp]:
     assumes "arr f" and "arr g" and "Dom g = Cod f"
     shows "Cod (COMP g f) = Cod g"
       unfolding COMP_def
       using assms arr_char by simp
 
     lemma Map_comp [simp]:
     assumes "arr f" and "arr g" and "Dom g = Cod f"
     shows "Map (COMP g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
       unfolding COMP_def
       using assms arr_char by simp
 
     lemma seq_char:
     shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> Dom g = Cod f"
       using arr_char not_arr_null null_char COMP_def Arr_comp by metis
 
     interpretation category COMP
     proof
       show "\<And>g f. COMP g f \<noteq> null \<Longrightarrow> seq g f"
         using arr_char COMP_def null_char Comp_in_Hom by auto
       show 1: "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
         using in_domains_char in_codomains_char by auto
       show "\<And>f g h. seq h g \<Longrightarrow> seq (COMP h g) f \<Longrightarrow> seq g f"
         by (auto simp add: seq_char)
       show "\<And>f g h. seq h (COMP g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
         using seq_char COMP_def Comp_in_Hom by (metis Cod_comp)
       show "\<And>f g h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (COMP h g) f"
         using Comp_in_Hom
         by (auto simp add: COMP_def seq_char)
       show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> COMP (COMP h g) f = COMP h (COMP g f)"
         using seq_char COMP_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
         by auto
     qed
 
     proposition is_category:
     shows "category COMP"
       ..
 
     text \<open>
       Functions \<open>Dom\<close>, \<open>Cod\<close>, and \<open>Map\<close> establish a correspondence between the
       arrows of the constructed category and the elements of the originally given
       parameters \<open>Obj\<close> and \<open>Hom\<close>.
     \<close>
 
     lemma Dom_in_Obj:
     assumes "arr f"
     shows "Dom f \<in> Obj"
       using assms arr_char by simp
 
     lemma Cod_in_Obj:
     assumes "arr f"
     shows "Cod f \<in> Obj"
       using assms arr_char by simp
 
     lemma Map_in_Hom:
     assumes "arr f"
     shows "Map f \<in> Hom (Dom f) (Cod f)"
       using assms arr_char by simp
 
     lemma MkArr_in_hom:
     assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
     shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
       using assms arr_char ide_MkIde
       by (simp add: in_codomains_char in_domains_char in_hom_def)
 
     text \<open>
       The next few results show that domains, codomains, and composition in the constructed
       category are as expected according to the just-given correspondence.
     \<close>
 
     lemma dom_char:
     shows "dom f = (if arr f then MkIde (Dom f) else null)"
       using dom_def in_domains_char dom_in_domains has_domain_iff_arr by auto
 
     lemma cod_char:
     shows "cod f = (if arr f then MkIde (Cod f) else null)"
       using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto
 
     lemma comp_char:
     shows "COMP g f = (if seq g f then
                          MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
                        else
                          null)"
       using COMP_def seq_char arr_char null_char by auto
 
     lemma in_hom_char:
     shows "in_hom f a b \<longleftrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
     proof
       show "in_hom f a b \<Longrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
         using arr_char dom_char cod_char by auto
       show "arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b \<Longrightarrow> in_hom f a b"
         using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
     qed
 
     lemma Dom_dom [simp]:
     assumes "arr f"
     shows "Dom (dom f) = Dom f"
       using assms MkArr_Map dom_char by simp
 
     lemma Cod_dom [simp]:
     assumes "arr f"
     shows "Cod (dom f) = Dom f"
       using assms MkArr_Map dom_char by simp
 
     lemma Dom_cod [simp]:
     assumes "arr f"
     shows "Dom (cod f) = Cod f"
       using assms MkArr_Map cod_char by simp
 
     lemma Cod_cod [simp]:
     assumes "arr f"
     shows "Cod (cod f) = Cod f"
       using assms MkArr_Map cod_char by simp
 
     lemma Map_dom [simp]:
     assumes "arr f"
     shows "Map (dom f) = Id (Dom f)"
       using assms MkArr_Map dom_char by simp
 
     lemma Map_cod [simp]:
     assumes "arr f"
     shows "Map (cod f) = Id (Cod f)"
       using assms MkArr_Map cod_char by simp
 
     lemma Map_ide:
     assumes "ide a"
     shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
       using assms ide_char dom_char [of a] Map_dom Map_cod ideD(1) by metis+
 
     (*
      * TODO: The next two ought to be simps, but they cause looping when they find themselves
      * in combination with dom_char and cod_char.
      *)
     lemma MkIde_Dom:
     assumes "arr a"
     shows "MkIde (Dom a) = dom a"
       using assms arr_char dom_char by (cases a, auto)
 
     lemma MkIde_Cod:
     assumes "arr a"
     shows "MkIde (Cod a) = cod a"
       using assms arr_char cod_char by (cases a, auto)
 
     lemma MkIde_Dom' [simp]:
     assumes "ide a"
     shows "MkIde (Dom a) = a"
       using assms MkIde_Dom by simp
 
     lemma MkIde_Cod' [simp]:
     assumes "ide a"
     shows "MkIde (Cod a) = a"
       using assms MkIde_Cod by simp
 
     lemma dom_MkArr [simp]:
     assumes "arr (MkArr A B F)"
     shows "dom (MkArr A B F) = MkIde A"
       using assms dom_char by simp
 
     lemma cod_MkArr [simp]:
     assumes "arr (MkArr A B F)"
     shows "cod (MkArr A B F) = MkIde B"
       using assms cod_char by simp
 
     lemma comp_MkArr [simp]:
     assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
     shows "COMP (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
       using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp
 
     text \<open>
       The set \<open>Obj\<close> of ``objects'' given as a parameter is in bijective correspondence
       (via function \<open>MkIde\<close>) with the set of identities of the resulting category.
     \<close>
 
     proposition bij_betw_ide_Obj:
     shows "MkIde \<in> Obj \<rightarrow> Collect ide"
     and "Dom \<in> Collect ide \<rightarrow> Obj"
     and "A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
     and "a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
     and "bij_betw Dom (Collect ide) Obj"
     proof -
       show "MkIde \<in> Obj \<rightarrow> Collect ide"
         using ide_MkIde by simp
       moreover show "Dom \<in> Collect ide \<rightarrow> Obj"
         using arr_char ideD(1) by simp
       moreover show "\<And>A. A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
         by simp
       moreover show "\<And>a. a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
         using MkIde_Dom by simp
       ultimately show "bij_betw Dom (Collect ide) Obj"
         using bij_betwI by blast
     qed
 
     text \<open>
       For each pair of identities \<open>a\<close> and \<open>b\<close>, the set \<open>Hom (Dom a) (Dom b)\<close> is in
       bijective correspondence (via function \<open>MkArr (Dom a) (Dom b)\<close>) with the
       ``hom-set'' \<open>hom a b\<close> of the resulting category.
     \<close>
 
     proposition bij_betw_hom_Hom:
     assumes "ide a" and "ide b"
     shows "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
     and "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
     and "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
     and "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
     and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
     proof -
       show "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
         using Map_in_Hom cod_char dom_char in_hom_char by fastforce
       moreover show "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
         using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
       moreover show "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
         using MkArr_Map by auto
       moreover show "\<And>F. F \<in> Hom (Dom a) (Dom b)
                             \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
         by simp
       ultimately show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
         using bij_betwI by blast
     qed
 
     lemma arr_eqI:
     assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
     shows "t = t'"
       using assms MkArr_Map by metis
 
   end
 
   sublocale concrete_category \<subseteq> category COMP
     using is_category by auto
 
 end
diff --git a/thys/Category3/FreeCategory.thy b/thys/Category3/FreeCategory.thy
--- a/thys/Category3/FreeCategory.thy
+++ b/thys/Category3/FreeCategory.thy
@@ -1,569 +1,569 @@
 (*  Title:       FreeCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter FreeCategory
 
 theory FreeCategory
 imports Category ConcreteCategory
 begin
 
   text\<open>
     This theory defines locales for constructing the free category generated by
     a graph, as well as some special cases, including the discrete category generated
     by a set of objects, the ``quiver'' generated by a set of arrows, and a ``parallel pair''
     of arrows, which is the diagram shape required for equalizers.
     Other diagram shapes can be constructed in a similar fashion.
 \<close>
 
   section Graphs
 
   text\<open>
     The following locale gives a definition of graphs in a traditional style.
 \<close>
 
   locale graph =
   fixes Obj :: "'obj set"
   and Arr :: "'arr set"
   and Dom :: "'arr \<Rightarrow> 'obj"
   and Cod :: "'arr \<Rightarrow> 'obj"
   assumes dom_is_obj: "x \<in> Arr \<Longrightarrow> Dom x \<in> Obj"
   and cod_is_obj: "x \<in> Arr \<Longrightarrow> Cod x \<in> Obj"
   begin
 
     text\<open>
       The list of arrows @{term p} forms a path from object @{term x} to object @{term y}
       if the domains and codomains of the arrows match up in the expected way.
 \<close>
 
     definition path
     where "path x y p \<equiv> (p = [] \<and> x = y \<and> x \<in> Obj) \<or>
                         (p \<noteq> [] \<and> x = Dom (hd p) \<and> y = Cod (last p) \<and>
                         (\<forall>n. n \<ge> 0 \<and> n < length p \<longrightarrow> nth p n \<in> Arr) \<and>
                         (\<forall>n. n \<ge> 0 \<and> n < (length p)-1 \<longrightarrow> Cod (nth p n) = Dom (nth p (n+1))))"
 
     lemma path_Obj:
     assumes "x \<in> Obj"
     shows "path x x []"
       using assms path_def by simp
 
     lemma path_single_Arr:
     assumes "x \<in> Arr"
     shows "path (Dom x) (Cod x) [x]"
       using assms path_def by simp
 
     lemma path_concat:
     assumes "path x y p" and "path y z q"
     shows "path x z (p @ q)"
     proof -
       have "p = [] \<or> q = [] \<Longrightarrow> ?thesis"
         using assms path_def by auto
       moreover have "p \<noteq> [] \<and> q \<noteq> [] \<Longrightarrow> ?thesis"
       proof -
         assume pq: "p \<noteq> [] \<and> q \<noteq> []"
         have Cod_last: "Cod (last p) = Cod (nth (p @ q) ((length p)-1))"
           using assms pq by (simp add: last_conv_nth nth_append)
         moreover have Dom_hd: "Dom (hd q) = Dom (nth (p @ q) (length p))"
           using assms pq by (simp add: hd_conv_nth less_not_refl2 nth_append)
         show ?thesis
         proof -
           have 1: "\<And>n. n \<ge> 0 \<and> n < length (p @ q) \<Longrightarrow> nth (p @ q) n \<in> Arr"
           proof -
             fix n
             assume n: "n \<ge> 0 \<and> n < length (p @ q)"
             have "(n \<ge> 0 \<and> n < length p) \<or> (n \<ge> length p \<and> n < length (p @ q))"
               using n by auto
             thus "nth (p @ q) n \<in> Arr"
               using assms pq nth_append path_def le_add_diff_inverse length_append
                     less_eq_nat.simps(1) nat_add_left_cancel_less
               by metis
           qed
           have 2: "\<And>n. n \<ge> 0 \<and> n < length (p @ q) - 1 \<Longrightarrow>
                                     Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
           proof -
             fix n
             assume n: "n \<ge> 0 \<and> n < length (p @ q) - 1"
             have 1: "(n \<ge> 0 \<and> n < (length p) - 1) \<or> (n \<ge> length p \<and> n < length (p @ q) - 1)
                        \<or> n = (length p) - 1"
               using n by auto
             thus "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
             proof -
               have "n \<ge> 0 \<and> n < (length p) - 1 \<Longrightarrow> ?thesis"
                 using assms pq nth_append path_def by (metis add_lessD1 less_diff_conv)
               moreover have "n = (length p) - 1 \<Longrightarrow> ?thesis"
                 using assms pq nth_append path_def Dom_hd Cod_last by simp
               moreover have "n \<ge> length p \<and> n < length (p @ q) - 1 \<Longrightarrow> ?thesis"
               proof -
                 assume 1: "n \<ge> length p \<and> n < length (p @ q) - 1"
                 have "Cod (nth (p @ q) n) = Cod (nth q (n - length p))"
                   using 1 nth_append leD by metis
                 also have "... = Dom (nth q (n - length p + 1))"
                   using 1 assms(2) path_def by auto
                 also have "... = Dom (nth (p @ q) (n + 1))"
                   using 1 nth_append
                   by (metis Nat.add_diff_assoc2 ex_least_nat_le le_0_eq le_add1 le_neq_implies_less
                             le_refl le_trans length_0_conv pq)
                 finally show "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n + 1))" by auto
               qed
               ultimately show ?thesis using 1 by auto
             qed
           qed
           show ?thesis
             unfolding path_def using assms pq path_def hd_append2 Cod_last Dom_hd 1 2
             by simp
         qed
       qed
       ultimately show ?thesis by auto
     qed
 
   end
 
   section "Free Categories"
 
   text\<open>
     The free category generated by a graph has as its arrows all triples @{term "MkArr x y p"},
     where @{term x} and @{term y} are objects and @{term p} is a path from @{term x} to @{term y}.
     We construct it here an instance of the general construction given by the
     @{locale concrete_category} locale.
 \<close>
 
   locale free_category =
     G: graph Obj Arr D C
   for Obj :: "'obj set"
   and Arr :: "'arr set"
   and D :: "'arr \<Rightarrow> 'obj"
   and C :: "'arr \<Rightarrow> 'obj"
   begin
 
     type_synonym ('o, 'a) arr = "('o, 'a list) concrete_category.arr"
 
     sublocale concrete_category \<open>Obj :: 'obj set\<close> \<open>\<lambda>x y. Collect (G.path x y)\<close>
       \<open>\<lambda>_. []\<close> \<open>\<lambda>_ _ _ g f. f @ g\<close>
       using G.path_Obj G.path_concat
       by (unfold_locales, simp_all)
 
     abbreviation comp      (infixr "\<cdot>" 55)
     where "comp \<equiv> COMP"
     notation in_hom     ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     abbreviation Path
     where "Path \<equiv> Map"
 
     lemma arr_single [simp]:
     assumes "x \<in> Arr"
     shows "arr (MkArr (D x) (C x) [x])"
       using assms
       by (simp add: G.cod_is_obj G.dom_is_obj G.path_single_Arr)
 
   end
 
   section "Discrete Categories"
 
   text\<open>
     A discrete category is a category in which every arrow is an identity.
     We could construct it as the free category generated by a graph with no
     arrows, but it is simpler just to apply the @{locale concrete_category}
     construction directly.
 \<close>
 
   locale discrete_category =
   fixes Obj :: "'obj set"
   begin
 
     type_synonym 'o arr = "('o, unit) concrete_category.arr"
 
     sublocale concrete_category \<open>Obj :: 'obj set\<close> \<open>\<lambda>x y. if x = y then {x} else {}\<close>
       \<open>\<lambda>x. x\<close> \<open>\<lambda>_ _ x _ _. x\<close>
       apply unfold_locales
           apply simp_all
         apply (metis empty_iff)
        apply (metis empty_iff singletonD)
       by (metis empty_iff singletonD)
 
     abbreviation comp      (infixr "\<cdot>" 55)
     where "comp \<equiv> COMP"
     notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     lemma is_discrete:
     shows "arr f \<longleftrightarrow> ide f"
-      using ide_char arr_char by simp
+      using ide_char\<^sub>C\<^sub>C arr_char by simp
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> Dom f \<in> Obj \<and> f = MkIde (Dom f)"
       using is_discrete
-      by (metis (no_types, lifting) cod_char dom_char ide_MkIde ide_char ide_char')
+      by (metis (no_types, lifting) cod_char dom_char ide_MkIde ide_char\<^sub>C\<^sub>C ide_char')
 
     lemma arr_char':
     shows "arr f \<longleftrightarrow> f \<in> MkIde ` Obj"
       using arr_char image_iff by auto
 
     lemma dom_char:
     shows "dom f = (if arr f then f else null)"
       using dom_char is_discrete by simp
 
     lemma cod_char:
     shows "cod f = (if arr f then f else null)"
       using cod_char is_discrete by simp
 
     lemma in_hom_char:
     shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> arr f \<and> f = a \<and> f = b"
       using is_discrete by auto
 
     lemma seq_char:
     shows "seq g f \<longleftrightarrow> arr f \<and> f = g"
       using is_discrete
       by (metis (no_types, lifting) comp_arr_dom seqE dom_char)
     
     lemma comp_char:
     shows "g \<cdot> f = (if seq g f then f else null)"
     proof -
       have "\<not> seq g f \<Longrightarrow> ?thesis"
         using comp_char by presburger
       moreover have "seq g f \<Longrightarrow> ?thesis"
         using seq_char comp_char comp_arr_ide is_discrete
         by (metis (no_types, lifting))
       ultimately show ?thesis by blast
     qed
 
   end
 
   text\<open>
     The empty category is the discrete category generated by an empty set of objects.
 \<close>
 
   locale empty_category =
     discrete_category "{} :: unit set"
   begin
 
     lemma is_empty:
     shows "\<not>arr f"
       using arr_char by simp
 
   end
 
   section "Quivers"
 
   text\<open>
     A quiver is a two-object category whose non-identity arrows all point in the
     same direction.  A quiver is specified by giving the set of these non-identity arrows.
 \<close>
 
   locale quiver =
   fixes Arr :: "'arr set"
   begin
 
     type_synonym 'a arr = "(unit, 'a) concrete_category.arr"
 
     sublocale free_category "{False, True}" Arr "\<lambda>_. False" "\<lambda>_. True"
       by (unfold_locales, simp_all)
 
     notation comp                  (infixr "\<cdot>" 55)
     notation in_hom                ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     definition Zero
     where "Zero \<equiv> MkIde False"
 
     definition One
     where "One \<equiv> MkIde True"
 
     definition fromArr
     where "fromArr x \<equiv> if x \<in> Arr then MkArr False True [x] else null"
 
     definition toArr
     where "toArr f \<equiv> hd (Path f)"
 
     lemma ide_char:
     shows "ide f \<longleftrightarrow> f = Zero \<or> f = One"
     proof -
       have "ide f \<longleftrightarrow> f = MkIde False \<or> f = MkIde True"
-        using ide_char concrete_category.MkIde_Dom' concrete_category_axioms by fastforce
+        using ide_char\<^sub>C\<^sub>C concrete_category.MkIde_Dom' concrete_category_axioms by fastforce
       thus ?thesis
         using comp_def Zero_def One_def by simp
     qed
 
     lemma arr_char':
     shows "arr f \<longleftrightarrow> f =
            MkIde False \<or> f = MkIde True \<or> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
     proof
       assume f: "f = MkIde False \<or> f = MkIde True \<or> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
       show "arr f" using f by auto
       next
       assume f: "arr f"
       have "\<not>(f = MkIde False \<or> f = MkIde True) \<Longrightarrow> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
       proof -
         assume f': "\<not>(f = MkIde False \<or> f = MkIde True)"
         have 0: "Dom f = False \<and> Cod f = True"
           using f f' arr_char G.path_def MkArr_Map by fastforce
         have 1: "f = MkArr False True (Path f)"
           using f 0 arr_char MkArr_Map by force
         moreover have "length (Path f) = 1"
         proof -
           have "length (Path f) \<noteq> 0"
             using f f' 0 arr_char G.path_def by simp
           moreover have "\<And>x y p. length p > 1 \<Longrightarrow> \<not> G.path x y p"
             using G.path_def less_diff_conv by fastforce
           ultimately show ?thesis
             using f arr_char
             by (metis less_one linorder_neqE_nat mem_Collect_eq)
         qed
         moreover have "\<And>p. length p = 1 \<longleftrightarrow> (\<exists>x. p = [x])"
           by (auto simp: length_Suc_conv)
         ultimately have "\<exists>x. x \<in> Arr \<and> Path f = [x]"
           using f G.path_def arr_char
           by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) le_eq_less_or_eq
               less_numeral_extra(1) mem_Collect_eq nth_Cons_0)
         thus "f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
           using 1 by auto
       qed
       thus "f = MkIde False \<or> f = MkIde True \<or> f \<in> (\<lambda>x. MkArr False True [x]) ` Arr"
         by auto
     qed
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> f = Zero \<or> f = One \<or> f \<in> fromArr ` Arr"
       using arr_char' Zero_def One_def fromArr_def by simp
 
     lemma dom_char:
     shows "dom f = (if arr f then
                       if f = One then One else Zero
                     else null)"
     proof -
       have "\<not> arr f \<Longrightarrow> ?thesis"
         using dom_char by simp
       moreover have "arr f \<Longrightarrow> ?thesis"
       proof -
         assume f: "arr f"
         have 1: "dom f = MkIde (Dom f)"
           using f dom_char by simp
         have "f = One \<Longrightarrow> ?thesis"
           using f 1 One_def by (metis (full_types) Dom.simps(1))
         moreover have "f = Zero \<Longrightarrow> ?thesis"
           using f 1 Zero_def by (metis (full_types) Dom.simps(1))
         moreover have "f \<in> fromArr ` Arr \<Longrightarrow> ?thesis"
           using f fromArr_def G.path_def Zero_def calculation(1) by auto
         ultimately show ?thesis
           using f arr_char by blast
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma cod_char:
     shows "cod f = (if arr f then
                       if f = Zero then Zero else One
                     else null)"
     proof -
       have "\<not> arr f \<Longrightarrow> ?thesis"
         using cod_char by simp
       moreover have "arr f \<Longrightarrow> ?thesis"
       proof -
         assume f: "arr f"
         have 1: "cod f = MkIde (Cod f)"
           using f cod_char by simp
         have "f = One \<Longrightarrow> ?thesis"
           using f 1 One_def by (metis (full_types) Cod.simps(1) f)
         moreover have "f = Zero \<Longrightarrow> ?thesis"
           using f 1 Zero_def by (metis (full_types) Cod.simps(1) f)
         moreover have "f \<in> fromArr ` Arr \<Longrightarrow> ?thesis"
           using f fromArr_def G.path_def One_def calculation(2) by auto
         ultimately show ?thesis
           using f arr_char by blast
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma seq_char:
     shows "seq g f \<longleftrightarrow> arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
     proof
       assume gf: "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
       show "seq g f"
         using gf dom_char cod_char by auto
       next
       assume gf: "seq g f"
       hence 1: "arr f \<and> arr g \<and> dom g = cod f" by auto
       have "Cod f = False \<Longrightarrow> f = Zero"
         using gf 1 arr_char [of f] G.path_def Zero_def One_def cod_char Dom_cod
         by (metis (no_types, lifting) Dom.simps(1))
       moreover have "Cod f = True \<Longrightarrow> g = One"
         using gf 1 arr_char [of f] G.path_def Zero_def One_def dom_char Dom_cod
         by (metis (no_types, lifting) Dom.simps(1))
       moreover have "\<not>(f = MkIde False \<and> g = MkIde True)"
         using 1 by auto
       ultimately show "arr g \<and> arr f \<and> ((f = Zero \<and> g \<noteq> One) \<or> (f \<noteq> Zero \<and> g = One))"
         using gf arr_char One_def Zero_def by blast
     qed
 
     lemma not_ide_fromArr:
     shows "\<not> ide (fromArr x)"
       using fromArr_def ide_char ide_def Zero_def One_def
       by (metis Cod.simps(1) Dom.simps(1))
 
     lemma in_hom_char:
     shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> (a = Zero \<and> b = Zero \<and> f = Zero) \<or>
                             (a = One \<and> b = One \<and> f = One) \<or>
                             (a = Zero \<and> b = One \<and> f \<in> fromArr ` Arr)"
     proof -
       have "f = Zero \<Longrightarrow> ?thesis"
         using arr_char' [of f] ide_char'
         by (metis (no_types, lifting) Zero_def category.in_homE category.in_homI
             cod_MkArr dom_MkArr imageE is_category not_ide_fromArr)
       moreover have "f = One \<Longrightarrow> ?thesis"
         using arr_char' [of f] ide_char'
         by (metis (no_types, lifting) One_def category.in_homE category.in_homI
             cod_MkArr dom_MkArr image_iff is_category not_ide_fromArr)
       moreover have "f \<in> fromArr ` Arr \<Longrightarrow> ?thesis"
       proof -
         assume f: "f \<in> fromArr ` Arr"
         have 1: "arr f" using f arr_char by simp
         moreover have "dom f = Zero \<and> cod f = One"
           using f 1 arr_char dom_char cod_char fromArr_def
           by (metis (no_types, lifting) ide_char imageE not_ide_fromArr)
         ultimately have "in_hom f Zero One" by auto
         thus "in_hom f a b \<longleftrightarrow> (a = Zero \<and> b = Zero \<and> f = Zero \<or>
                                            a = One \<and> b = One \<and> f = One \<or>
                                            a = Zero \<and> b = One \<and> f \<in> fromArr ` Arr)"
           using f ide_char by auto
       qed
       ultimately show ?thesis
         using arr_char [of f] by fast
     qed
 
     lemma Zero_not_eq_One [simp]:
     shows "Zero \<noteq> One"
       by (simp add: One_def Zero_def)
 
     lemma Zero_not_eq_fromArr [simp]:
     shows "Zero \<notin> fromArr ` Arr"
       using ide_char not_ide_fromArr
       by (metis (no_types, lifting) image_iff)
 
     lemma One_not_eq_fromArr [simp]:
     shows "One \<notin> fromArr ` Arr"
       using ide_char not_ide_fromArr
       by (metis (no_types, lifting) image_iff)
 
     lemma comp_char:
     shows "g \<cdot> f = (if seq g f then
                       if f = Zero then g else if g = One then f else null
                     else null)"
     proof -
       have "seq g f \<Longrightarrow> f = Zero \<Longrightarrow> g \<cdot> f = g"
         using seq_char comp_char [of g f] Zero_def dom_char cod_char comp_arr_dom
         by auto
       moreover have "seq g f \<Longrightarrow> g = One \<Longrightarrow> g \<cdot> f = f"
         using seq_char comp_char [of g f] One_def dom_char cod_char comp_cod_arr
         by simp
       moreover have "seq g f \<Longrightarrow> f \<noteq> Zero \<Longrightarrow> g \<noteq> One \<Longrightarrow> g \<cdot> f = null"
         using seq_char Zero_def One_def by simp
       moreover have "\<not>seq g f \<Longrightarrow> g \<cdot> f = null"
         using comp_char ext by fastforce
       ultimately show ?thesis by argo
     qed
 
     lemma comp_simp [simp]:
     assumes "seq g f"
     shows "f = Zero \<Longrightarrow> g \<cdot> f = g"
     and "g = One \<Longrightarrow> g \<cdot> f = f"
       using assms seq_char comp_char by metis+
 
     lemma arr_fromArr:
     assumes "x \<in> Arr"
     shows "arr (fromArr x)"
       using assms fromArr_def arr_char image_eqI by simp
 
     lemma toArr_in_Arr:
     assumes "arr f" and "\<not>ide f"
     shows "toArr f \<in> Arr"
     proof -
       have "\<And>a. a \<in> Arr \<Longrightarrow> Path (fromArr a) = [a]"
         using fromArr_def arr_char by simp
       hence "hd (Path f) \<in> Arr"
         using assms arr_char ide_char by auto
       thus ?thesis
         by (simp add: toArr_def)
     qed
 
     lemma toArr_fromArr [simp]:
     assumes "x \<in> Arr"
     shows "toArr (fromArr x) = x"
       using assms fromArr_def toArr_def
       by (simp add: toArr_def)
 
     lemma fromArr_toArr [simp]:
     assumes "arr f" and "\<not>ide f"
     shows "fromArr (toArr f) = f"
       using assms fromArr_def toArr_def arr_char ide_char toArr_fromArr by auto
 
   end
 
   section "Parallel Pairs"
 
   text\<open>
     A parallel pair is a quiver with two non-identity arrows.
     It is important in the definition of equalizers.
 \<close>
 
   locale parallel_pair =
     quiver "{False, True} :: bool set"
   begin
 
     typedef arr = "UNIV :: bool quiver.arr set" ..
 
     definition j0
     where "j0 \<equiv> fromArr False"
 
     definition j1
     where "j1 \<equiv> fromArr True"
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> f = Zero \<or> f = One \<or> f = j0 \<or> f = j1"
       using arr_char j0_def j1_def by simp
 
     lemma dom_char:
     shows "dom f = (if f = j0 \<or> f = j1 then Zero else if arr f then f else null)"
       using arr_char dom_char j0_def j1_def
       by (metis ide_char not_ide_fromArr)
 
     lemma cod_char:
     shows "cod f = (if f = j0 \<or> f = j1 then One else if arr f then f else null)"
       using arr_char cod_char j0_def j1_def
       by (metis ide_char not_ide_fromArr)
 
     lemma j0_not_eq_j1 [simp]:
     shows "j0 \<noteq> j1"
       using j0_def j1_def
       by (metis insert_iff toArr_fromArr)
 
     lemma Zero_not_eq_j0 [simp]:
     shows "Zero \<noteq> j0"
       using Zero_def j0_def Zero_not_eq_fromArr by auto
 
     lemma Zero_not_eq_j1 [simp]:
     shows "Zero \<noteq> j1"
       using Zero_def j1_def Zero_not_eq_fromArr by auto
 
     lemma One_not_eq_j0 [simp]:
     shows "One \<noteq> j0"
       using One_def j0_def One_not_eq_fromArr by auto
 
     lemma One_not_eq_j1 [simp]:
     shows "One \<noteq> j1"
       using One_def j1_def One_not_eq_fromArr by auto
 
     lemma dom_simp [simp]:
     shows "dom Zero = Zero"
     and "dom One = One"
     and "dom j0 = Zero"
     and "dom j1 = Zero"
       using dom_char arr_char by auto
 
     lemma cod_simp [simp]:
     shows "cod Zero = Zero"
     and "cod One = One"
     and "cod j0 = One"
     and "cod j1 = One"
       using cod_char arr_char by auto
 
   end
 
 end
diff --git a/thys/Category3/FunctorCategory.thy b/thys/Category3/FunctorCategory.thy
--- a/thys/Category3/FunctorCategory.thy
+++ b/thys/Category3/FunctorCategory.thy
@@ -1,815 +1,815 @@
 (*  Title:       FunctorCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter FunctorCategory
 
 theory FunctorCategory
 imports ConcreteCategory BinaryFunctor
 begin
 
   text\<open>
     The functor category \<open>[A, B]\<close> is the category whose objects are functors
     from @{term A} to @{term B} and whose arrows correspond to natural transformations
     between these functors.
 \<close>
 
   section "Construction"
 
   text\<open>
     Since the arrows of a functor category cannot (in the context of the present development)
     be directly identified with natural transformations, but rather only with natural
     transformations that have been equipped with their domain and codomain functors,
     and since there is no natural value to serve as @{term null},
     we use the general-purpose construction given by @{locale concrete_category} to define
     this category.
 \<close>
 
   locale functor_category =
     A: category A +
     B: category B
   for A :: "'a comp"     (infixr "\<cdot>\<^sub>A" 55)
   and B :: "'b comp"     (infixr "\<cdot>\<^sub>B" 55)
   begin
 
     notation A.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A _\<guillemotright>")
     notation B.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     type_synonym ('aa, 'bb) arr = "('aa \<Rightarrow> 'bb, 'aa \<Rightarrow> 'bb) concrete_category.arr"
 
     sublocale concrete_category \<open>Collect (functor A B)\<close>
       \<open>\<lambda>F G. Collect (natural_transformation A B F G)\<close> \<open>\<lambda>F. F\<close>
       \<open>\<lambda>F G H \<tau> \<sigma>. vertical_composite.map A B \<sigma> \<tau>\<close>
       using vcomp_assoc
       apply (unfold_locales, simp_all)
     proof -
       fix F G H \<sigma> \<tau>
       assume F: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F"
       assume G: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) G"
       assume H: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) H"
       assume \<sigma>: "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F G \<sigma>"
       assume \<tau>: "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) G H \<tau>"
       interpret F: "functor" A B F using F by simp
       interpret G: "functor" A B G using G by simp
       interpret H: "functor" A B H using H by simp
       interpret \<sigma>: natural_transformation A B F G \<sigma>
         using \<sigma> by simp
       interpret \<tau>: natural_transformation A B G H \<tau>
         using \<tau> by simp
       interpret \<tau>\<sigma>: vertical_composite A B F G H \<sigma> \<tau>
         ..
       show "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F H (vertical_composite.map (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) \<sigma> \<tau>)"
         using \<tau>\<sigma>.map_def \<tau>\<sigma>.is_natural_transformation by simp
     qed
 
     lemma is_concrete_category:
     shows "concrete_category (Collect (functor A B))
              (\<lambda>F G. Collect (natural_transformation A B F G)) (\<lambda>F. F)
              (\<lambda>F G H \<tau> \<sigma>. vertical_composite.map A B \<sigma> \<tau>)"
       ..
 
     abbreviation comp      (infixr "\<cdot>" 55)
     where "comp \<equiv> COMP"
     notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     lemma is_category:
     shows "category comp"
       ..
 
     lemma arrI [intro]:
     assumes "f \<noteq> null" and "natural_transformation A B (Dom f) (Cod f) (Map f)"
     shows "arr f"
       using assms arr_char null_char
       by (simp add: natural_transformation_def)
 
     lemma arrE [elim]:
     assumes "arr f"
     and "f \<noteq> null \<Longrightarrow> natural_transformation A B (Dom f) (Cod f) (Map f) \<Longrightarrow> T"
     shows T
       using assms arr_char null_char by simp
 
     lemma arr_MkArr [iff]:
     shows "arr (MkArr F G \<tau>) \<longleftrightarrow> natural_transformation A B F G \<tau>"
       using arr_char null_char arr_MkArr natural_transformation_def by fastforce
 
     lemma ide_char [iff]:
     shows "ide t \<longleftrightarrow> t \<noteq> null \<and> functor A B (Map t) \<and> Dom t = Map t \<and> Cod t = Map t"
-      using ide_char null_char by fastforce
+      using ide_char\<^sub>C\<^sub>C null_char by fastforce
 
   end
 
   section "Additional Properties"
 
   text\<open>
     In this section some additional facts are proved, which make it easier to
     work with the @{term "functor_category"} locale.
 \<close>
 
   context functor_category
   begin
 
     lemma Map_comp [simp]:
     assumes "seq t' t" and "A.seq a' a"
     shows "Map (t' \<cdot> t) (a' \<cdot>\<^sub>A a) = Map t' a' \<cdot>\<^sub>B Map t a"
     proof -
       interpret t: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
         using assms(1) arr_char seq_char by blast
       interpret t': natural_transformation A B \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t'\<close>
         using assms(1) arr_char seq_char by force 
       interpret t'ot: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
       show ?thesis
         using B.comp_assoc assms seq_char t'.preserves_comp_2 t'ot.map_simp_2 by auto
     qed
 
     lemma Map_comp':
     assumes "seq t' t"
     shows "Map (t' \<cdot> t) = vertical_composite.map A B (Map t) (Map t')"
     proof -
       interpret t: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
         using assms(1) arr_char seq_char by blast
       interpret t': natural_transformation A B \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t'\<close>
         using assms(1) arr_char seq_char by force 
       interpret t'ot: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
       show ?thesis
         using assms(1) seq_char t'ot.natural_transformation_axioms by simp
     qed
 
     lemma MkArr_eqI [intro]:
     assumes "arr (MkArr F G \<tau>)"
     and "F = F'" and "G = G'" and "\<tau> = \<tau>'"
     shows "MkArr F G \<tau> = MkArr F' G' \<tau>'"
       using assms arr_eqI by simp
 
     lemma MkArr_eqI' [intro]:
     assumes "arr (MkArr F G \<tau>)" and "\<tau> = \<tau>'"
     shows "MkArr F G \<tau> = MkArr F G \<tau>'"
       using assms arr_eqI by simp
 
     lemma iso_char [iff]:
     shows "iso t \<longleftrightarrow> t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
     proof
       assume t: "iso t"
       show "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
       proof
         show "t \<noteq> null" using t arr_char iso_is_arr by auto
         from t obtain t' where t': "inverse_arrows t t'" by blast
         interpret \<tau>: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
           using t arr_char iso_is_arr by auto
         interpret \<tau>': natural_transformation A B \<open>Cod t\<close> \<open>Dom t\<close> \<open>Map t'\<close>
           using t' arr_char dom_char seq_char
           by (metis arrE ide_compE inverse_arrowsE)
         interpret \<tau>'o\<tau>: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Dom t\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
         interpret \<tau>o\<tau>': vertical_composite A B \<open>Cod t\<close> \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t'\<close> \<open>Map t\<close> ..
         show "natural_isomorphism A B (Dom t) (Cod t) (Map t)"
         proof
           fix a
           assume a: "A.ide a"
           show "B.iso (Map t a)"
           proof
             have 1: "\<tau>'o\<tau>.map = Dom t \<and> \<tau>o\<tau>'.map = Cod t"
               using t t'
               by (metis (no_types, lifting) Map_dom concrete_category.Map_comp
                   concrete_category_axioms ide_compE inverse_arrowsE seq_char)
             show "B.inverse_arrows (Map t a) (Map t' a)"
               using a 1 \<tau>o\<tau>'.map_simp_ide \<tau>'o\<tau>.map_simp_ide \<tau>.F.preserves_ide \<tau>.G.preserves_ide
               by auto
           qed
         qed
       qed
       next
       assume t: "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
       show "iso t"
       proof
         interpret \<tau>: natural_isomorphism A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
           using t by auto
         interpret \<tau>': inverse_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close> ..
         have 1: "vertical_composite.map A B (Map t) \<tau>'.map = Dom t \<and>
                  vertical_composite.map A B \<tau>'.map (Map t) = Cod t"
           using \<tau>.natural_isomorphism_axioms vertical_composite_inverse_iso
                 vertical_composite_iso_inverse
           by blast
         show "inverse_arrows t (MkArr (Cod t) (Dom t) (\<tau>'.map))"
         proof
           show 2: "ide (MkArr (Cod t) (Dom t) \<tau>'.map \<cdot> t)"
             using t 1
             by (metis (no_types, lifting) MkArr_Map MkIde_Dom \<tau>'.natural_transformation_axioms
                 \<tau>.natural_transformation_axioms arrI arr_MkArr comp_MkArr ide_dom)
           show "ide (t \<cdot> MkArr (Cod t) (Dom t) \<tau>'.map)"
             using t 1 2
             by (metis Dom.simps(1) Map.simps(1) \<tau>.natural_transformation_axioms arrI
                 cod_char cod_comp comp_char ide_char' ide_compE)
         qed
       qed
     qed
 
   end
 
   section "Evaluation Functor"
 
   text\<open>
     This section defines the evaluation map that applies an arrow of the functor
     category \<open>[A, B]\<close> to an arrow of @{term A} to obtain an arrow of @{term B}
     and shows that it is functorial.
 \<close>
 
   locale evaluation_functor =
     A: category A +
     B: category B +
     A_B: functor_category A B +
     A_BxA: product_category A_B.comp A
   for A :: "'a comp"          (infixr "\<cdot>\<^sub>A" 55)
   and B :: "'b comp"          (infixr "\<cdot>\<^sub>B" 55)
   begin
 
     notation A_B.comp         (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]" 55)
     notation A_BxA.comp       (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A" 55)
     notation A_B.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
     notation A_BxA.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A _\<guillemotright>")
 
     definition map
     where "map Fg \<equiv> if A_BxA.arr Fg then A_B.Map (fst Fg) (snd Fg) else B.null"
 
     lemma map_simp:
     assumes "A_BxA.arr Fg"
     shows "map Fg = A_B.Map (fst Fg) (snd Fg)"
       using assms map_def by auto
 
     lemma is_functor:
     shows "functor A_BxA.comp B map"
     proof
       show "\<And>Fg. \<not> A_BxA.arr Fg \<Longrightarrow> map Fg = B.null"
         using map_def by auto
       fix Fg
       assume Fg: "A_BxA.arr Fg"
       let ?F = "fst Fg" and ?g = "snd Fg"
       have F: "A_B.arr ?F" using Fg by auto
       have g: "A.arr ?g" using Fg by auto
       have DomF: "A_B.Dom ?F = A_B.Map (A_B.dom ?F)" using F by simp
       have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)" using F by simp
       interpret F: natural_transformation A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Map ?F\<close>
         using Fg A_B.arr_char [of ?F] by blast
       show "B.arr (map Fg)" using Fg map_def by auto
       show "B.dom (map Fg) = map (A_BxA.dom Fg)"
         using g Fg map_def DomF
         by (metis (no_types, lifting) A_BxA.arr_dom A_BxA.dom_simp F.preserves_dom
             fst_conv snd_conv)
       show "B.cod (map Fg) = map (A_BxA.cod Fg)"
         using g Fg map_def CodF
         by (metis (no_types, lifting) A_BxA.arr_cod A_BxA.cod_simp F.preserves_cod
             fst_conv snd_conv)
       next
       fix Fg Fg'
       assume 1: "A_BxA.seq Fg' Fg"
       let ?F = "fst Fg" and ?g = "snd Fg"
       let ?F' = "fst Fg'" and ?g' = "snd Fg'"
       have F': "A_B.arr ?F'" using 1 A_BxA.seqE by blast
       have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)"
         using 1 by (metis A_B.Map_cod A_B.seqE A_BxA.seqE)
       have DomF': "A_B.Dom ?F' = A_B.Map (A_B.dom ?F')"
         using F' by simp
       have seq_F'F: "A_B.seq ?F' ?F" using 1 by blast
       have seq_g'g: "A.seq ?g' ?g" using 1 by blast
       interpret F: natural_transformation A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Map ?F\<close>
         using 1 A_B.arr_char by blast
       interpret F': natural_transformation A B \<open>A_B.Cod ?F\<close> \<open>A_B.Cod ?F'\<close> \<open>A_B.Map ?F'\<close>
         using 1 A_B.arr_char seq_F'F CodF DomF' A_B.seqE
         by (metis mem_Collect_eq)
       interpret F'oF: vertical_composite A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Cod ?F'\<close>
                                              \<open>A_B.Map ?F\<close> \<open>A_B.Map ?F'\<close> ..
       show "map (Fg' \<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A Fg) = map Fg' \<cdot>\<^sub>B map Fg"
         unfolding map_def
         using 1 seq_F'F seq_g'g by auto
     qed
 
   end
 
   sublocale evaluation_functor \<subseteq> "functor" A_BxA.comp B map
     using is_functor by auto
   sublocale evaluation_functor \<subseteq> binary_functor A_B.comp A B map ..
 
   section "Currying"
 
   text\<open>
     This section defines the notion of currying of a natural transformation
     between binary functors, to obtain a natural transformation between
     functors into a functor category, along with the inverse operation of uncurrying.
     We have only proved here what is needed to establish the results
     in theory \<open>Limit\<close> about limits in functor categories and have not
     attempted to fully develop the functoriality and naturality properties of
     these notions.
 \<close>
 
   locale currying =
   A1: category A1 +
   A2: category A2 +
   B: category B
   for A1 :: "'a1 comp"           (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
   and A2 :: "'a2 comp"           (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
   and B :: "'b comp"             (infixr "\<cdot>\<^sub>B" 55)
   begin
 
     interpretation A1xA2: product_category A1 A2 ..
     interpretation A2_B: functor_category A2 B ..
     interpretation A2_BxA2: product_category A2_B.comp A2 ..
     interpretation E: evaluation_functor A2 B ..
 
     notation A1xA2.comp          (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
     notation A2_B.comp           (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>]" 55)
     notation A2_BxA2.comp        (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A\<^sub>2" 55)
     notation A1xA2.in_hom        ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
     notation A2_B.in_hom         ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
     notation A2_BxA2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
 
     text\<open>
       A proper definition for @{term curry} requires that it be parametrized by
       binary functors @{term F} and @{term G} that are the domain and codomain
       of the natural transformations to which it is being applied.
       Similar parameters are not needed in the case of @{term uncurry}.
 \<close>
 
     definition curry :: "('a1 \<times> 'a2 \<Rightarrow> 'b) \<Rightarrow> ('a1 \<times> 'a2 \<Rightarrow> 'b) \<Rightarrow> ('a1 \<times> 'a2 \<Rightarrow> 'b)
                            \<Rightarrow> 'a1 \<Rightarrow> ('a2, 'b) A2_B.arr"
     where "curry F G \<tau> f1 = (if A1.arr f1 then
                                A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                           (\<lambda>f2. \<tau> (f1, f2))
                              else A2_B.null)"
 
     definition uncurry :: "('a1 \<Rightarrow> ('a2, 'b) A2_B.arr) \<Rightarrow> 'a1 \<times> 'a2 \<Rightarrow> 'b"
     where "uncurry \<tau> f \<equiv> if A1xA2.arr f then E.map (\<tau> (fst f), snd f) else B.null"
 
     lemma curry_simp:
     assumes "A1.arr f1"
     shows "curry F G \<tau> f1 = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                        (\<lambda>f2. \<tau> (f1, f2))"
       using assms curry_def by auto
 
     lemma uncurry_simp:
     assumes "A1xA2.arr f"
     shows "uncurry \<tau> f = E.map (\<tau> (fst f), snd f)"
       using assms uncurry_def by auto
 
     lemma curry_in_hom:
     assumes f1: "A1.arr f1"
     and "natural_transformation A1xA2.comp B F G \<tau>"
     shows "\<guillemotleft>curry F G \<tau> f1 : curry F F F (A1.dom f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry G G G (A1.cod f1)\<guillemotright>"
     proof -
       interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
       show ?thesis
       proof -
         interpret F_dom_f1: "functor" A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
           using f1 \<tau>.F.is_extensional apply (unfold_locales, simp_all)
           by (metis A1.arr_dom A1.comp_arr_dom A1.dom_dom A1xA2.comp_simp A1xA2.seqI
               \<tau>.F.as_nat_trans.preserves_comp_2 fst_conv snd_conv)
         interpret G_cod_f1: "functor" A2 B \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
           using f1 \<tau>.G.is_extensional A1.arr_cod_iff_arr
           apply (unfold_locales, simp_all)
           by (metis A1.comp_arr_dom A1.dom_cod A1xA2.comp_simp A1xA2.seqI
               \<tau>.G.preserves_comp fst_conv snd_conv)
         have "natural_transformation A2 B (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                           (\<lambda>f2. \<tau> (f1, f2))"
           using f1 \<tau>.is_extensional apply (unfold_locales, simp_all)
         proof -
           fix f2
           assume f2: "A2.arr f2"
           show "G (A1.cod f1, f2) \<cdot>\<^sub>B \<tau> (f1, A2.dom f2) = \<tau> (f1, f2)"
             using f1 f2 \<tau>.preserves_comp_1 [of "(A1.cod f1, f2)" "(f1, A2.dom f2)"]
                   A1.comp_cod_arr A2.comp_arr_dom
             by simp
           show "\<tau> (f1, A2.cod f2) \<cdot>\<^sub>B F (A1.dom f1, f2) = \<tau> (f1, f2)"
             using f1 f2 \<tau>.preserves_comp_2 [of "(f1, A2.cod f2)" "(A1.dom f1, f2)"]
                   A1.comp_arr_dom A2.comp_cod_arr
             by simp
         qed
         thus ?thesis
           using f1 curry_simp by auto
       qed
     qed
 
     lemma curry_preserves_functors:
     assumes "functor A1xA2.comp B F"
     shows "functor A1 A2_B.comp (curry F F F)"
     proof -
       interpret F: "functor" A1xA2.comp B F using assms by auto
       interpret F: binary_functor A1 A2 B F ..
       show ?thesis
         using curry_def F.fixing_arr_gives_natural_transformation_1
               A2_B.comp_char F.preserves_comp_1 curry_simp A2_B.seq_char
         apply unfold_locales by auto
     qed
 
     lemma curry_preserves_transformations:
     assumes "natural_transformation A1xA2.comp B F G \<tau>"
     shows "natural_transformation A1 A2_B.comp (curry F F F) (curry G G G) (curry F G \<tau>)"
     proof -
       interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
       interpret \<tau>: binary_functor_transformation A1 A2 B F G \<tau> ..
       interpret curry_F: "functor" A1 A2_B.comp \<open>curry F F F\<close>
         using curry_preserves_functors \<tau>.F.functor_axioms by simp
       interpret curry_G: "functor" A1 A2_B.comp \<open>curry G G G\<close>
         using curry_preserves_functors \<tau>.G.functor_axioms by simp
       show ?thesis
       proof
         show "\<And>f2. \<not> A1.arr f2 \<Longrightarrow> curry F G \<tau> f2 = A2_B.null"
           using curry_def by simp
         fix f1
         assume f1: "A1.arr f1"
         show "A2_B.dom (curry F G \<tau> f1) = curry F F F (A1.dom f1)"
           using assms f1 curry_in_hom by blast
         show "A2_B.cod (curry F G \<tau> f1) = curry G G G (A1.cod f1)"
           using assms f1 curry_in_hom by blast
         show "curry G G G f1 \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F G \<tau> (A1.dom f1) = curry F G \<tau> f1"
         proof -
           interpret \<tau>_dom_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
                                 \<open>\<lambda>f2. G (A1.dom f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.dom f1, f2)\<close>
             using assms f1 curry_in_hom A1.ide_dom \<tau>.fixing_ide_gives_natural_transformation_1
             by blast
           interpret G_f1: natural_transformation A2 B
                                 \<open>\<lambda>f2. G (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. G (f1, f2)\<close>
             using f1 \<tau>.G.fixing_arr_gives_natural_transformation_1 by simp
           interpret G_f1o\<tau>_dom_f1: vertical_composite A2 B
                                      \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (A1.dom f1, f2)\<close>
                                      \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
                                      \<open>\<lambda>f2. \<tau> (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (f1, f2)\<close> ..
           have "curry G G G f1 \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F G \<tau> (A1.dom f1)
                   = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) G_f1o\<tau>_dom_f1.map"
           proof -
             have "A2_B.seq (curry G G G f1) (curry F G \<tau> (A1.dom f1))"
               using f1 curry_in_hom [of "A1.dom f1"] \<tau>.natural_transformation_axioms by force
             thus ?thesis
               using f1 curry_simp A2_B.comp_char [of "curry G G G f1" "curry F G \<tau> (A1.dom f1)"]
               by simp
           qed
           also have "... = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                       (\<lambda>f2. \<tau> (f1, f2))"
           proof (intro A2_B.MkArr_eqI)
             show "(\<lambda>f2. F (A1.dom f1, f2)) = (\<lambda>f2. F (A1.dom f1, f2))" by simp
             show "(\<lambda>f2. G (A1.cod f1, f2)) = (\<lambda>f2. G (A1.cod f1, f2))" by simp
             show "A2_B.arr (A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                        G_f1o\<tau>_dom_f1.map)"
               using G_f1o\<tau>_dom_f1.natural_transformation_axioms by blast
             show "G_f1o\<tau>_dom_f1.map = (\<lambda>f2. \<tau> (f1, f2))"
             proof
               fix f2
               have "\<not>A2.arr f2 \<Longrightarrow> G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                 using f1 G_f1o\<tau>_dom_f1.is_extensional \<tau>.is_extensional by simp
               moreover have "A2.arr f2 \<Longrightarrow> G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
               proof -
                 interpret \<tau>_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
                                   \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (f1, f2)\<close>
                   using assms f1 curry_in_hom [of f1] curry_simp by auto
                 fix f2
                 assume f2: "A2.arr f2"
                 show "G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                   using f1 f2 G_f1o\<tau>_dom_f1.map_simp_2 B.comp_assoc \<tau>.is_natural_1
                   by fastforce
               qed
               ultimately show "G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2" by blast
             qed
           qed
           also have "... = curry F G \<tau> f1" using f1 curry_def by simp
           finally show ?thesis by blast
         qed
         show "curry F G \<tau> (A1.cod f1) \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F F F f1 = curry F G \<tau> f1"
         proof -
           interpret \<tau>_cod_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
                                 \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.cod f1, f2)\<close>
             using assms f1 curry_in_hom A1.ide_cod \<tau>.fixing_ide_gives_natural_transformation_1
             by blast
           interpret F_f1: natural_transformation A2 B
                                 \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (f1, f2)\<close>
             using f1 \<tau>.F.fixing_arr_gives_natural_transformation_1 by simp
           interpret \<tau>_cod_f1oF_f1: vertical_composite A2 B
                                      \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
                                      \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
                                      \<open>\<lambda>f2. F (f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.cod f1, f2)\<close> ..
           have "curry F G \<tau> (A1.cod f1) \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F F F f1
                   = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) \<tau>_cod_f1oF_f1.map"
           proof -
             have
                  "curry F F F f1 =
                     A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2))
                                (\<lambda>f2. F (f1, f2)) \<and>
                   \<guillemotleft>curry F F F f1 : curry F F F (A1.dom f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry F F F (A1.cod f1)\<guillemotright>"
               using f1 curry_F.preserves_hom curry_simp by blast
             moreover have
                  "curry F G \<tau> (A1.dom f1) =
                     A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.dom f1, f2))
                                (\<lambda>f2. \<tau> (A1.dom f1, f2)) \<and>
                     \<guillemotleft>curry F G \<tau> (A1.cod f1) :
                        curry F F F (A1.cod f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry G G G (A1.cod f1)\<guillemotright>"
               using assms f1 curry_in_hom [of "A1.cod f1"] curry_def A1.arr_cod_iff_arr by simp
             ultimately show ?thesis
               using f1 curry_def by fastforce
           qed
           also have "... = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                       (\<lambda>f2. \<tau> (f1, f2))"
           proof (intro A2_B.MkArr_eqI)
             show "(\<lambda>f2. F (A1.dom f1, f2)) = (\<lambda>f2. F (A1.dom f1, f2))" by simp
             show "(\<lambda>f2. G (A1.cod f1, f2)) = (\<lambda>f2. G (A1.cod f1, f2))" by simp
             show "A2_B.arr (A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                        \<tau>_cod_f1oF_f1.map)"
               using \<tau>_cod_f1oF_f1.natural_transformation_axioms by blast
             show "\<tau>_cod_f1oF_f1.map = (\<lambda>f2. \<tau> (f1, f2))"
             proof
               fix f2
               have "\<not>A2.arr f2 \<Longrightarrow> \<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                 using f1 by (simp add: \<tau>.is_extensional \<tau>_cod_f1oF_f1.is_extensional)
               moreover have "A2.arr f2 \<Longrightarrow> \<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
               proof -
                 interpret \<tau>_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
                                   \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (f1, f2)\<close>
                   using assms f1 curry_in_hom [of f1] curry_simp by auto
                 fix f2
                 assume f2: "A2.arr f2"
                 show "\<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                   using f1 f2 \<tau>_cod_f1oF_f1.map_simp_1 B.comp_assoc \<tau>.is_natural_2
                   by fastforce
               qed
               ultimately show "\<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2" by blast
             qed
           qed
           also have "... = curry F G \<tau> f1" using f1 curry_def by simp
           finally show ?thesis by blast
         qed
       qed
     qed
 
     lemma uncurry_preserves_functors:
     assumes "functor A1 A2_B.comp F"
     shows "functor A1xA2.comp B (uncurry F)"
     proof -
       interpret F: "functor" A1 A2_B.comp F using assms by auto
       show ?thesis
         using uncurry_def
         apply (unfold_locales)
             apply auto[4]
       proof -
         fix f g :: "'a1 * 'a2"
         let ?f1 = "fst f"
         let ?f2 = "snd f"
         let ?g1 = "fst g"
         let ?g2 = "snd g"
         assume fg: "A1xA2.seq g f"
         have f: "A1xA2.arr f" using fg A1xA2.seqE by blast
         have f1: "A1.arr ?f1" using f by auto
         have f2: "A2.arr ?f2" using f by auto
         have g: "\<guillemotleft>g : A1xA2.cod f \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 A1xA2.cod g\<guillemotright>"
           using fg A1xA2.dom_char A1xA2.cod_char
           by (elim A1xA2.seqE, intro A1xA2.in_homI, auto)
         let ?g1 = "fst g"
         let ?g2 = "snd g"
         have g1: "\<guillemotleft>?g1 : A1.cod ?f1 \<rightarrow>\<^sub>A\<^sub>1 A1.cod ?g1\<guillemotright>"
           using f g by (intro A1.in_homI, auto)
         have g2: "\<guillemotleft>?g2 : A2.cod ?f2 \<rightarrow>\<^sub>A\<^sub>2 A2.cod ?g2\<guillemotright>"
           using f g by (intro A2.in_homI, auto)
         interpret Ff1: natural_transformation A2 B \<open>A2_B.Dom (F ?f1)\<close> \<open>A2_B.Cod (F ?f1)\<close>
                                                    \<open>A2_B.Map (F ?f1)\<close>
           using f A2_B.arr_char [of "F ?f1"] by auto
         interpret Fg1: natural_transformation A2 B \<open>A2_B.Cod (F ?f1)\<close> \<open>A2_B.Cod (F ?g1)\<close>
                                                    \<open>A2_B.Map (F ?g1)\<close>
           using f1 g1 A2_B.arr_char F.preserves_arr
                 A2_B.Map_dom [of "F ?g1"] A2_B.Map_cod [of "F ?f1"]
           by fastforce
         interpret Fg1oFf1: vertical_composite A2 B
                               \<open>A2_B.Dom (F ?f1)\<close> \<open>A2_B.Cod (F ?f1)\<close> \<open>A2_B.Cod (F ?g1)\<close>
                               \<open>A2_B.Map (F ?f1)\<close> \<open>A2_B.Map (F ?g1)\<close> ..
         show "uncurry F (g \<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 f) = uncurry F g \<cdot>\<^sub>B uncurry F f"
           using f1 g1 g2 g2 f g fg E.map_simp uncurry_def by auto
       qed
     qed
 
     lemma uncurry_preserves_transformations:
     assumes "natural_transformation A1 A2_B.comp F G \<tau>"
     shows "natural_transformation A1xA2.comp B (uncurry F) (uncurry G) (uncurry \<tau>)"
     proof -
       interpret \<tau>: natural_transformation A1 A2_B.comp F G \<tau> using assms by auto
       interpret "functor" A1xA2.comp B \<open>uncurry F\<close>
         using \<tau>.F.functor_axioms uncurry_preserves_functors by blast
       interpret "functor" A1xA2.comp B \<open>uncurry G\<close>
         using \<tau>.G.functor_axioms uncurry_preserves_functors by blast
       show ?thesis
       proof
         fix f
         show "\<not> A1xA2.arr f \<Longrightarrow> uncurry \<tau> f = B.null"
           using uncurry_def by auto
         assume f: "A1xA2.arr f"
         let ?f1 = "fst f"
         let ?f2 = "snd f"
         show "B.dom (uncurry \<tau> f) = uncurry F (A1xA2.dom f)"
           using f uncurry_def by simp
         show "B.cod (uncurry \<tau> f) = uncurry G (A1xA2.cod f)"
           using f uncurry_def by simp
         show "uncurry G f \<cdot>\<^sub>B uncurry \<tau> (A1xA2.dom f) = uncurry \<tau> f"
           using f uncurry_def \<tau>.is_natural_1 A2_BxA2.seq_char A2.comp_arr_dom
                 E.preserves_comp [of "(G (fst f), snd f)" "(\<tau> (A1.dom (fst f)), A2.dom (snd f))"]
           by auto
         show "uncurry \<tau> (A1xA2.cod f) \<cdot>\<^sub>B uncurry F f = uncurry \<tau> f"
         proof -
           have 1: "A1.arr ?f1 \<and> A1.arr (fst (A1.cod ?f1, A2.cod ?f2)) \<and>
                    A1.cod ?f1 = A1.dom (fst (A1.cod ?f1, A2.cod ?f2)) \<and>
                    A2.seq (snd (A1.cod ?f1, A2.cod ?f2)) ?f2"
             using f A1.arr_cod_iff_arr A2.arr_cod_iff_arr by auto
           hence 2:
               "?f2 = A2 (snd (\<tau> (fst (A1xA2.cod f)), snd (A1xA2.cod f))) (snd (F ?f1, ?f2))"
             using f A2.comp_cod_arr by simp
           have "A2_B.arr (\<tau> ?f1)" using 1 by force
           thus ?thesis
             unfolding uncurry_def E.map_def
             using f 1 2
             apply simp
             by (metis (no_types, lifting) A2_B.Map_comp \<open>A2_B.arr (\<tau> (fst f))\<close> \<tau>.is_natural_2)
 
         qed
       qed
     qed
 
     lemma uncurry_curry:
     assumes "natural_transformation A1xA2.comp B F G \<tau>"
     shows "uncurry (curry F G \<tau>) = \<tau>"
     proof
       interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
       interpret curry_\<tau>: natural_transformation A1 A2_B.comp \<open>curry F F F\<close> \<open>curry G G G\<close>
                                                              \<open>curry F G \<tau>\<close>
         using assms curry_preserves_transformations by auto
       fix f
       have "\<not>A1xA2.arr f \<Longrightarrow> uncurry (curry F G \<tau>) f = \<tau> f"
         using curry_def uncurry_def \<tau>.is_extensional by auto
       moreover have "A1xA2.arr f \<Longrightarrow> uncurry (curry F G \<tau>) f = \<tau> f"
       proof -
         assume f: "A1xA2.arr f"
         have 1: "A2_B.Map (curry F G \<tau> (fst f)) (snd f) = \<tau> (fst f, snd f)"
           using f A1xA2.arr_char curry_def by simp
         thus "uncurry (curry F G \<tau>) f = \<tau> f"
           unfolding uncurry_def E.map_def
           using f 1 A1xA2.arr_char [of f] by simp
       qed
       ultimately show "uncurry (curry F G \<tau>) f = \<tau> f" by blast
     qed
 
     lemma curry_uncurry:
     assumes "functor A1 A2_B.comp F" and "functor A1 A2_B.comp G"
     and "natural_transformation A1 A2_B.comp F G \<tau>"
     shows "curry (uncurry F) (uncurry G) (uncurry \<tau>) = \<tau>"
     proof
       interpret F: "functor" A1 A2_B.comp F using assms(1) by auto
       interpret G: "functor" A1 A2_B.comp G using assms(2) by auto
       interpret \<tau>: natural_transformation A1 A2_B.comp F G \<tau> using assms(3) by auto
       interpret uncurry_F: "functor" A1xA2.comp B \<open>uncurry F\<close>
         using F.functor_axioms uncurry_preserves_functors by auto
       interpret uncurry_G: "functor" A1xA2.comp B \<open>uncurry G\<close>
         using G.functor_axioms uncurry_preserves_functors by auto
       fix f1
       have "\<not>A1.arr f1 \<Longrightarrow> curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1"
         using curry_def uncurry_def \<tau>.is_extensional by simp
       moreover have "A1.arr f1 \<Longrightarrow> curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1"
       proof -
         assume f1: "A1.arr f1"
         interpret uncurry_\<tau>:
             natural_transformation A1xA2.comp B \<open>uncurry F\<close> \<open>uncurry G\<close> \<open>uncurry \<tau>\<close>
           using \<tau>.natural_transformation_axioms uncurry_preserves_transformations [of F G \<tau>]
           by simp
         have "curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 =
                 A2_B.MkArr (\<lambda>f2. uncurry F (A1.dom f1, f2)) (\<lambda>f2. uncurry G (A1.cod f1, f2))
                            (\<lambda>f2. uncurry \<tau> (f1, f2))"
           using f1 curry_def by simp
         also have "... = A2_B.MkArr (\<lambda>f2. uncurry F (A1.dom f1, f2))
                                     (\<lambda>f2. uncurry G (A1.cod f1, f2))
                                     (\<lambda>f2. E.map (\<tau> f1, f2))"
         proof -
           have "(\<lambda>f2. uncurry \<tau> (f1, f2)) = (\<lambda>f2. E.map (\<tau> f1, f2))"
             using f1 uncurry_def E.is_extensional by auto
           thus ?thesis by simp
         qed
         also have "... = \<tau> f1"
         proof -
           have "A2_B.Dom (\<tau> f1) = (\<lambda>f2. uncurry F (A1.dom f1, f2))"
           proof -
             have "A2_B.Dom (\<tau> f1) = A2_B.Map (A2_B.dom (\<tau> f1))"
               using f1 A2_B.ide_char A2_B.Map_dom A2_B.dom_char by auto
             also have "... = A2_B.Map (F (A1.dom f1))"
               using f1 by simp
             also have "... = (\<lambda>f2. uncurry F (A1.dom f1, f2))"
             proof
               fix f2
               interpret F_dom_f1: "functor" A2 B \<open>A2_B.Map (F (A1.dom f1))\<close>
                 using f1 A2_B.ide_char F.preserves_ide by simp
               show "A2_B.Map (F (A1.dom f1)) f2 = uncurry F (A1.dom f1, f2)"
                 using f1 uncurry_def E.map_simp F_dom_f1.is_extensional by auto
             qed
             finally show ?thesis by auto
           qed
           moreover have "A2_B.Cod (\<tau> f1) = (\<lambda>f2. uncurry G (A1.cod f1, f2))"
           proof -
             have "A2_B.Cod (\<tau> f1) = A2_B.Map (A2_B.cod (\<tau> f1))"
               using f1 A2_B.ide_char A2_B.Map_cod A2_B.cod_char by auto
             also have "... = A2_B.Map (G (A1.cod f1))"
               using f1 by simp
             also have "... = (\<lambda>f2. uncurry G (A1.cod f1, f2))"
             proof
               fix f2
               interpret G_cod_f1: "functor" A2 B \<open>A2_B.Map (G (A1.cod f1))\<close>
                 using f1 A2_B.ide_char G.preserves_ide by simp
               show "A2_B.Map (G (A1.cod f1)) f2 = uncurry G (A1.cod f1, f2)"
                 using f1 uncurry_def E.map_simp G_cod_f1.is_extensional by auto
             qed
             finally show ?thesis by auto
           qed
           moreover have "A2_B.Map (\<tau> f1) = (\<lambda>f2. E.map (\<tau> f1, f2))"
           proof
             fix f2
             have "\<not>A2.arr f2 \<Longrightarrow> A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
               using f1 A2_B.arrE \<tau>.preserves_reflects_arr natural_transformation.is_extensional
               by (metis (no_types, lifting) E.fixing_arr_gives_natural_transformation_1)
             moreover have "A2.arr f2 \<Longrightarrow> A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
               using f1 E.map_simp by fastforce
             ultimately show "A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2" by blast
           qed
           ultimately show ?thesis
             using f1 A2_B.MkArr_Map \<tau>.preserves_reflects_arr by metis
         qed
         finally show ?thesis by auto
       qed
       ultimately show "curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1" by blast
     qed
 
   end
 
   locale curried_functor =
      currying A1 A2 B +
      A1xA2: product_category A1 A2 +
      A2_B: functor_category A2 B +
      F: binary_functor A1 A2 B F
   for A1 :: "'a1 comp"         (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
   and A2 :: "'a2 comp"         (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
   and B :: "'b comp"           (infixr "\<cdot>\<^sub>B" 55)
   and F :: "'a1 * 'a2 \<Rightarrow> 'b"
   begin
 
     notation A1xA2.comp        (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
     notation A2_B.comp         (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>]" 55)
     notation A1xA2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
     notation A2_B.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
 
     definition map
     where "map \<equiv> curry F F F"
 
     lemma map_simp [simp]:
     assumes "A1.arr f1"
     shows "map f1 =
            A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2)) (\<lambda>f2. F (f1, f2))"
       using assms map_def curry_simp by auto
 
     lemma is_functor:
     shows "functor A1 A2_B.comp map"
       using F.functor_axioms map_def curry_preserves_functors by simp
 
   end
 
   sublocale curried_functor \<subseteq> "functor" A1 A2_B.comp map
     using is_functor by auto
 
   locale curried_functor' =
      A1: category A1 +
      A2: category A2 +
      A1xA2: product_category A1 A2 +
      currying A2 A1 B +
      F: binary_functor A1 A2 B F +
      A1_B: functor_category A1 B
   for A1 :: "'a1 comp"         (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
   and A2 :: "'a2 comp"         (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
   and B :: "'b comp"           (infixr "\<cdot>\<^sub>B" 55)
   and F :: "'a1 * 'a2 \<Rightarrow> 'b"
   begin
 
     notation A1xA2.comp        (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
     notation A1_B.comp         (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>1,\<^sub>B\<^sub>]" 55)
     notation A1xA2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
     notation A1_B.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>1\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
 
     definition map
     where "map \<equiv> curry F.sym F.sym F.sym"
 
     lemma map_simp [simp]:
     assumes "A2.arr f2"
     shows "map f2 =
            A1_B.MkArr (\<lambda>f1. F (f1, A2.dom f2)) (\<lambda>f1. F (f1, A2.cod f2)) (\<lambda>f1. F (f1, f2))"
       using assms map_def curry_simp by simp
 
     lemma is_functor:
     shows "functor A2 A1_B.comp map"
     proof -
       interpret A2xA1: product_category A2 A1 ..
       interpret F': binary_functor A2 A1 B F.sym
         using F.sym_is_binary_functor by simp
       have "functor A2xA1.comp B F.sym" ..
       thus ?thesis using map_def curry_preserves_functors by simp
     qed
 
   end
 
   sublocale curried_functor' \<subseteq> "functor" A2 A1_B.comp map
     using is_functor by auto
 
 end
 
diff --git a/thys/Category3/SetCat.thy b/thys/Category3/SetCat.thy
--- a/thys/Category3/SetCat.thy
+++ b/thys/Category3/SetCat.thy
@@ -1,1366 +1,1366 @@
 (*  Title:       SetCat
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter SetCat
 
 theory SetCat
 imports SetCategory ConcreteCategory
 begin
 
   text\<open>
     This theory proves the consistency of the \<open>set_category\<close> locale by giving
     a particular concrete construction of an interpretation for it.
     Applying the general construction given by @{locale concrete_category},
     we define arrows to be terms \<open>MkArr A B F\<close>, where \<open>A\<close> and \<open>B\<close> are sets
     and \<open>F\<close> is an extensional function that maps \<open>A\<close> to \<open>B\<close>.
 \<close>
 
   text\<open>
     This locale uses an extra dummy parameter just to fix the element type for sets.
     Without this, a type is used for each interpretation, which makes it impossible to
     construct set categories whose element types are related to the context.
     An additional parameter, @{term Setp}, allows some control over which subsets of
     the element type are assumed to correspond to objects of the category.
   \<close>
 
   locale setcat =
   fixes dummy :: 'e
   and Setp :: "'e set \<Rightarrow> bool"
   assumes Setp_singleton: "Setp {x}"
   and Setp_respects_subset: "A' \<subseteq> A \<Longrightarrow> Setp A \<Longrightarrow> Setp A'"
   and union_preserves_Setp: "\<lbrakk> Setp A; Setp B \<rbrakk> \<Longrightarrow> Setp (A \<union> B)"
   begin
 
     lemma finite_imp_Setp: "finite A \<Longrightarrow> Setp A"
       using Setp_singleton
       by (metis finite_induct insert_is_Un Setp_respects_subset singleton_insert_inj_eq
           union_preserves_Setp)
 
     type_synonym 'b arr = "('b set, 'b \<Rightarrow> 'b) concrete_category.arr"
 
     interpretation S: concrete_category \<open>Collect Setp\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
                         \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
       using compose_Id Id_compose
       apply unfold_locales
           apply auto[3]
        apply blast
       by (metis IntD2 compose_assoc)
 
     abbreviation comp :: "'e setcat.arr comp"     (infixr "\<cdot>" 55)
     where "comp \<equiv> S.COMP"
     notation S.in_hom                               ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     lemma is_category:
     shows "category comp"
       using S.category_axioms by simp
 
     lemma MkArr_expansion:
     assumes "S.arr f"
     shows "f = S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x)"
     proof (intro S.arr_eqI)
       show "S.arr f" by fact
       show "S.arr (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
         using assms S.arr_char
         by (metis (mono_tags, lifting) Int_iff S.MkArr_Map extensional_restrict)
       show "S.Dom f = S.Dom (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
         by simp
       show "S.Cod f = S.Cod (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
         by simp
       show "S.Map f = S.Map (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
         using assms S.arr_char
         by (metis (mono_tags, lifting) Int_iff S.MkArr_Map extensional_restrict)
     qed
 
     lemma arr_char:
     shows "S.arr f \<longleftrightarrow> f \<noteq> S.Null \<and> Setp (S.Dom f) \<and> Setp (S.Cod f) \<and>
                        S.Map f \<in> extensional (S.Dom f) \<inter> (S.Dom f \<rightarrow> S.Cod f)"
       using S.arr_char by auto
 
     lemma terminal_char:
     shows "S.terminal a \<longleftrightarrow> (\<exists>x. a = S.MkIde {x})"
     proof
       show "\<exists>x. a = S.MkIde {x} \<Longrightarrow> S.terminal a"
       proof -
         assume a: "\<exists>x. a = S.MkIde {x}"
         from this obtain x where x: "a = S.MkIde {x}" by blast
         have "S.terminal (S.MkIde {x})"
         proof
           show 1: "S.ide (S.MkIde {x})"
             using finite_imp_Setp S.ide_MkIde by auto
           show "\<And>a. S.ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> S.MkIde {x}\<guillemotright>"
           proof
             fix a :: "'e setcat.arr"
             assume a: "S.ide a"
             show "\<guillemotleft>S.MkArr (S.Dom a) {x} (\<lambda>_\<in>S.Dom a. x) : a \<rightarrow> S.MkIde {x}\<guillemotright>"
             proof
               show 2: "S.arr (S.MkArr (S.Dom a) {x} (\<lambda>_ \<in> S.Dom a. x))"
-                using a 1 S.arr_MkArr [of "S.Dom a" "{x}"] S.ide_char by force
+                using a 1 S.arr_MkArr [of "S.Dom a" "{x}"] S.ide_char\<^sub>C\<^sub>C by force
               show "S.dom (S.MkArr (S.Dom a) {x} (\<lambda>_ \<in> S.Dom a. x)) = a"
                 using a 2 S.dom_MkArr by force
               show "S.cod (S.MkArr (S.Dom a) {x} (\<lambda>_\<in>S.Dom a. x)) = S.MkIde {x}"
                 using 2 S.cod_MkArr by blast
             qed
             fix f :: "'e setcat.arr"
             assume f: "\<guillemotleft>f : a \<rightarrow> S.MkIde {x}\<guillemotright>"
             show "f = S.MkArr (S.Dom a) {x} (\<lambda>_ \<in> S.Dom a. x)"
             proof -
               have 1: "S.Dom f = S.Dom a \<and> S.Cod f = {x}"
                 using a f by (metis (mono_tags, lifting) S.Dom.simps(1) S.in_hom_char)
               moreover have "S.Map f = (\<lambda>_ \<in> S.Dom a. x)"
               proof
                 fix z
                 have "z \<notin> S.Dom a \<Longrightarrow> S.Map f z = (\<lambda>_ \<in> S.Dom a. x) z"
                   using f 1 MkArr_expansion
                   by (metis (mono_tags, lifting) S.Map.simps(1) S.in_homE restrict_apply)
                 moreover have "z \<in> S.Dom a \<Longrightarrow> S.Map f z = (\<lambda>_ \<in> S.Dom a. x) z"
                   using f 1 arr_char [of f] by fastforce
                 ultimately show "S.Map f z = (\<lambda>_ \<in> S.Dom a. x) z" by auto
               qed
               ultimately show ?thesis
                using f MkArr_expansion [of f] by fastforce
             qed
           qed
         qed
         thus "S.terminal a" using x by simp
       qed
       show "S.terminal a \<Longrightarrow> \<exists>x. a = S.MkIde {x}"
       proof -
         assume a: "S.terminal a"
         hence ide_a: "S.ide a" using S.terminal_def by auto
         have 1: "\<exists>!x. x \<in> S.Dom a"
         proof -
           have "S.Dom a = {} \<Longrightarrow> \<not>S.terminal a"
           proof -
             assume "S.Dom a = {}"
             hence 1: "a = S.MkIde {}"
               using S.MkIde_Dom' \<open>S.ide a\<close> by fastforce
             have "\<And>f. f \<in> S.hom (S.MkIde {undefined}) (S.MkIde ({} :: 'e set))
                          \<Longrightarrow> S.Map f \<in> {undefined} \<rightarrow> {}"
             proof -
               fix f
               assume f: "f \<in> S.hom (S.MkIde {undefined}) (S.MkIde ({} :: 'e set))"
               show "S.Map f \<in> {undefined} \<rightarrow> {}"
                 using f MkArr_expansion arr_char [of f] S.in_hom_char by auto
             qed
             hence "S.hom (S.MkIde {undefined}) a = {}" using 1 by auto
             moreover have "S.ide (S.MkIde {undefined})"
               using finite_imp_Setp
               by (metis (mono_tags, lifting) finite.intros(1-2) S.ide_MkIde mem_Collect_eq)
             ultimately show "\<not>S.terminal a" by blast
           qed
           moreover have "\<And>x x'. x \<in> S.Dom a \<and> x' \<in> S.Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>S.terminal a"
           proof -
             fix x x'
             assume 1: "x \<in> S.Dom a \<and> x' \<in> S.Dom a \<and> x \<noteq> x'"
             let ?f = "S.MkArr {undefined} (S.Dom a) (\<lambda>_ \<in> {undefined}. x)"
             let ?f' = "S.MkArr {undefined} (S.Dom a) (\<lambda>_ \<in> {undefined}. x')"
             have "S.par ?f ?f'"
             proof -
               have "\<guillemotleft>?f : S.MkIde {undefined} \<rightarrow> a\<guillemotright>"
               proof
                 show 2: "S.arr ?f"
                 proof (intro S.arr_MkArr)
                   show "{undefined} \<in> {A. Setp A}"
                     by (simp add: finite_imp_Setp)
                   show "S.Dom a \<in> {A. Setp A}"
-                    using ide_a S.ide_char by blast
+                    using ide_a S.ide_char\<^sub>C\<^sub>C by blast
                   show "(\<lambda>_ \<in> {undefined}. x) \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> S.Dom a)"
                     using 1 by blast
                 qed
                 show "S.dom ?f = S.MkIde {undefined}"
                   using 2 S.dom_MkArr by auto
                 show "S.cod ?f = a"
                   using 2 S.cod_MkArr ide_a by force
               qed
               moreover have "\<guillemotleft>?f' : S.MkIde {undefined} \<rightarrow> a\<guillemotright>"
               proof
                 show 2: "S.arr ?f'"
                 proof (intro S.arr_MkArr)
                   show "{undefined} \<in> {A. Setp A}"
                     by (simp add: finite_imp_Setp)
                   show "S.Dom a \<in> {A. Setp A}"
-                    using ide_a S.ide_char by blast
+                    using ide_a S.ide_char\<^sub>C\<^sub>C by blast
                   show "(\<lambda>_ \<in> {undefined}. x') \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> S.Dom a)"
                     using 1 by blast
                 qed
                 show "S.dom ?f' = S.MkIde {undefined}"
                   using 2 S.dom_MkArr by auto
                 show "S.cod ?f' = a"
                   using 2 S.cod_MkArr ide_a by force
               qed
               ultimately show ?thesis
                 by (metis (no_types, lifting) S.in_homE)
             qed
             moreover have "?f \<noteq> ?f'"
               using 1 by (metis S.arr.inject restrict_apply' singletonI)
             ultimately show "\<not>S.terminal a"
               using S.cod_MkArr ide_a S.terminal_arr_unique [of ?f ?f'] by auto
           qed
           ultimately show ?thesis
             using a by auto
         qed
         hence "S.Dom a = {THE x. x \<in> S.Dom a}"
           using theI [of "\<lambda>x. x \<in> S.Dom a"] by auto
         hence "a = S.MkIde {THE x. x \<in> S.Dom a}"
           using a S.terminal_def by (metis (mono_tags, lifting) S.MkIde_Dom')
         thus "\<exists>x. a = S.MkIde {x}"
           by auto
       qed
     qed
 
     definition IMG :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
     where "IMG f = S.MkIde (S.Map f ` S.Dom f)"
   
     interpretation S: set_category_data comp IMG
       ..
 
     lemma terminal_unity:
     shows "S.terminal S.unity"
       using terminal_char S.unity_def someI_ex [of S.terminal]
       by (metis (mono_tags, lifting))
   
     text\<open>
       The inverse maps @{term arr_of} and @{term elem_of} are used to pass back and forth between
       the inhabitants of type @{typ 'a} and the corresponding terminal objects.
       These are exported so that a client of the theory can relate the concrete
       element type @{typ 'a} to the otherwise abstract arrow type.
 \<close>
 
     definition arr_of :: "'e \<Rightarrow> 'e setcat.arr"
     where "arr_of x \<equiv> S.MkIde {x}"
   
     definition elem_of :: "'e setcat.arr \<Rightarrow> 'e"
     where "elem_of t \<equiv> the_elem (S.Dom t)"
 
     abbreviation U
     where "U \<equiv> elem_of S.unity"
   
     lemma arr_of_mapsto:
     shows "arr_of \<in> UNIV \<rightarrow> S.Univ"
       using terminal_char arr_of_def by fast
     
     lemma elem_of_mapsto:
     shows "elem_of \<in> Univ \<rightarrow> UNIV"
       by auto
     
     lemma elem_of_arr_of [simp]:
     shows "elem_of (arr_of x) = x"
       by (simp add: elem_of_def arr_of_def)
     
     lemma arr_of_elem_of [simp]:
     assumes "t \<in> S.Univ"
     shows "arr_of (elem_of t) = t"
       using assms terminal_char arr_of_def elem_of_def
       by (metis (mono_tags, lifting) mem_Collect_eq elem_of_arr_of)
   
     lemma inj_arr_of:
     shows "inj arr_of"
       by (metis elem_of_arr_of injI)
   
     lemma bij_arr_of:
     shows "bij_betw arr_of UNIV S.Univ"
     proof (intro bij_betwI)
       show "\<And>x :: 'e. elem_of (arr_of x) = x" by simp
       show "\<And>t. t \<in> S.Univ \<Longrightarrow> arr_of (elem_of t) = t" by simp
       show "arr_of \<in> UNIV \<rightarrow> S.Univ" using arr_of_mapsto by auto
       show "elem_of \<in> Collect S.terminal \<rightarrow> UNIV" by auto
     qed
   
     lemma bij_elem_of:
     shows "bij_betw elem_of S.Univ UNIV"
     proof (intro bij_betwI)
       show "\<And>t. t \<in> S.Univ \<Longrightarrow> arr_of (elem_of t) = t" by simp
       show "\<And>x. x \<in> UNIV \<Longrightarrow> elem_of (arr_of x) = x" by simp
       show "elem_of \<in> S.Univ \<rightarrow> UNIV" using elem_of_mapsto by auto
       show "arr_of \<in> UNIV \<rightarrow> S.Univ" using arr_of_mapsto by auto
     qed
 
     lemma elem_of_img_arr_of_img [simp]:
     shows "elem_of ` arr_of ` A = A"
       by force
 
     lemma arr_of_img_elem_of_img [simp]:
     assumes "A \<subseteq> S.Univ"
     shows "arr_of ` elem_of ` A = A"
       using assms by force
 
     lemma Dom_terminal:
     assumes "S.terminal t"
     shows "S.Dom t = {elem_of t}"
       using assms arr_of_def
       by (metis (mono_tags, lifting) S.Dom.simps(1) elem_of_def terminal_char the_elem_eq)
 
     text\<open>
       The image of a point @{term "p \<in> hom unity a"} is a terminal object, which is given
       by the formula @{term "(arr_of o Fun p o elem_of) unity"}.
 \<close>
 
     lemma IMG_point:
     assumes "\<guillemotleft>p : S.unity \<rightarrow> a\<guillemotright>"
     shows "IMG \<in> S.hom S.unity a \<rightarrow> S.Univ"
     and "IMG p = (arr_of o S.Map p o elem_of) S.unity"
     proof -
       show "IMG \<in> S.hom S.unity a \<rightarrow> S.Univ"
       proof
         fix f
         assume f: "f \<in> S.hom S.unity a"
         have "S.terminal (S.MkIde (S.Map f ` S.Dom S.unity))"
         proof -
           obtain u :: 'e where u: "S.unity = S.MkIde {u}"
             using terminal_unity terminal_char
             by (metis (mono_tags, lifting))
           have "S.Map f ` S.Dom S.unity = {S.Map f u}"
             using u by simp
           thus ?thesis
             using terminal_char by auto
         qed
         hence "S.MkIde (S.Map f ` S.Dom S.unity) \<in> S.Univ" by simp
         moreover have "S.MkIde (S.Map f ` S.Dom S.unity) = IMG f"
           using f IMG_def S.in_hom_char
           by (metis (mono_tags, lifting) mem_Collect_eq)
         ultimately show "IMG f \<in> S.Univ" by auto
       qed
       have "IMG p = S.MkIde (S.Map p ` S.Dom p)" using IMG_def by blast
       also have "... = S.MkIde (S.Map p ` {U})"
         using assms S.in_hom_char terminal_unity Dom_terminal
         by (metis (mono_tags, lifting))
       also have "... = (arr_of o S.Map p o elem_of) S.unity" by (simp add: arr_of_def)
       finally show "IMG p = (arr_of o S.Map p o elem_of) S.unity" using assms by auto
     qed
   
     text\<open>
       The function @{term IMG} is injective on @{term "hom unity a"} and its inverse takes
       a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
       constant-@{term t} function.
 \<close>
 
     abbreviation MkElem :: "'e setcat.arr => 'e setcat.arr => 'e setcat.arr"
     where "MkElem t a \<equiv> S.MkArr {U} (S.Dom a) (\<lambda>_ \<in> {U}. elem_of t)"
 
     lemma MkElem_in_hom:
     assumes "S.arr f" and "x \<in> S.Dom f"
     shows "\<guillemotleft>MkElem (arr_of x) (S.dom f) : S.unity \<rightarrow> S.dom f\<guillemotright>"
     proof -
       have "(\<lambda>_ \<in> {U}. elem_of (arr_of x)) \<in> {U} \<rightarrow> S.Dom (S.dom f)"
         using assms S.dom_char [of f] by simp
       moreover have "S.MkIde {U} = S.unity"
         using terminal_char terminal_unity
         by (metis (mono_tags, lifting) elem_of_arr_of arr_of_def)
       moreover have "S.MkIde (S.Dom (S.dom f)) = S.dom f"
         using assms S.dom_char S.MkIde_Dom' S.ide_dom by blast
       ultimately show ?thesis
         using assms S.MkArr_in_hom [of "{U}" "S.Dom (S.dom f)" "\<lambda>_ \<in> {U}. elem_of (arr_of x)"]
         by (metis (no_types, lifting) S.Dom.simps(1) S.Dom_in_Obj IntI S.arr_dom S.ideD(1)
             restrict_extensional S.terminal_def terminal_unity)
     qed
 
     lemma MkElem_IMG:
     assumes "p \<in> S.hom S.unity a"
     shows "MkElem (IMG p) a = p"
     proof -
       have 0: "IMG p = arr_of (S.Map p U)"
         using assms IMG_point(2) by auto
       have 1: "S.Dom p = {U}"
         using assms terminal_unity Dom_terminal
         by (metis (mono_tags, lifting) S.in_hom_char mem_Collect_eq)
       moreover have "S.Cod p = S.Dom a"
         using assms
         by (metis (mono_tags, lifting) S.in_hom_char mem_Collect_eq)
       moreover have "S.Map p = (\<lambda>_ \<in> {U}. elem_of (IMG p))"
       proof
         fix e
         show "S.Map p e = (\<lambda>_ \<in> {U}. elem_of (IMG p)) e"
         proof -
           have "S.Map p e = (\<lambda>x \<in> S.Dom p. S.Map p x) e"
             using assms MkArr_expansion [of p]
             by (metis (mono_tags, lifting) CollectD S.Map.simps(1) S.in_homE)
           also have "... = (\<lambda>_ \<in> {U}. elem_of (IMG p)) e"
             using assms 0 1 by simp
           finally show ?thesis by blast
         qed
       qed
       ultimately show "MkElem (IMG p) a = p"
         using assms S.MkArr_Map CollectD
         by (metis (mono_tags, lifting) S.in_homE mem_Collect_eq)
     qed
 
     lemma inj_IMG:
     assumes "S.ide a"
     shows "inj_on IMG (S.hom S.unity a)"
     proof (intro inj_onI)
       fix x y
       assume x: "x \<in> S.hom S.unity a"
       assume y: "y \<in> S.hom S.unity a"
       assume eq: "IMG x = IMG y"
       show "x = y"
       proof (intro S.arr_eqI)
         show "S.arr x" using x by blast
         show "S.arr y" using y by blast
         show "S.Dom x = S.Dom y"
           using x y S.in_hom_char by (metis (mono_tags, lifting) CollectD)
         show "S.Cod x = S.Cod y"
           using x y S.in_hom_char by (metis (mono_tags, lifting) CollectD)
         show "S.Map x = S.Map y"
         proof -
           have "\<And>a. y \<in> S.hom S.unity a \<Longrightarrow> S.MkArr {U} (S.Dom a) (\<lambda>e\<in>{U}. elem_of (IMG x)) = y"
             using MkElem_IMG eq by presburger
           hence "y = x"
             using MkElem_IMG x y by blast
           thus ?thesis by meson
         qed
       qed
     qed
 
     lemma set_char:
     assumes "S.ide a"
     shows "S.set a = arr_of ` S.Dom a"
     proof
       show "S.set a \<subseteq> arr_of ` S.Dom a"
       proof
         fix t
         assume "t \<in> S.set a"
         from this obtain p where p: "\<guillemotleft>p : S.unity \<rightarrow> a\<guillemotright> \<and> t = IMG p"
           using S.set_def by blast
         have "t = (arr_of o S.Map p o elem_of) S.unity"
           using p IMG_point(2) by blast
         moreover have "(S.Map p o elem_of) S.unity \<in> S.Dom a"
           using p arr_char S.in_hom_char Dom_terminal terminal_unity
           by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
         ultimately show "t \<in> arr_of ` S.Dom a" by simp
       qed
       show "arr_of ` S.Dom a \<subseteq> S.set a"
       proof
         fix t
         assume "t \<in> arr_of ` S.Dom a"
         from this obtain x where x: "x \<in> S.Dom a \<and> t = arr_of x" by blast
         let ?p = "MkElem (arr_of x) a"
         have p: "?p \<in> S.hom S.unity a"
           using assms x MkElem_in_hom [of "S.dom a"] S.ideD(1-2) by force
         moreover have "IMG ?p = t"
           using p x elem_of_arr_of IMG_def arr_of_def
           by (metis (no_types, lifting) S.Dom.simps(1) S.Map.simps(1) image_empty
               image_insert image_restrict_eq)
         ultimately show "t \<in> S.set a" using S.set_def by blast
       qed
     qed
   
     lemma Map_via_comp:
     assumes "S.arr f"
     shows "S.Map f = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U)"
     proof
       fix x
       have "x \<notin> S.Dom f \<Longrightarrow> S.Map f x = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U) x"
         using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
       moreover have
            "x \<in> S.Dom f \<Longrightarrow> S.Map f x = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U) x"
       proof -
         assume x: "x \<in> S.Dom f"
         let ?X = "MkElem (arr_of x) (S.dom f)"
         have "\<guillemotleft>?X : S.unity \<rightarrow> S.dom f\<guillemotright>"
           using assms x MkElem_in_hom by auto
         moreover have "S.Dom ?X = {U} \<and> S.Map ?X = (\<lambda>_ \<in> {U}. x)"
           using x by simp
         ultimately have
           "S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) = compose {U} (S.Map f) (\<lambda>_ \<in> {U}. x)"
           using assms x S.Map_comp [of "MkElem (arr_of x) (S.dom f)" f]
           by (metis (mono_tags, lifting) S.Cod.simps(1) S.Dom_dom S.arr_iff_in_hom S.seqE S.seqI')
         thus ?thesis
           using x by (simp add: compose_eq restrict_apply' singletonI)
       qed
       ultimately show "S.Map f x = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U) x"
         by auto
     qed
 
     lemma arr_eqI':
     assumes "S.par f f'" and "\<And>t. \<guillemotleft>t : S.unity \<rightarrow> S.dom f\<guillemotright> \<Longrightarrow> f \<cdot> t = f' \<cdot> t"
     shows "f = f'"
     proof (intro S.arr_eqI)
       show "S.arr f" using assms by simp
       show "S.arr f'" using assms by simp
       show "S.Dom f = S.Dom f'"
         using assms by (metis (mono_tags, lifting) S.Dom_dom)
       show "S.Cod f = S.Cod f'"
         using assms by (metis (mono_tags, lifting) S.Cod_cod)
       show "S.Map f = S.Map f'"
       proof
         have 1: "\<And>x. x \<in> S.Dom f \<Longrightarrow> \<guillemotleft>MkElem (arr_of x) (S.dom f) : S.unity \<rightarrow> S.dom f\<guillemotright>"
           using MkElem_in_hom by (metis (mono_tags, lifting) assms(1))
         fix x
         show "S.Map f x = S.Map f' x"
           using assms 1 \<open>S.Dom f = S.Dom f'\<close> by (simp add: Map_via_comp)
       qed
     qed
 
     lemma Setp_elem_of_img:
     assumes "A \<in> S.set ` Collect S.ide"
     shows "Setp (elem_of ` A)"
     proof -
       obtain a where a: "S.ide a \<and> S.set a = A"
         using assms by blast
       have "elem_of ` S.set a = S.Dom a"
       proof -
         have "S.set a = arr_of ` S.Dom a"
         using a set_char by blast
         moreover have "elem_of ` arr_of ` S.Dom a = S.Dom a"
           using elem_of_arr_of by force
         ultimately show ?thesis by presburger
       qed
       thus ?thesis
-        using a S.ide_char by auto
+        using a S.ide_char\<^sub>C\<^sub>C by auto
     qed
 
     lemma set_MkIde_elem_of_img:
     assumes "A \<subseteq> S.Univ" and "S.ide (S.MkIde (elem_of ` A))"
     shows "S.set (S.MkIde (elem_of ` A)) = A"
     proof -
       have "S.Dom (S.MkIde (elem_of ` A)) = elem_of ` A"
         by simp
       moreover have "arr_of ` elem_of ` A = A"
         using assms arr_of_elem_of by force
       ultimately show ?thesis
         using assms Setp_elem_of_img set_char S.ide_MkIde by auto
     qed
 
     (*
      * We need this result, which characterizes what sets of terminals correspond
      * to sets.
      *)
     lemma set_img_Collect_ide_iff:
     shows "A \<in> S.set ` Collect S.ide \<longleftrightarrow> A \<subseteq> S.Univ \<and> Setp (elem_of ` A)"
     proof
       show "A \<in> S.set ` Collect S.ide \<Longrightarrow> A \<subseteq> S.Univ \<and> Setp (elem_of ` A)"
         using set_char arr_of_mapsto Setp_elem_of_img by auto
       assume A: "A \<subseteq> S.Univ \<and> Setp (elem_of ` A)"
       have "S.ide (S.MkIde (elem_of ` A))"
         using A S.ide_MkIde by blast
       moreover have "S.set (S.MkIde (elem_of ` A)) = A"
         using A calculation set_MkIde_elem_of_img by presburger
       ultimately show "A \<in> S.set ` Collect S.ide" by blast
     qed
 
     text\<open>
       The main result, which establishes the consistency of the \<open>set_category\<close> locale
       and provides us with a way of obtaining ``set categories'' at arbitrary types.
 \<close>
 
     theorem is_set_category:
     shows "set_category comp (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A))"
     proof
       show "\<exists>img :: 'e setcat.arr \<Rightarrow> 'e setcat.arr.
                        set_category_given_img comp img (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A))"
       proof
         show "set_category_given_img comp IMG (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A))"
         proof
           show "S.Univ \<noteq> {}" using terminal_char by blast
           fix a :: "'e setcat.arr"
           assume a: "S.ide a"
           show "S.set a \<subseteq> S.Univ \<and> Setp (elem_of ` S.set a)"
             using a set_img_Collect_ide_iff by auto
           show "inj_on IMG (S.hom S.unity a)" using a inj_IMG terminal_unity by blast
           next
           fix t :: "'e setcat.arr"
           assume t: "S.terminal t"
           show "t \<in> IMG ` S.hom S.unity t"
           proof -
             have "t \<in> S.set t"
               using t set_char [of t]
               by (metis (mono_tags, lifting) S.Dom.simps(1) image_insert insertI1 arr_of_def
                   terminal_char S.terminal_def)
             thus ?thesis
               using t S.set_def [of t] by simp
           qed
           next
           show "\<And>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A) \<Longrightarrow> \<exists>a. S.ide a \<and> S.set a = A"
             using set_img_Collect_ide_iff by fast
           next
           fix a b :: "'e setcat.arr"
           assume a: "S.ide a" and b: "S.ide b" and ab: "S.set a = S.set b"
           show "a = b"
             using a b ab set_char inj_arr_of inj_image_eq_iff S.dom_char S.in_homE S.ide_in_hom
             by (metis (mono_tags, lifting))
           next
           fix f f' :: "'e setcat.arr"
           assume par: "S.par f f'" and ff': "\<And>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
           show "f = f'" using par ff' arr_eqI' by blast
           next
           fix a b :: "'e setcat.arr" and F :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
           assume a: "S.ide a" and b: "S.ide b" and F: "F \<in> S.hom S.unity a \<rightarrow> S.hom S.unity b"
           show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
           proof
             let ?f = "S.MkArr (S.Dom a) (S.Dom b) (\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U)"
             have 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
             proof -
               have "(\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U)
                       \<in> extensional (S.Dom a) \<inter> (S.Dom a \<rightarrow> S.Dom b)"
               proof
                 show "(\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U) \<in> extensional (S.Dom a)"
                   using a F by simp
                 show "(\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U) \<in> S.Dom a \<rightarrow> S.Dom b"
                 proof
                   fix x
                   assume x: "x \<in> S.Dom a"
                   have "MkElem (arr_of x) a \<in> S.hom S.unity a"
                     using x a MkElem_in_hom [of a x] S.ide_char S.ideD(1-2) by force
                   hence 1: "F (MkElem (arr_of x) a) \<in> S.hom S.unity b"
                     using F by auto
                   moreover have "S.Dom (F (MkElem (arr_of x) a)) = {U}"
                     using 1 MkElem_IMG
                     by (metis (mono_tags, lifting) S.Dom.simps(1))
                   moreover have "S.Cod (F (MkElem (arr_of x) a)) = S.Dom b"
                     using 1 by (metis (mono_tags, lifting) CollectD S.in_hom_char)
                   ultimately have "S.Map (F (MkElem (arr_of x) a)) \<in> {U} \<rightarrow> S.Dom b"
                     using arr_char [of "F (MkElem (arr_of x) a)"] by blast
                   thus "S.Map (F (MkElem (arr_of x) a)) U \<in> S.Dom b" by blast
                 qed
               qed
               hence "\<guillemotleft>?f : S.MkIde (S.Dom a) \<rightarrow> S.MkIde (S.Dom b)\<guillemotright>"
-                using a b S.MkArr_in_hom S.ide_char by blast
+                using a b S.MkArr_in_hom S.ide_char\<^sub>C\<^sub>C by blast
               thus ?thesis
                 using a b by simp
             qed
             moreover have "\<And>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
             proof -
               fix x
               assume x: "\<guillemotleft>x : S.unity \<rightarrow> S.dom ?f\<guillemotright>"
               have 2: "x = MkElem (IMG x) a"
                 using a x 1 MkElem_IMG [of x a]
                 by (metis (mono_tags, lifting) S.in_homE mem_Collect_eq)
               moreover have 5: "S.Dom x = {U} \<and> S.Cod x = S.Dom a \<and>
                                 S.Map x = (\<lambda>_ \<in> {U}. elem_of (IMG x))"
                 using x 2
                 by (metis (no_types, lifting) S.Cod.simps(1) S.Dom.simps(1) S.Map.simps(1))
               moreover have "S.Cod ?f = S.Dom b" using 1 by simp
               ultimately have
                    3: "?f \<cdot> x =
                        S.MkArr {U} (S.Dom b) (compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)))"
                 by (metis (no_types, lifting) "1" S.Map.simps(1) S.comp_MkArr S.in_homE x)
               have 4: "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) = S.Map (F x)"
               proof
                 fix y
                 have "y \<notin> {U} \<Longrightarrow>
                         compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                 proof -
                   assume y: "y \<notin> {U}"
                   have "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = undefined"
                     using y compose_def extensional_arb by simp
                   also have "... = S.Map (F x) y"
                   proof -
                     have 5: "F x \<in> S.hom S.unity b" using x F 1 by fastforce
                     hence "S.Dom (F x) = {U}"
                       by (metis (mono_tags, lifting) "2" CollectD S.Dom.simps(1) S.in_hom_char x)
                     thus ?thesis
                       using x y F 5 arr_char [of "F x"] extensional_arb [of "S.Map (F x)" "{U}" y]
                       by (metis (mono_tags, lifting) CollectD Int_iff S.in_hom_char)
                   qed
                   ultimately show ?thesis by auto
                 qed
                 moreover have
                     "y \<in> {U} \<Longrightarrow>
                        compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                 proof -
                   assume y: "y \<in> {U}"
                   have "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y =
                         S.Map ?f (elem_of (IMG x))"
                     using y by (simp add: compose_eq restrict_apply')
                   also have "... = (\<lambda>x. S.Map (F (MkElem (arr_of x) a)) U) (elem_of (IMG x))"
                   proof -
                     have "elem_of (IMG x) \<in> S.Dom a"
                       using x y a 5 arr_char S.in_homE restrict_apply by force
                     thus ?thesis
                       using restrict_apply by simp
                   qed
                   also have "... = S.Map (F x) y"
                     using x y 1 2 MkElem_IMG [of x a] by simp
                   finally show
                       "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                     by auto
                 qed
                 ultimately show
                     "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                   by auto
               qed
               show "?f \<cdot> x = F x"
               proof (intro S.arr_eqI)
                 have 5: "?f \<cdot> x \<in> S.hom S.unity b" using 1 x by blast
                 have 6: "F x \<in> S.hom S.unity b"
                   using x F 1
                   by (metis (mono_tags, lifting) PiE S.in_homE mem_Collect_eq)
                 show "S.arr (comp ?f x)" using 5 by blast
                 show "S.arr (F x)" using 6 by blast
                 show "S.Dom (comp ?f x) = S.Dom (F x)"
                   using 5 6 by (metis (mono_tags, lifting) CollectD S.in_hom_char)
                 show "S.Cod (comp ?f x) = S.Cod (F x)"
                   using 5 6 by (metis (mono_tags, lifting) CollectD S.in_hom_char)
                 show "S.Map (comp ?f x) = S.Map (F x)"
                   using 3 4 by simp
               qed
             qed
             thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom ?f\<guillemotright> \<longrightarrow> comp ?f x = F x)"
               using 1 by blast
           qed
           next
           show "\<And>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A) \<Longrightarrow> A \<subseteq> S.Univ"
             by simp
           show "\<And>A' A. \<lbrakk>A' \<subseteq> A; A \<subseteq> S.Univ \<and> Setp (elem_of ` A)\<rbrakk> \<Longrightarrow> A' \<subseteq> S.Univ \<and> Setp (elem_of ` A')"
             by (meson image_mono setcat.Setp_respects_subset setcat_axioms subset_trans)
           show "\<And>A B. \<lbrakk>A \<subseteq> S.Univ \<and> Setp (elem_of ` A); B \<subseteq> S.Univ \<and> Setp (elem_of ` B)\<rbrakk>
                          \<Longrightarrow> A \<union> B \<subseteq> S.Univ \<and> Setp (elem_of ` (A \<union> B))"
             by (simp add: image_Un union_preserves_Setp)
         qed
       qed
     qed
 
     text\<open>
       \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
       @{typ 'a}, using @{term arr_of} as the required injection from @{typ 'a} to the universe
       of \<open>SetCat\<close>.
 \<close>
 
     corollary is_concrete_set_category:
     shows "concrete_set_category comp (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A)) UNIV arr_of"
     proof -
       interpret S': set_category comp \<open>\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A)\<close>
         using is_set_category by auto
       show ?thesis
       proof
         show 1: "arr_of \<in> UNIV \<rightarrow> S'.Univ"
           using arr_of_def terminal_char by force
         show "inj_on arr_of UNIV"
           using inj_arr_of by blast
       qed
     qed
 
     text\<open>
       As a consequence of the categoricity of the \<open>set_category\<close> axioms,
       if @{term S} interprets \<open>set_category\<close>, and if @{term \<phi>} is a bijection between
       the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
       to the category \<open>setcat\<close> of @{typ 'a} sets and functions between them constructed here.
 \<close>
 
     corollary set_category_iso_SetCat:
     fixes S :: "'s comp" and \<phi> :: "'s \<Rightarrow> 'e"
     assumes "set_category S \<S>"
     and "bij_betw \<phi> (set_category_data.Univ S) UNIV"
     and "\<And>A. \<S> A \<longleftrightarrow> A \<subseteq> set_category_data.Univ S \<and> (arr_of \<circ> \<phi>) ` A \<in> S.set ` Collect S.ide"
     shows "\<exists>\<Phi>. invertible_functor S comp \<Phi>
                  \<and> (\<forall>m. set_category.incl S \<S> m
                            \<longrightarrow> set_category.incl comp (\<lambda>A. A \<in> S.set ` Collect S.ide) (\<Phi> m))"
     proof -
       interpret S': set_category S \<S> using assms by auto
       let ?\<psi> = "inv_into S'.Univ \<phi>"
       have "bij_betw (arr_of o \<phi>) S'.Univ S.Univ"
       proof (intro bij_betwI)
         show "arr_of o \<phi> \<in> S'.Univ \<rightarrow> Collect S.terminal"
           using assms(2) arr_of_mapsto by auto
         show "?\<psi> o elem_of \<in> S.Univ \<rightarrow> S'.Univ"
         proof
           fix x :: "'e setcat.arr"
           assume x: "x \<in> S.Univ"
           show "(inv_into S'.Univ \<phi> \<circ> elem_of) x \<in> S'.Univ"
             using x assms(2) bij_betw_def comp_apply inv_into_into
             by (metis UNIV_I)
         qed
         fix t
         assume "t \<in> S'.Univ"
         thus "(?\<psi> o elem_of) ((arr_of o \<phi>) t) = t"
           using assms(2) bij_betw_inv_into_left
           by (metis comp_apply elem_of_arr_of)
         next
         fix t' :: "'e setcat.arr"
         assume "t' \<in> S.Univ"
         thus "(arr_of o \<phi>) ((?\<psi> o elem_of) t') = t'"
           using assms(2) by (simp add: bij_betw_def f_inv_into_f)
       qed
       thus ?thesis
         using assms is_set_category set_img_Collect_ide_iff
               set_category_is_categorical
                 [of S \<S> comp "\<lambda>A. A \<in> S.set ` Collect S.ide" "arr_of o \<phi>"]
         by simp
     qed
 
     sublocale category comp
       using is_category by blast
     sublocale set_category comp \<open>\<lambda>A. A \<subseteq> Collect S.terminal \<and> Setp (elem_of ` A)\<close>
       using is_set_category set_img_Collect_ide_iff by simp
     interpretation concrete_set_category comp \<open>\<lambda>A. A \<subseteq> Collect S.terminal \<and> Setp (elem_of ` A)\<close>
                        UNIV arr_of
       using is_concrete_set_category by simp
  
   end
 (*
   interpretation SetCat: setcat undefined \<open>\<lambda>S. True\<close>
     by unfold_locales auto
  *)
   text\<open>
     Here we discard the temporary interpretations \<open>S\<close>, leaving only the exported
     definitions and facts.
 \<close>
 
   context setcat
   begin
 
     text\<open>
       We establish mappings to pass back and forth between objects and arrows of the category
       and sets and functions on the underlying elements.
 \<close>
 
     interpretation set_category comp \<open>\<lambda>A. A \<subseteq> Collect terminal \<and> Setp (elem_of ` A)\<close>
       using is_set_category by blast
     interpretation concrete_set_category comp \<open>\<lambda>A. A \<subseteq> Univ \<and> Setp (elem_of ` A)\<close> UNIV arr_of
       using is_concrete_set_category by blast
 
     definition set_of_ide :: "'e setcat.arr \<Rightarrow> 'e set"
     where "set_of_ide a \<equiv> elem_of ` set a"
 
     definition ide_of_set :: "'e set \<Rightarrow> 'e setcat.arr"
     where "ide_of_set A \<equiv> mkIde (arr_of ` A)"
 
     lemma bij_betw_ide_set:
     shows "set_of_ide \<in> Collect ide \<rightarrow> Collect Setp"
     and "ide_of_set \<in> Collect Setp \<rightarrow> Collect ide"
     and [simp]: "ide a \<Longrightarrow> ide_of_set (set_of_ide a) = a"
     and [simp]: "Setp A \<Longrightarrow> set_of_ide (ide_of_set A) = A"
     and "bij_betw set_of_ide (Collect ide) (Collect Setp)"
     and "bij_betw ide_of_set (Collect Setp) (Collect ide)"
     proof -
       show 1: "set_of_ide \<in> Collect ide \<rightarrow> Collect Setp"
         using setp_set_ide set_of_ide_def by auto
       show 2: "ide_of_set \<in> Collect Setp \<rightarrow> Collect ide"
       proof
         fix A :: "'e set"
         assume A: "A \<in> Collect Setp"
         have "arr_of ` A \<subseteq> Univ"
           using A arr_of_mapsto by auto
         moreover have "Setp (elem_of ` arr_of ` A)"
           using A elem_of_arr_of Setp_respects_subset by simp
         ultimately have "ide (mkIde (arr_of ` A))"
           using ide_mkIde by blast
         thus "ide_of_set A \<in> Collect ide"
           using ide_of_set_def by simp
       qed
       show 3: "\<And>a. ide a \<Longrightarrow> ide_of_set (set_of_ide a) = a"
         using arr_of_img_elem_of_img ide_of_set_def mkIde_set set_of_ide_def setp_set_ide
         by presburger
       show 4: "\<And>A. Setp A \<Longrightarrow> set_of_ide (ide_of_set A) = A"
       proof -
         fix A :: "'e set"
         assume A: "Setp A"
         have "elem_of ` set (mkIde (arr_of ` A)) = elem_of ` arr_of ` A"
         proof -
           have "arr_of ` A \<subseteq> Univ"
             using A arr_of_mapsto by blast
           moreover have "Setp (elem_of ` arr_of ` A)"
             using A by simp
           ultimately have "set (mkIde (arr_of ` A)) = arr_of ` A"
             using A set_mkIde by blast
           thus ?thesis by auto
         qed
         also have "... = A"
           using A elem_of_arr_of by force
         finally show "set_of_ide (ide_of_set A) = A"
           using ide_of_set_def set_of_ide_def by simp
       qed
       show "bij_betw set_of_ide (Collect ide) (Collect Setp)"
         using 1 2 3 4
         by (intro bij_betwI) blast+
       show "bij_betw ide_of_set (Collect Setp) (Collect ide)"
         using 1 2 3 4
         by (intro bij_betwI) blast+
     qed
 
     definition fun_of_arr :: "'e setcat.arr \<Rightarrow> 'e \<Rightarrow> 'e"
     where "fun_of_arr f \<equiv> restrict (elem_of o Fun f o arr_of) (elem_of `Dom f)"
 
     definition arr_of_fun :: "'e set \<Rightarrow> 'e set \<Rightarrow> ('e \<Rightarrow> 'e) \<Rightarrow> 'e setcat.arr"
     where "arr_of_fun A B F \<equiv> mkArr (arr_of ` A) (arr_of ` B) (arr_of o F o elem_of)"
 
     lemma bij_betw_hom_fun:
     shows "fun_of_arr \<in> hom a b \<rightarrow> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
     and "\<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow> arr_of_fun A B \<in> (A \<rightarrow> B) \<rightarrow> hom (ide_of_set A) (ide_of_set B)"
     and "f \<in> hom a b \<Longrightarrow> arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
     and "\<lbrakk>Setp A; Setp B; F \<in> A \<rightarrow> B; F \<in> extensional A\<rbrakk> \<Longrightarrow> fun_of_arr (arr_of_fun A B F) = F"
     and "\<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> bij_betw fun_of_arr (hom a b)
                              (extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b))"
     and "\<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow>
             bij_betw (arr_of_fun A B)
                      (extensional A \<inter> (A \<rightarrow> B)) (hom (ide_of_set A) (ide_of_set B))"
     proof -
       show 1: "\<And>a b. fun_of_arr \<in>
                         hom a b \<rightarrow> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
       proof
         fix a b f
         assume f: "f \<in> hom a b"
         have Dom: "Dom f = arr_of ` set_of_ide a"
           using f set_of_ide_def
           by (metis (mono_tags, lifting) arr_dom arr_mkIde bij_betw_ide_set(3)
               ide_dom ide_of_set_def in_homE mem_Collect_eq set_mkIde)
         have Cod: "Cod f = arr_of ` set_of_ide b"
           using f set_of_ide_def
           by (metis (mono_tags, lifting) arr_cod arr_mkIde bij_betw_ide_set(3)
               ide_cod ide_of_set_def in_homE mem_Collect_eq set_mkIde)
         have "fun_of_arr f \<in> set_of_ide a \<rightarrow> set_of_ide b"
         proof
           fix x
           assume x: "x \<in> set_of_ide a"
           have 1: "arr_of x \<in> Dom f"
             using x Dom by blast
           hence "Fun f (arr_of x) \<in> Cod f"
             using f Fun_mapsto Cod by blast
           hence "elem_of (Fun f (arr_of x)) \<in> set_of_ide b"
             using Cod by auto
           hence "restrict (elem_of o Fun f o arr_of) (elem_of ` Dom f) x \<in> set_of_ide b"
             using 1 by force
           thus "fun_of_arr f x \<in> set_of_ide b"
             unfolding fun_of_arr_def by auto
         qed
         moreover have "fun_of_arr f \<in> extensional (set_of_ide a)"
           unfolding fun_of_arr_def
           using set_of_ide_def f by blast
         ultimately show "fun_of_arr f \<in> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
           by blast
       qed
       show 2: "\<And>A B. \<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow>
                         arr_of_fun A B \<in> (A \<rightarrow> B) \<rightarrow> hom (ide_of_set A) (ide_of_set B)"
       proof
         fix x and A B :: "'e set"
         assume A: "Setp A" and B: "Setp B"
         assume x: "x \<in> A \<rightarrow> B"
         show "arr_of_fun A B x \<in> hom (ide_of_set A) (ide_of_set B)"
         proof
           show "\<guillemotleft>arr_of_fun A B x : ide_of_set A \<rightarrow> ide_of_set B\<guillemotright>"
           proof
             show 1: "arr (arr_of_fun A B x)"
             proof -
               have "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
                 using A arr_of_mapsto elem_of_arr_of
                 by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2)
                     ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
               moreover have "arr_of ` B \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` B)"
                 using B arr_of_mapsto elem_of_arr_of
                 by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2)
                     ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
               moreover have "arr_of \<circ> x \<circ> elem_of \<in> arr_of ` A \<rightarrow> arr_of ` B"
                 using x by auto
               ultimately show ?thesis
                 unfolding arr_of_fun_def by blast
             qed
             show "dom (arr_of_fun A B x) = ide_of_set A"
               using 1 dom_mkArr ide_of_set_def arr_of_fun_def by simp
             show "cod (arr_of_fun A B x) = ide_of_set B"
               using 1 cod_mkArr ide_of_set_def arr_of_fun_def by simp
           qed
         qed
       qed
       show 3: "\<And>a b f. f \<in> hom a b \<Longrightarrow> arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
       proof -
         fix a b f
         assume f: "f \<in> hom a b"
         have 1: "Dom f = set a \<and> Cod f = set b"
           using f by blast
         have Dom: "Dom f \<subseteq> Univ \<and> Setp (elem_of ` Dom f)"
           using setp_set_ide f ide_dom by blast
         have Cod: "Cod f \<subseteq> Univ \<and> Setp (elem_of ` Cod f)"
           using setp_set_ide f ide_cod by blast
         have "mkArr (set a) (set b)
                     (arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of) =
               mkArr (Dom f) (Cod f)
                     (arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of)"
           using 1 by simp
         also have "... = mkArr (Dom f) (Cod f) (Fun f)"
         proof (intro mkArr_eqI')
           show 2: "\<And>x. x \<in> Dom f \<Longrightarrow>
                          (arr_of \<circ>
                             restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
                               elem_of) x =
                          Fun f x"
           proof -
             fix x
             assume x: "x \<in> Dom f"
             hence 1: "elem_of x \<in> elem_of ` Dom f"
               by blast
             have "(arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of) x =
                   arr_of (restrict (elem_of o Fun f o arr_of) (elem_of ` Dom f) (elem_of x))"
               by auto
             also have "... = arr_of ((elem_of o Fun f o arr_of) (elem_of x))"
               using 1 by auto
             also have "... = arr_of (elem_of (Fun f (arr_of (elem_of x))))"
               by auto
             also have "... = arr_of (elem_of (Fun f x))"
               using x arr_of_elem_of \<open>Dom f \<subseteq> Univ \<and> Setp (elem_of ` Dom f)\<close> by auto
             also have "... = Fun f x"
               using x f Dom Cod Fun_mapsto arr_of_elem_of [of "Fun f x"] by blast
             finally show "(arr_of \<circ>
                              restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
                                elem_of) x =
                           Fun f x"
               by blast
           qed
           have "arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of
                   \<in> Dom f \<rightarrow> Cod f"
           proof
             fix x
             assume x: "x \<in> Dom f"
             have "(arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of) x =
                   Fun f x"
               using 2 x by blast
             moreover have "... \<in> Cod f"
               using f x Fun_mapsto by blast
             ultimately show "(arr_of \<circ>
                                 restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
                                   elem_of) x
                                \<in> Cod f"
               by argo
           qed
           thus "arr (mkArr (Dom f) (Cod f)
                            (arr_of \<circ>
                               restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
                                 elem_of))"
             using Dom Cod by blast
         qed
         finally have "mkArr (set a) (set b)
                             (arr_of \<circ>
                                restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
                                  elem_of) = f"
           using f mkArr_Fun
           by (metis (no_types, lifting) in_homE mem_Collect_eq)
         thus "arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
           using 1 f
           by (metis (no_types, lifting) Cod Dom arr_of_img_elem_of_img arr_of_fun_def
               fun_of_arr_def set_of_ide_def)
       qed
       show 4: "\<And>A B F. \<lbrakk>Setp A; Setp B; F \<in> A \<rightarrow> B; F \<in> extensional A\<rbrakk>
                           \<Longrightarrow> fun_of_arr (arr_of_fun A B F) = F"
       proof
         fix F and A B :: "'e set"
         assume A: "Setp A" and B: "Setp B"
         assume F: "F \<in> A \<rightarrow> B" and ext: "F \<in> extensional A"
         have 4: "arr (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of))"
         proof -
           have "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
             using A
             by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2) ide_implies_incl
                 ide_of_set_def incl_def mem_Collect_eq)
           moreover have "arr_of ` B \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` B)"
             using B
             by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2) ide_implies_incl
                 ide_of_set_def incl_def mem_Collect_eq)
           moreover have "arr_of \<circ> F \<circ> elem_of \<in> arr_of ` A \<rightarrow> arr_of ` B"
             using F by auto
           ultimately show ?thesis by blast
         qed
         show "\<And>x. fun_of_arr (arr_of_fun A B F) x = F x"
         proof -
           fix x
           have "fun_of_arr (arr_of_fun A B F) x =
                 restrict (elem_of \<circ>
                             Fun (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of)) \<circ>
                               arr_of) A x"
           proof -
             have "elem_of ` Dom (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of)) = A"
               using A 4 elem_of_arr_of dom_mkArr set_of_ide_def bij_betw_ide_set(4) ide_of_set_def
               by auto
             thus ?thesis
               using arr_of_fun_def fun_of_arr_def by auto
           qed
           also have "... = F x"
           proof (cases "x \<in> A")
             show "x \<notin> A \<Longrightarrow> ?thesis"
               using ext extensional_arb by fastforce
             assume x: "x \<in> A"
             show "restrict
                     (elem_of \<circ>
                        Fun (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of)) \<circ>
                          arr_of) A x =
                   F x"
               using x 4 Fun_mkArr by simp
           qed
           finally show "fun_of_arr (arr_of_fun A B F) x = F x"
             by blast
         qed
       qed
       show "\<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow>
                bij_betw (arr_of_fun A B) (extensional A \<inter> (A \<rightarrow> B))
                         (hom (ide_of_set A) (ide_of_set B))"
       proof -
         assume A: "Setp A" and B: "Setp B"
         have "ide (ide_of_set A) \<and> ide (ide_of_set B)"
           using A B bij_betw_ide_set(2) by auto
         have "set_of_ide (ide_of_set A) = A \<and> set_of_ide (ide_of_set B) = B"
           using A B by simp
         show ?thesis
           using A B 1 [of "ide_of_set A" "ide_of_set B"] 2 3 4
           apply (intro bij_betwI)
              apply auto
            apply blast
           by fastforce
       qed
       show "\<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> bij_betw fun_of_arr (hom a b)
                                 (extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b))"
       proof (intro bij_betwI)
         assume a: "ide a" and b: "ide b"
         show "fun_of_arr \<in> hom a b \<rightarrow> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
           using 1 by blast
         show "arr_of_fun (set_of_ide a) (set_of_ide b) \<in>
                extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b) \<rightarrow> hom a b"
           using a b 2 [of "set_of_ide a" "set_of_ide b"] setp_set_ide set_of_ide_def
                 bij_betw_ide_set(3)
           by auto
         show "\<And>f. f \<in> hom a b \<Longrightarrow> arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
           using a b 3 by blast
         show "\<And>F. F \<in> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b) \<Longrightarrow>
                     fun_of_arr (arr_of_fun (set_of_ide a) (set_of_ide b) F) = F"
           using a b 4 [of "set_of_ide a" "set_of_ide b"]
           by (metis (no_types, lifting) IntE set_of_ide_def setp_set_ide)
       qed
     qed
 
     lemma fun_of_arr_ide:
     assumes "ide a"
     shows "fun_of_arr a = restrict id (elem_of ` Dom a)"
     proof
       fix x
       show "fun_of_arr a x = restrict id (elem_of ` Dom a) x"
       proof (cases "x \<in> elem_of ` Dom a")
         show "x \<notin> elem_of ` Dom a \<Longrightarrow> ?thesis"
           using fun_of_arr_def extensional_arb by auto
         assume x: "x \<in> elem_of ` Dom a"
         have "fun_of_arr a x = restrict (elem_of \<circ> Fun a \<circ> arr_of) (elem_of ` Dom a) x"
           using x fun_of_arr_def by simp
         also have "... = elem_of (Fun a (arr_of x))"
           using x by auto
         also have "... = elem_of ((\<lambda>x\<in>set a. x) (arr_of x))"
           using assms x Fun_ide by auto
         also have "... = elem_of (arr_of x)"
         proof -
           have "x \<in> elem_of ` set a"
             using assms x ideD(2) by force
           hence "arr_of x \<in> set a"
             by (metis (mono_tags, lifting) arr_of_img_elem_of_img assms image_eqI setp_set_ide)
           thus ?thesis by simp
         qed
         also have "... = x"
           by simp
         also have "... = restrict id (elem_of ` Dom a) x"
           using x by auto
         finally show ?thesis by blast
       qed
     qed
 
     lemma arr_of_fun_id:
     assumes "Setp A"
     shows "arr_of_fun A A (restrict id A) = ide_of_set A"
     proof -
       have A: "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
         using assms elem_of_arr_of
         by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2) ide_implies_incl
             ide_of_set_def incl_def mem_Collect_eq)
       have "arr_of_fun A A (restrict id A) =
             mkArr (arr_of ` A) (arr_of ` A) (arr_of \<circ> restrict id A \<circ> elem_of)"
         unfolding arr_of_fun_def by simp
       also have "... = mkArr (arr_of ` A) (arr_of ` A) (\<lambda>x. x)"
         using A arr_mkArr
         by (intro mkArr_eqI') auto
       also have "... = ide_of_set A"
         using A ide_of_set_def mkIde_as_mkArr by simp
       finally show ?thesis by blast
     qed
 
     lemma fun_of_arr_comp:
     assumes "f \<in> hom a b" and "g \<in> hom b c"
     shows "fun_of_arr (comp g f) = restrict (fun_of_arr g \<circ> fun_of_arr f) (set_of_ide a)"
     proof -
       have 1: "seq g f"
         using assms by blast
       have "fun_of_arr (comp g f) =
             restrict (elem_of \<circ> Fun (comp g f) \<circ> arr_of) (elem_of ` Dom (comp g f))"
         unfolding fun_of_arr_def by blast
       also have "... = restrict (elem_of \<circ> Fun (comp g f) \<circ> arr_of) (elem_of ` Dom f)"
         using assms dom_comp seqI' by auto
       also have "... = restrict (elem_of \<circ> restrict (Fun g \<circ> Fun f) (Dom f) \<circ> arr_of)
                                 (elem_of ` Dom f)"
         using 1 Fun_comp by auto
       also have "... = restrict (restrict (elem_of o Fun g o arr_of) (elem_of ` Dom g) \<circ>
                                    restrict (elem_of o Fun f o arr_of) (elem_of ` Dom f))
                                 (elem_of ` Dom f)"
       proof
         fix x
         show "restrict (elem_of \<circ> restrict (Fun g \<circ> Fun f) (Dom f) \<circ> arr_of) (elem_of ` Dom f) x =
               restrict (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
                           restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
                        (elem_of ` Dom f) x"
         proof (cases "x \<in> elem_of ` Dom f")
           show "x \<notin> elem_of ` Dom f \<Longrightarrow> ?thesis"
             by auto
           assume x: "x \<in> elem_of ` Dom f"
           have 2: "arr_of x \<in> Dom f"
           proof -
             have "arr_of x \<in> arr_of ` elem_of ` Dom f"
               using x by simp
             thus ?thesis
               by (metis (no_types, lifting) 1 arr_of_img_elem_of_img ide_dom seqE setp_set_ide)
           qed
           have 3: "Dom g = Cod f"
             using assms by fastforce
           have "restrict (elem_of \<circ> restrict (Fun g \<circ> Fun f) (Dom f) \<circ> arr_of) (elem_of ` Dom f) x =
                 elem_of (Fun g (Fun f (arr_of x)))"
             using x 2 by simp
           also have "... = restrict
                              (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
                                 restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
                              (elem_of ` Dom f) x"
           proof -
             have "restrict (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
                               restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
                            (elem_of ` Dom f) x =
                   elem_of (Fun g (Fun f (arr_of x)))"
             proof -
               have "restrict (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
                                 restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
                              (elem_of ` Dom f) x =
                     (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) o
                        restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f)) x"
                 using 2 by force
               also have "... = restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g)
                                  (restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) x)"
                 by simp
               also have "... = restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g)
                                  (elem_of (Fun f (arr_of x)))"
                 using 2 by force
               also have "... = (elem_of o Fun g o arr_of) (elem_of (Fun f (arr_of x)))"
               proof -
                 have "elem_of (Fun f (arr_of x)) \<in> elem_of ` Dom g"
                   using assms 2 3 Fun_mapsto [of f] by blast
                 thus ?thesis by simp
               qed
               also have "... = elem_of (Fun g (arr_of (elem_of (Fun f (arr_of x)))))"
                 by simp
               also have "... = elem_of (Fun g (Fun f (arr_of x)))"
               proof -
                 have "Fun f (arr_of x) \<in> Univ"
                   using assms 2 setp_set_ide ide_cod Fun_mapsto by blast
                 thus ?thesis
                   using 2 by simp
               qed
               finally show ?thesis by blast
             qed
             thus ?thesis by simp
           qed
           finally show ?thesis by blast
         qed
       qed
       also have "... = restrict (fun_of_arr g o fun_of_arr f) (elem_of ` Dom f)"
         unfolding fun_of_arr_def by blast
       finally show ?thesis
         unfolding set_of_ide_def
         using assms by blast
     qed
 
     lemma arr_of_fun_comp:
     assumes "Setp A" and "Setp B" and "Setp C"
     and "F \<in> extensional A \<inter> (A \<rightarrow> B)" and "G \<in> extensional B \<inter> (B \<rightarrow> C)"
     shows "arr_of_fun A C (G o F) = comp (arr_of_fun B C G) (arr_of_fun A B F)"
     proof -
       have A: "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
         using assms elem_of_arr_of
         by (metis (no_types, lifting) Pi_iff arr_mkIde bij_betw_ide_set(2)
             ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
       have B: "arr_of ` B \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` B)"
         using assms elem_of_arr_of
         by (metis (no_types, lifting) Pi_iff arr_mkIde bij_betw_ide_set(2)
             ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
       have C: "arr_of ` C \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` C)"
         using assms elem_of_arr_of
         by (metis (no_types, lifting) Pi_iff arr_mkIde bij_betw_ide_set(2)
             ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
       have "arr_of_fun A C (G o F) = mkArr (arr_of ` A) (arr_of ` C) (arr_of \<circ> (G \<circ> F) \<circ> elem_of)"
         unfolding arr_of_fun_def by simp
       also have "... = mkArr (arr_of ` A) (arr_of ` C)
                              ((arr_of \<circ> G \<circ> elem_of) o (arr_of o F \<circ> elem_of))"
       proof (intro mkArr_eqI')
         show "arr (mkArr (arr_of ` A) (arr_of ` C) (arr_of \<circ> (G \<circ> F) \<circ> elem_of))"
         proof -
           have "arr_of \<circ> (G \<circ> F) \<circ> elem_of \<in> arr_of ` A \<rightarrow> arr_of ` C"
             using assms by force
           thus ?thesis
             using A B C by blast
         qed
         show "\<And>x. x \<in> arr_of ` A \<Longrightarrow>
                     (arr_of \<circ> (G \<circ> F) \<circ> elem_of) x =
                     ((arr_of \<circ> G \<circ> elem_of) o (arr_of o F \<circ> elem_of)) x"
           by simp
       qed
       also have "... = comp (mkArr (arr_of ` B) (arr_of ` C) (arr_of \<circ> G \<circ> elem_of))
                             (mkArr (arr_of ` A) (arr_of ` B) (arr_of o F o elem_of))"
       proof -
         have "arr (mkArr (arr_of ` B) (arr_of ` C) (arr_of \<circ> G \<circ> elem_of))"
           using assms B C elem_of_arr_of by fastforce
         moreover have "arr (mkArr (arr_of ` A) (arr_of ` B) (arr_of o F o elem_of))"
           using assms A B elem_of_arr_of by fastforce
         ultimately show ?thesis
           using comp_mkArr by auto
       qed
       also have "... = comp (arr_of_fun B C G) (arr_of_fun A B F)"
         using arr_of_fun_def by presburger
       finally show ?thesis by blast
     qed
 
   end
 
   text\<open>
     When there is no restriction on the sets that determine objects, the resulting set category
     is replete.  This is the normal use case, which we want to streamline as much as possible,
     so it is useful to introduce a special locale for this purpose.
   \<close>
 
   locale replete_setcat =
   fixes dummy :: 'e
   begin
 
     interpretation SC: setcat dummy \<open>\<lambda>_. True\<close>
       by unfold_locales blast
 
     definition comp
     where "comp \<equiv> SC.comp"
 
     definition arr_of
     where "arr_of \<equiv> SC.arr_of"
 
     definition elem_of
     where "elem_of \<equiv> SC.elem_of"
 
     sublocale replete_set_category comp
       unfolding comp_def
       using SC.is_set_category replete_set_category_def set_category_def by auto
 
     lemma is_replete_set_category:
     shows "replete_set_category comp"
       ..
 
     lemma is_set_category\<^sub>R\<^sub>S\<^sub>C:
     shows "set_category comp (\<lambda>A. A \<subseteq> Univ)"
       using is_set_category by blast
 
     sublocale concrete_set_category comp setp UNIV arr_of
       using SC.is_concrete_set_category comp_def SC.set_img_Collect_ide_iff arr_of_def
       by auto
 
     lemma is_concrete_set_category:
     shows "concrete_set_category comp setp UNIV arr_of"
       ..
 
     lemma bij_arr_of:
     shows "bij_betw arr_of UNIV Univ"
       using SC.bij_arr_of comp_def arr_of_def by presburger
 
     lemma bij_elem_of:
     shows "bij_betw elem_of Univ UNIV"
       using SC.bij_elem_of comp_def elem_of_def by auto
 
   end
 (*
   interpretation RepleteSetCat: replete_setcat undefined .
  *)
 end