diff --git a/thys/Bicategory/Bicategory.thy b/thys/Bicategory/Bicategory.thy
--- a/thys/Bicategory/Bicategory.thy
+++ b/thys/Bicategory/Bicategory.thy
@@ -1,2434 +1,2336 @@
 (*  Title:       Bicategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 theory Bicategory
 imports Prebicategory Category3.Subcategory Category3.DiscreteCategory
         MonoidalCategory.MonoidalCategory
 begin
 
   section "Bicategories"
 
   text \<open>
     A \emph{bicategory} is a (vertical) category that has been equipped with
     a horizontal composition, an associativity natural isomorphism,
     and for each object a ``unit isomorphism'', such that horizontal
     composition on the left by target and on the right by source are
     fully faithful endofunctors of the vertical category, and such that
     the usual pentagon coherence condition holds for the associativity.
   \<close>
 
   locale bicategory =
     horizontal_composition V H src trg +
     \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
          \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
     L: fully_faithful_functor V V L +
     R: fully_faithful_functor V V R
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a" +
   assumes unit_in_vhom: "obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
   and iso_unit: "obj a \<Longrightarrow> iso \<i>[a]"
   and pentagon: "\<lbrakk> ide f; ide g; ide h; ide k; src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
                    (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) = \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
   begin
     (*
      * TODO: the mapping \<i> is not currently assumed to be extensional.
      * It might be best in the long run if it were.
      *)
 
     definition \<alpha>
     where "\<alpha> \<mu>\<nu>\<tau> \<equiv> \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
 
     lemma assoc_in_hom':
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "in_hhom \<a>[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
     and "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<tau>\<guillemotright>"
     proof -
       show "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<tau>\<guillemotright>"
       proof -
         have 1: "VVV.in_hom (\<mu>, \<nu>, \<tau>) (dom \<mu>, dom \<nu>, dom \<tau>) (cod \<mu>, cod \<nu>, cod \<tau>)"
           using assms VVV.in_hom_char VVV.arr_char VV.arr_char by auto
         have "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : HoHV (dom \<mu>, dom \<nu>, dom \<tau>) \<Rightarrow> HoVH (cod \<mu>, cod \<nu>, cod \<tau>)\<guillemotright>"
           using 1 \<alpha>.preserves_hom by auto
         moreover have "HoHV (dom \<mu>, dom \<nu>, dom \<tau>) = (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau>"
           using 1 HoHV_def by (simp add: VVV.in_hom_char)
         moreover have "HoVH (cod \<mu>, cod \<nu>, cod \<tau>) = cod \<mu> \<star> cod \<nu> \<star> cod \<tau>"
           using 1 HoVH_def by (simp add: VVV.in_hom_char)
         ultimately show ?thesis by simp
       qed
       thus "in_hhom \<a>[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
         using assms src_cod trg_cod vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
     qed
 
     lemma assoc_is_natural_1:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "\<a>[\<mu>, \<nu>, \<tau>] = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
       using assms \<alpha>.is_natural_1 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char VVV.dom_char
             HoVH_def src_dom trg_dom
       by simp
 
     lemma assoc_is_natural_2:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "\<a>[\<mu>, \<nu>, \<tau>] = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
       using assms \<alpha>.is_natural_2 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char VVV.cod_char
             HoHV_def src_dom trg_dom
       by simp
 
     lemma assoc_naturality:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "\<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>) = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
       using assms \<alpha>.naturality VVV.arr_char VV.arr_char HoVH_def HoHV_def
             VVV.dom_char VVV.cod_char
       by auto
 
     lemma assoc_in_hom [intro]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "in_hhom \<a>[f, g, h] (src h) (trg f)"
     and "\<guillemotleft>\<a>[f, g, h] : (dom f \<star> dom g) \<star> dom h \<Rightarrow> cod f \<star> cod g \<star> cod h\<guillemotright>"
       using assms assoc_in_hom' apply auto[1]
       using assms assoc_in_hom' ideD(1) by metis
 
     lemma assoc_simps [simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "arr \<a>[f, g, h]"
     and "src \<a>[f, g, h] = src h" and "trg \<a>[f, g, h] = trg f"
     and "dom \<a>[f, g, h] = (dom f \<star> dom g) \<star> dom h"
     and "cod \<a>[f, g, h] = cod f \<star> cod g \<star> cod h"
       using assms assoc_in_hom apply auto
       using assoc_in_hom(1) by auto
 
     lemma iso_assoc [intro, simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "iso \<a>[f, g, h]"
       using assms \<alpha>.components_are_iso [of "(f, g, h)"] VVV.ide_char VVV.arr_char VV.arr_char
       by simp
 
   end
 
   subsection "Categories Induce Bicategories"
 
   text \<open>
     In this section we show that a category becomes a bicategory if we take the vertical
     composition to be discrete, we take the composition of the category as the
     horizontal composition, and we take the vertical domain and codomain as \<open>src\<close> and \<open>trg\<close>.
   \<close>
 
   (*
    * It is helpful to make a few local definitions here, but I don't want them to
    * clutter the category locale.  Using a context and private definitions does not
    * work as expected.  So we have to define a new locale just for the present purpose.
    *)
   locale category_as_bicategory = category
   begin
 
     interpretation V: discrete_category \<open>Collect arr\<close> null
       using not_arr_null by (unfold_locales, blast)
 
     abbreviation V
     where "V \<equiv> V.comp"
 
     interpretation src: "functor" V V dom
       using V.null_char
       by (unfold_locales, simp add: has_domain_iff_arr dom_def, auto)
     interpretation trg: "functor" V V cod
       using V.null_char
       by (unfold_locales, simp add: has_codomain_iff_arr cod_def, auto)
 
     interpretation H: horizontal_homs V dom cod
       by (unfold_locales, auto)
 
     interpretation H: "functor" H.VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<cdot> snd \<mu>\<nu>\<close>
       apply (unfold_locales)
       using H.VV.arr_char V.null_char ext
           apply force
       using H.VV.arr_char V.null_char H.VV.dom_char H.VV.cod_char
          apply auto[3]
     proof -
       show "\<And>g f. H.VV.seq g f \<Longrightarrow>
                    fst (H.VV.comp g f) \<cdot> snd (H.VV.comp g f) = V (fst g \<cdot> snd g) (fst f \<cdot> snd f)"
       proof -
         have 0: "\<And>f. H.VV.arr f \<Longrightarrow> V.arr (fst f \<cdot> snd f)"
           using H.VV.arr_char by auto
         have 1: "\<And>f g. V.seq g f \<Longrightarrow> V.ide f \<and> g = f"
           using V.arr_char V.dom_char V.cod_char V.not_arr_null by force
         have 2: "\<And>f g. H.VxV.seq g f \<Longrightarrow> H.VxV.ide f \<and> g = f"
           using 1 H.VxV.seq_char by (metis H.VxV.dom_eqI H.VxV.ide_Ide)
         fix f g
         assume fg: "H.VV.seq g f"
         have 3: "H.VV.ide f \<and> f = g"
           using fg 2 H.VV.seq_char H.VV.ide_char by blast
         show "fst (H.VV.comp g f) \<cdot> snd (H.VV.comp g f) = V (fst g \<cdot> snd g) (fst f \<cdot> snd f)"
           using fg 0 1 3 H.VV.comp_char H.VV.arr_char H.VV.ide_char V.arr_char V.comp_char
                 H.VV.comp_arr_ide
           by (metis (no_types, lifting))
       qed
     qed
 
     interpretation H: horizontal_composition V C dom cod
       by (unfold_locales, auto)
 
     abbreviation \<a>
     where "\<a> f g h \<equiv> f \<cdot> g \<cdot> h"
 
     interpretation \<alpha>: natural_isomorphism H.VVV.comp V H.HoHV H.HoVH
                         \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close>
       apply unfold_locales
       using V.null_char ext
            apply fastforce
       using H.HoHV_def H.HoVH_def H.VVV.arr_char H.VV.arr_char H.VVV.dom_char
             H.VV.dom_char H.VVV.cod_char H.VV.cod_char H.VVV.ide_char comp_assoc
       by auto
 
     interpretation fully_faithful_functor V V H.R
       using comp_arr_dom by (unfold_locales, auto)
     interpretation fully_faithful_functor V V H.L
       using comp_cod_arr by (unfold_locales, auto)
 
     abbreviation \<i>
     where "\<i> \<equiv> \<lambda>x. x"
 
     proposition induces_bicategory:
     shows "bicategory V C \<a> \<i> dom cod"
       apply (unfold_locales, auto simp add: comp_assoc)
       using comp_arr_dom by fastforce
 
   end
 
   subsection "Monoidal Categories induce Bicategories"
 
   text \<open>
     In this section we show that our definition of bicategory directly generalizes our
     definition of monoidal category:
     a monoidal category becomes a bicategory when equipped with the constant-\<open>\<I>\<close> functors
     as src and trg and \<open>\<iota>\<close> as the unit isomorphism from \<open>\<I> \<otimes> \<I>\<close> to \<open>\<I>\<close>.
     There is a slight mismatch because the bicategory locale assumes that the associator
     is given in curried form, whereas for monoidal categories it is given in tupled form.
     Ultimately, the monoidal category locale should be revised to also use curried form,
     which ends up being more convenient in most situations.
   \<close>
 
   context monoidal_category
   begin
 
     interpretation I: constant_functor C C \<I>
       using \<iota>_in_hom by unfold_locales auto
     interpretation horizontal_homs C I.map I.map
       by unfold_locales auto
 
     lemma CC_eq_VV:
     shows "CC.comp = VV.comp"
     proof -
       have "\<And>g f. CC.comp g f = VV.comp g f"
       proof -
         fix f g
         show "CC.comp g f = VV.comp g f"
         proof -
           have "CC.seq g f \<Longrightarrow> CC.comp g f = VV.comp g f"
             using VV.comp_char VV.arr_char CC.seq_char
             by (elim CC.seqE seqE, simp)
           moreover have "\<not> CC.seq g f \<Longrightarrow> CC.comp g f = VV.comp g f"
             using VV.seq_char VV.ext VV.null_char CC.ext
             by (metis (no_types, lifting))
           ultimately show ?thesis by blast
         qed
       qed
       thus ?thesis by blast
     qed
 
     lemma CCC_eq_VVV:
     shows "CCC.comp = VVV.comp"
     proof -
       have "\<And>g f. CCC.comp g f = VVV.comp g f"
       proof -
         fix f g
         show "CCC.comp g f = VVV.comp g f"
         proof -
           have "CCC.seq g f \<Longrightarrow> CCC.comp g f = VVV.comp g f"
             by (metis (no_types, lifting) CC.arrE CCC.seqE CC_eq_VV I.map_simp
                 I.preserves_reflects_arr VV.seq_char VVV.arrI VVV.comp_simp VVV.seq_char
                 trg_vcomp vseq_implies_hpar(1))
           moreover have "\<not> CCC.seq g f \<Longrightarrow> CCC.comp g f = VVV.comp g f"
             using VVV.seq_char VVV.ext VVV.null_char CCC.ext
             by (metis (no_types, lifting))
           ultimately show ?thesis by blast
         qed
       qed
       thus ?thesis by blast
     qed
 
     interpretation H: "functor" VV.comp C \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<otimes> snd \<mu>\<nu>\<close>
       using CC_eq_VV T.functor_axioms by simp
     interpretation H: horizontal_composition C tensor I.map I.map
       by (unfold_locales, simp_all)
 
     lemma HoHV_eq_ToTC:
     shows "H.HoHV = T.ToTC"
       using H.HoHV_def T.ToTC_def CCC_eq_VVV by presburger
 
     lemma HoVH_eq_ToCT:
     shows "H.HoVH = T.ToCT"
       using H.HoVH_def T.ToCT_def CCC_eq_VVV by presburger
 
     interpretation \<alpha>: natural_isomorphism VVV.comp C H.HoHV H.HoVH \<alpha>
       using \<alpha>.natural_isomorphism_axioms CCC_eq_VVV HoHV_eq_ToTC HoVH_eq_ToCT
       by simp
 
     lemma R'_eq_R:
     shows "H.R = R"
       using H.is_extensional CC_eq_VV CC.arr_char by force
 
     lemma L'_eq_L:
     shows "H.L = L"
       using H.is_extensional CC_eq_VV CC.arr_char by force
 
     interpretation R': fully_faithful_functor C C H.R
       using R'_eq_R R.fully_faithful_functor_axioms unity_def by auto
     interpretation L': fully_faithful_functor C C H.L
       using L'_eq_L L.fully_faithful_functor_axioms unity_def by auto
 
     lemma obj_char:
     shows "obj a \<longleftrightarrow> a = \<I>"
       using obj_def [of a] \<iota>_in_hom by fastforce
 
     proposition induces_bicategory:
     shows "bicategory C tensor (\<lambda>\<mu> \<nu> \<tau>. \<alpha> (\<mu>, \<nu>, \<tau>)) (\<lambda>_. \<iota>) I.map I.map"
       using obj_char \<iota>_in_hom \<iota>_is_iso pentagon \<alpha>.is_extensional \<alpha>.is_natural_1 \<alpha>.is_natural_2
       by unfold_locales simp_all
 
   end
 
   subsection "Prebicategories Extend to Bicategories"
 
   text \<open>
     In this section, we show that a prebicategory with homs and units extends to a bicategory.
     The main work is to show that the endofunctors \<open>L\<close> and \<open>R\<close> are fully faithful.
     We take the left and right unitor isomorphisms, which were obtained via local
     constructions in the left and right hom-subcategories defined by a specified
     weak unit, and show that in the presence of the chosen sources and targets they
     are the components of a global natural isomorphisms \<open>\<ll>\<close> and \<open>\<rr>\<close> from the endofunctors
     \<open>L\<close> and \<open>R\<close> to the identity functor.  A consequence is that functors \<open>L\<close> and \<open>R\<close> are
     endo-equivalences, hence fully faithful.
   \<close>
 
   context prebicategory_with_homs
   begin
 
     text \<open>
       Once it is equipped with a particular choice of source and target for each arrow,
       a prebicategory determines a horizontal composition.
     \<close>
 
     lemma induces_horizontal_composition:
     shows "horizontal_composition V H src trg"
     proof -
       interpret H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
       proof -
         have "VV.comp = VoV.comp"
           using composable_char\<^sub>P\<^sub>B\<^sub>H by meson
         thus "functor VV.comp V (\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>)"
           using functor_axioms by argo
       qed
       show "horizontal_composition V H src trg"
         using src_hcomp' trg_hcomp' composable_char\<^sub>P\<^sub>B\<^sub>H not_arr_null
         by (unfold_locales; metis)
     qed
 
   end
 
   sublocale prebicategory_with_homs \<subseteq> horizontal_composition V H src trg
     using induces_horizontal_composition by auto
 
   locale prebicategory_with_homs_and_units =
     prebicategory_with_units +
     prebicategory_with_homs
   begin
 
     no_notation in_hom                ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     text \<open>
       The next definitions extend the left and right unitors that were defined locally with
       respect to a particular weak unit, to globally defined versions using the chosen
       source and target for each arrow.
     \<close>
 
     definition lunit  ("\<l>[_]")
     where "lunit f \<equiv> left_hom_with_unit.lunit V H \<a> \<i>[trg f] (trg f) f"
 
     definition runit  ("\<r>[_]")
     where "runit f \<equiv> right_hom_with_unit.runit V H \<a> \<i>[src f] (src f) f"
 
     lemma lunit_in_hom:
     assumes "ide f"
     shows "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
     proof -
       interpret Left: subcategory V \<open>left (trg f)\<close>
         using assms left_hom_is_subcategory by simp
       interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[trg f]\<close> \<open>trg f\<close>
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       have 0: "Left.ide f"
         using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
       show 1: "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
         unfolding lunit_def
         using assms 0 Left.lunit_char(1) Left.hom_char H\<^sub>L_def by auto
       show "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
         using 1 src_cod trg_cod src_in_sources trg_in_targets
         by (metis arrI vconn_implies_hpar)
     qed
 
     lemma runit_in_hom:
     assumes "ide f"
     shows "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
     proof -
       interpret Right: subcategory V \<open>right (src f)\<close>
         using assms right_hom_is_subcategory weak_unit_self_composable by force
       interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[src f]\<close> \<open>src f\<close>
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       have 0: "Right.ide f"
         using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
       show 1: "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
         unfolding runit_def
         using assms 0 Right.runit_char(1) Right.hom_char H\<^sub>R_def by auto
       show "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
         using 1 src_cod trg_cod src_in_sources trg_in_targets
         by (metis arrI vconn_implies_hpar)
     qed
 
     text \<open>
       The characterization of the locally defined unitors yields a corresponding characterization
       of the globally defined versions, by plugging in the chosen source or target for each
       arrow for the unspecified weak unit in the the local versions.
     \<close>
 
     lemma lunit_char:
     assumes "ide f"
     shows "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
     and "trg f \<star> \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and> trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
     proof -
       let ?a = "src f" and ?b = "trg f"
       interpret Left: subcategory V \<open>left ?b\<close>
         using assms left_hom_is_subcategory weak_unit_self_composable by force
       interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       have 0: "Left.ide f"
         using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
       show "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
         using assms lunit_in_hom by simp
       show A: "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
         using assms lunit_in_hom by simp
       show B: "?b \<star> \<l>[f] = (\<i>[?b] \<star> f) \<cdot> inv \<a>[?b, ?b, f]"
         unfolding lunit_def using 0 Left.lunit_char(2) H\<^sub>L_def
         by (metis Left.comp_simp Left.characteristic_iso(1-2) Left.seqI')
       show "\<exists>!\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and> trg f \<star> \<mu> = (\<i>[?b] \<star> f) \<cdot> inv \<a>[?b, ?b, f]"
       proof -
         have 1: "hom (trg f \<star> f) f = Left.hom (Left.L f) f"
         proof
           have 1: "Left.L f = ?b \<star> f"
           using 0 H\<^sub>L_def by simp
           show "Left.hom (Left.L f) f \<subseteq> hom (?b \<star> f) f"
             using assms Left.hom_char [of "?b \<star> f" f] H\<^sub>L_def by simp
           show "hom (?b \<star> f) f \<subseteq> Left.hom (Left.L f) f"
             using assms 1 ide_in_hom composable_char\<^sub>P\<^sub>B\<^sub>H hom_connected left_def
                   Left.hom_char
             by auto
         qed
         let ?P = "\<lambda>\<mu>. Left.in_hom \<mu> (Left.L f) f"
         let ?P' = "\<lambda>\<mu>. \<guillemotleft>\<mu> : ?b \<star> f \<Rightarrow> f\<guillemotright>"
         let ?Q = "\<lambda>\<mu>. Left.L \<mu> = (\<i>[?b] \<star> f) \<cdot> (inv \<a>[?b, ?b, f])"
         let ?R = "\<lambda>\<mu>. ?b \<star> \<mu> = (\<i>[?b] \<star> f) \<cdot> (inv \<a>[?b, ?b, f])"
         have 2: "?P = ?P'"
           using 0 1 H\<^sub>L_def Left.hom_char by blast
         moreover have "\<forall>\<mu>. ?P \<mu> \<longrightarrow> (?Q \<mu> \<longleftrightarrow> ?R \<mu>)"
           using 2 Left.lunit_eqI H\<^sub>L_def by presburger
         moreover have "(\<exists>!\<mu>. ?P \<mu> \<and> ?Q \<mu>)"
           using 0 2 A B Left.lunit_char(3) Left.ide_char Left.arr_char
           by (metis (no_types, lifting) Left.lunit_char(2) calculation(2) lunit_def)
         ultimately show ?thesis by metis
       qed
     qed
 
     lemma runit_char:
     assumes "ide f"
     shows "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
     and "\<r>[f] \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and> \<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
     proof -
       let ?a = "src f" and ?b = "trg f"
       interpret Right: subcategory V \<open>right ?a\<close>
         using assms right_hom_is_subcategory weak_unit_self_composable by force
       interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       have 0: "Right.ide f"
         using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
       show "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
         using assms runit_in_hom by simp
       show A: "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
         using assms runit_in_hom by simp
       show B: "\<r>[f] \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
         unfolding runit_def using 0 Right.runit_char(2) H\<^sub>R_def
         using Right.comp_simp Right.characteristic_iso(4) Right.iso_is_arr by auto
       show "\<exists>!\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and> \<mu> \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
       proof -
         have 1: "hom (f \<star> ?a) f = Right.hom (Right.R f) f"
         proof
           have 1: "Right.R f = f \<star> ?a"
           using 0 H\<^sub>R_def by simp
           show "Right.hom (Right.R f) f \<subseteq> hom (f \<star> ?a) f"
             using assms Right.hom_char [of "f \<star> ?a" f] H\<^sub>R_def by simp
           show "hom (f \<star> ?a) f \<subseteq> Right.hom (Right.R f) f"
             using assms 1 ide_in_hom composable_char\<^sub>P\<^sub>B\<^sub>H hom_connected right_def
                   Right.hom_char
             by auto
         qed
         let ?P = "\<lambda>\<mu>. Right.in_hom \<mu> (Right.R f) f"
         let ?P' = "\<lambda>\<mu>. \<guillemotleft>\<mu> : f \<star> ?a \<Rightarrow> f\<guillemotright>"
         let ?Q = "\<lambda>\<mu>. Right.R \<mu> = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
         let ?R = "\<lambda>\<mu>. \<mu> \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
         have 2: "?P = ?P'"
           using 0 1 H\<^sub>R_def Right.hom_char by blast
         moreover have "\<forall>\<mu>. ?P \<mu> \<longrightarrow> (?Q \<mu> \<longleftrightarrow> ?R \<mu>)"
           using 2 Right.runit_eqI H\<^sub>R_def by presburger
         moreover have "(\<exists>!\<mu>. ?P \<mu> \<and> ?Q \<mu>)"
           using 0 2 A B Right.runit_char(3) Right.ide_char Right.arr_char
           by (metis (no_types, lifting) Right.runit_char(2) calculation(2) runit_def)
         ultimately show ?thesis by metis
       qed
     qed
 
     lemma lunit_eqI:
     assumes "ide f" and "\<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
     and "trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> (inv \<a>[trg f, trg f, f])"
     shows "\<mu> = \<l>[f]"
       using assms lunit_char(2-4) by blast
 
     lemma runit_eqI:
     assumes "ide f" and "\<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
     and "\<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
     shows "\<mu> = \<r>[f]"
       using assms runit_char(2-4) by blast
 
     lemma iso_lunit:
     assumes "ide f"
     shows "iso \<l>[f]"
     proof -
       let ?b = "trg f"
       interpret Left: subcategory V \<open>left ?b\<close>
         using assms left_hom_is_subcategory weak_unit_self_composable by force
       interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       show ?thesis
       proof -
         have 0: "Left.ide f"
           using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
         thus ?thesis
           unfolding lunit_def using Left.iso_lunit Left.iso_char by blast
       qed
     qed
 
     lemma iso_runit:
     assumes "ide f"
     shows "iso \<r>[f]"
     proof -
       let ?a = "src f"
       interpret Right: subcategory V \<open>right ?a\<close>
         using assms right_hom_is_subcategory weak_unit_self_composable by force
       interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       show ?thesis
       proof -
         have 0: "Right.ide f"
           using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
         thus ?thesis
           unfolding runit_def using Right.iso_runit Right.iso_char by blast
       qed
     qed
 
     lemma lunit_naturality:
     assumes "arr \<mu>"
     shows "\<mu> \<cdot> \<l>[dom \<mu>] = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
     proof -
       let ?a = "src \<mu>" and ?b = "trg \<mu>"
       interpret Left: subcategory V \<open>left ?b\<close>
         using assms obj_trg left_hom_is_subcategory weak_unit_self_composable by force
       interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       interpret Left.L: endofunctor \<open>Left ?b\<close> Left.L
         using assms endofunctor_H\<^sub>L [of ?b] weak_unit_self_composable obj_trg obj_is_weak_unit
         by blast
       have 1: "Left.in_hom \<mu> (dom \<mu>) (cod \<mu>)"
         using assms Left.hom_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H obj_trg by auto
       have 2: "Left.in_hom \<l>[Left.dom \<mu>] (?b \<star> dom \<mu>) (dom \<mu>)"
         unfolding lunit_def
         using assms 1 Left.in_hom_char trg_dom Left.lunit_char(1) H\<^sub>L_def
               Left.arr_char Left.dom_char Left.ide_dom
         by force
       have 3: "Left.in_hom \<l>[Left.cod \<mu>] (?b \<star> cod \<mu>) (cod \<mu>)"
         unfolding lunit_def
         using assms 1 Left.in_hom_char trg_cod Left.lunit_char(1) H\<^sub>L_def
               Left.cod_char Left.ide_cod
         by force
       have 4: "Left.in_hom (Left.L \<mu>) (?b \<star> dom \<mu>) (?b \<star> cod \<mu>)"
         using 1 Left.L.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] H\<^sub>L_def by auto
       show ?thesis
-      proof -
-        have "\<mu> \<cdot> \<l>[dom \<mu>] = Left.comp \<mu> \<l>[Left.dom \<mu>]"
-          using 1 2 Left.comp_simp by fastforce
-        also have "... = Left.comp \<mu> (Left.lunit (Left.dom \<mu>))"
-          using assms 1 lunit_def by auto
-        also have "... = Left.comp (Left.lunit (Left.cod \<mu>)) (Left.L \<mu>)"
-          using 1 Left.lunit_naturality Left.cod_simp by auto
-        also have "... = Left.comp (lunit (Left.cod \<mu>)) (Left.L \<mu>)"
-          using assms 1 lunit_def by auto
-        also have "... = \<l>[cod \<mu>] \<cdot> Left.L \<mu>"
-          using 1 3 4 Left.comp_char Left.cod_char Left.in_hom_char by auto
-        also have "... = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
-          using 1 by (simp add: H\<^sub>L_def)
-        finally show ?thesis by simp
-      qed
+        by (metis "1" "2" H\<^sub>L_def Left.comp_simp Left.in_homE Left.lunit_naturality
+            Left.seqI' lunit_def trg_cod trg_dom)
     qed
 
     lemma runit_naturality:
     assumes "arr \<mu>"
     shows "\<mu> \<cdot> \<r>[dom \<mu>] = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> src \<mu>)"
     proof -
       let ?a = "src \<mu>" and ?b = "trg \<mu>"
       interpret Right: subcategory V \<open>right ?a\<close>
         using assms right_hom_is_subcategory weak_unit_self_composable by force
       interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
         using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
       interpret Right.R: endofunctor \<open>Right ?a\<close> Right.R
         using assms endofunctor_H\<^sub>R [of ?a] weak_unit_self_composable obj_src obj_is_weak_unit
         by blast
       have 1: "Right.in_hom \<mu> (dom \<mu>) (cod \<mu>)"
         using assms Right.hom_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
       have 2: "Right.in_hom \<r>[Right.dom \<mu>] (dom \<mu> \<star> ?a) (dom \<mu>)"
         unfolding runit_def
         using 1 Right.in_hom_char trg_dom Right.runit_char(1) [of "Right.dom \<mu>"] H\<^sub>R_def
               Right.arr_char Right.dom_char Right.ide_dom assms
         by force
       have 3: "\<r>[Right.cod \<mu>] \<in> Right.hom (cod \<mu> \<star> ?a) (cod \<mu>)"
         unfolding runit_def
         using 1 Right.in_hom_char trg_cod Right.runit_char(1) [of "Right.cod \<mu>"] H\<^sub>R_def
               Right.cod_char Right.ide_cod assms
         by force
       have 4: "Right.R \<mu> \<in> Right.hom (dom \<mu> \<star> ?a) (cod \<mu> \<star> ?a)"
         using 1 Right.R.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] H\<^sub>R_def by auto
       show ?thesis
-      proof -
-        have "\<mu> \<cdot> \<r>[dom \<mu>] = Right.comp \<mu> \<r>[Right.dom \<mu>]"
-          by (metis 1 2 Right.comp_char Right.in_homE Right.seqI' Right.seq_char)
-        also have "... = Right.comp \<mu> (Right.runit (Right.dom \<mu>))"
-          using assms 1 src_dom trg_dom Right.hom_char runit_def by auto
-        also have "... = Right.comp (Right.runit (Right.cod \<mu>)) (Right.R \<mu>)"
-          using 1 Right.runit_naturality Right.cod_simp by auto
-        also have "... = Right.comp (runit (Right.cod \<mu>)) (Right.R \<mu>)"
-          using assms 1 runit_def by auto
-        also have "... = \<r>[cod \<mu>] \<cdot> Right.R \<mu>"
-          using 1 3 4 Right.comp_char Right.cod_char Right.in_hom_char by auto
-        also have "... = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> ?a)"
-          using 1 by (simp add: H\<^sub>R_def)
-        finally show ?thesis by simp
-      qed
+        by (metis "1" "2" H\<^sub>R_def Right.comp_simp Right.in_homE Right.runit_naturality
+            Right.seqI' runit_def src_cod src_dom)
     qed
 
     interpretation L: endofunctor V L
       using endofunctor_L by auto
     interpretation \<ll>: transformation_by_components V V L map lunit
       using lunit_in_hom lunit_naturality by unfold_locales auto
     interpretation \<ll>: natural_isomorphism V V L map \<ll>.map
       using iso_lunit by unfold_locales auto
 
     lemma natural_isomorphism_\<ll>:
     shows "natural_isomorphism V V L map \<ll>.map"
       ..
 
     interpretation L: equivalence_functor V V L
       using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
 
     lemma equivalence_functor_L:
     shows "equivalence_functor V V L"
       ..
 
     lemma lunit_commutes_with_L:
     assumes "ide f"
     shows "\<l>[L f] = L \<l>[f]"
     proof -
       have "seq \<l>[f] (L \<l>[f])"
         using assms lunit_char(2) L.preserves_hom by fastforce
       moreover have "seq \<l>[f] \<l>[L f]"
         using assms lunit_char(2) lunit_char(2) [of "L f"] L.preserves_ide by auto
       ultimately show ?thesis
         using assms lunit_char(2) [of f] lunit_naturality [of "\<l>[f]"] iso_lunit
               iso_is_section section_is_mono monoE [of "\<l>[f]" "L \<l>[f]" "\<l>[L f]"]
         by auto
     qed
 
     interpretation R: endofunctor V R
       using endofunctor_R by auto
     interpretation \<rr>: transformation_by_components V V R map runit
       using runit_in_hom runit_naturality by unfold_locales auto
     interpretation \<rr>: natural_isomorphism V V R map \<rr>.map
       using iso_runit by unfold_locales auto
 
     lemma natural_isomorphism_\<rr>:
     shows "natural_isomorphism V V R map \<rr>.map"
       ..
 
     interpretation R: equivalence_functor V V R
       using R.isomorphic_to_identity_is_equivalence \<rr>.natural_isomorphism_axioms by simp
 
     lemma equivalence_functor_R:
     shows "equivalence_functor V V R"
       ..
 
     lemma runit_commutes_with_R:
     assumes "ide f"
     shows "\<r>[R f] = R \<r>[f]"
     proof -
       have "seq \<r>[f] (R \<r>[f])"
         using assms runit_char(2) R.preserves_hom by fastforce
       moreover have "seq \<r>[f] \<r>[R f]"
         using assms runit_char(2) runit_char(2) [of "R f"] R.preserves_ide by auto
       ultimately show ?thesis
         using assms runit_char(2) [of f] runit_naturality [of "\<r>[f]"] iso_runit
               iso_is_section section_is_mono monoE [of "\<r>[f]" "R \<r>[f]" "\<r>[R f]"]
         by auto
     qed
 
     definition \<alpha>
     where "\<alpha> \<mu> \<nu> \<tau> \<equiv> if VVV.arr (\<mu>, \<nu>, \<tau>) then
                         (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]
                       else null"
 
     lemma \<alpha>_ide_simp [simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "\<alpha> f g h = \<a>[f, g, h]"
     proof -
       have "\<alpha> f g h = (f \<star> g \<star> h) \<cdot> \<a>[dom f, dom g, dom h]"
         using assms \<alpha>_def VVV.arr_char [of "(f, g, h)"] by auto
       also have "... = (f \<star> g \<star> h) \<cdot> \<a>[f, g, h]"
         using assms by simp
       also have "... = \<a>[f, g, h]"
         using assms \<alpha>_def assoc_in_hom\<^sub>A\<^sub>W\<^sub>C hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H VVV.arr_char VoV.arr_char
               comp_cod_arr composable_char\<^sub>P\<^sub>B\<^sub>H
         by auto
       finally show ?thesis by simp
     qed
 
     (* TODO: Figure out how this got reinstated. *)
     no_notation in_hom      ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     lemma natural_isomorphism_\<alpha>:
     shows "natural_isomorphism VVV.comp V HoHV HoVH
              (\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)))"
     proof -
       interpret \<alpha>: transformation_by_components VVV.comp V HoHV HoVH
                      \<open>\<lambda>f. \<a>[fst f, fst (snd f), snd (snd f)]\<close>
       proof
         show 1: "\<And>x. VVV.ide x \<Longrightarrow> \<guillemotleft>\<a>[fst x, fst (snd x), snd (snd x)] : HoHV x \<Rightarrow> HoVH x\<guillemotright>"
         proof -
           fix x
           assume x: "VVV.ide x"
           show "\<guillemotleft>\<a>[fst x, fst (snd x), snd (snd x)] : HoHV x \<Rightarrow> HoVH x\<guillemotright>"
           proof -
             have "ide (fst x) \<and> ide (fst (snd x)) \<and> ide (snd (snd x)) \<and>
                   fst x \<star> fst (snd x) \<noteq> null \<and> fst (snd x) \<star> snd (snd x) \<noteq> null"
               using x VVV.ide_char VVV.arr_char VV.arr_char composable_char\<^sub>P\<^sub>B\<^sub>H by simp
             hence "\<a>[fst x, fst (snd x), snd (snd x)]
                      \<in> hom ((fst x \<star> fst (snd x)) \<star> snd (snd x))
                              (fst x \<star> fst (snd x) \<star> snd (snd x))"
               using x assoc_in_hom\<^sub>A\<^sub>W\<^sub>C by simp
             thus ?thesis
               unfolding HoHV_def HoVH_def
               using x VVV.ideD(1) by simp
           qed
         qed
         show "\<And>f. VVV.arr f \<Longrightarrow>
                    \<a>[fst (VVV.cod f), fst (snd (VVV.cod f)), snd (snd (VVV.cod f))] \<cdot> HoHV f =
                    HoVH f \<cdot> \<a>[fst (VVV.dom f), fst (snd (VVV.dom f)), snd (snd (VVV.dom f))]"
           unfolding HoHV_def HoVH_def
           using assoc_naturality\<^sub>A\<^sub>W\<^sub>C VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char
                 composable_char\<^sub>P\<^sub>B\<^sub>H
           by simp
       qed
       interpret \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH \<alpha>.map
       proof
         fix f
         assume f: "VVV.ide f"
         show "iso (\<alpha>.map f)"
         proof -
           have "fst f \<star> fst (snd f) \<noteq> null \<and> fst (snd f) \<star> snd (snd f) \<noteq> null"
             using f VVV.ideD(1) VVV.arr_char [of f] VV.arr_char composable_char\<^sub>P\<^sub>B\<^sub>H by auto
           thus ?thesis
             using f \<alpha>.map_simp_ide iso_assoc\<^sub>A\<^sub>W\<^sub>C VVV.ide_char VVV.arr_char by simp
         qed
       qed
       have "(\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))) = \<alpha>.map"
       proof
         fix \<mu>\<nu>\<tau>
         have "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>"
           using \<alpha>_def \<alpha>.map_def by simp
         moreover have "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow>
                          \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>"
         proof -
           assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
           have "\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) =
                 (fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>) \<star> snd (snd \<mu>\<nu>\<tau>)) \<cdot>
                   \<a>[dom (fst \<mu>\<nu>\<tau>), dom (fst (snd \<mu>\<nu>\<tau>)), dom (snd (snd \<mu>\<nu>\<tau>))]"
             using \<mu>\<nu>\<tau> \<alpha>_def by simp
           also have "... = \<a>[cod (fst \<mu>\<nu>\<tau>), cod (fst (snd \<mu>\<nu>\<tau>)), cod (snd (snd \<mu>\<nu>\<tau>))] \<cdot>
                              ((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
             using \<mu>\<nu>\<tau> HoHV_def HoVH_def VVV.arr_char VV.arr_char assoc_naturality\<^sub>A\<^sub>W\<^sub>C
                   composable_char\<^sub>P\<^sub>B\<^sub>H
             by simp
           also have "... =
                      \<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
                        ((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
             using \<mu>\<nu>\<tau> VVV.arr_char VVV.cod_char VV.arr_char by simp
           also have "... = \<alpha>.map \<mu>\<nu>\<tau>"
             using \<mu>\<nu>\<tau> \<alpha>.map_def HoHV_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
           finally show ?thesis by blast
         qed
         ultimately show "\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>" by blast
       qed
       thus ?thesis using \<alpha>.natural_isomorphism_axioms by simp
     qed
 
     proposition induces_bicategory:
     shows "bicategory V H \<alpha> \<i> src trg"
     proof -
       interpret VxVxV: product_category V VxV.comp ..
       interpret VoVoV: subcategory VxVxV.comp
                        \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
                               src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
         using subcategory_VVV by blast
       interpret HoHV: "functor" VVV.comp V HoHV
         using functor_HoHV by blast
       interpret HoVH: "functor" VVV.comp V HoVH
         using functor_HoVH by blast
       interpret \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
                      \<open>\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close>
         using natural_isomorphism_\<alpha> by blast
       interpret L: equivalence_functor V V L
         using equivalence_functor_L by blast
       interpret R: equivalence_functor V V R
         using equivalence_functor_R by blast
       show "bicategory V H \<alpha> \<i> src trg"
       proof
         show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
           using obj_is_weak_unit unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by blast
         show "\<And>a. obj a \<Longrightarrow> iso \<i>[a]"
           using obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by blast
         show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k;
                           src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
                           (f \<star> \<alpha> g h k) \<cdot> \<alpha> f (g \<star> h) k \<cdot> (\<alpha> f g h \<star> k) =
                           \<alpha> f g (h \<star> k) \<cdot> \<alpha> (f \<star> g) h k"
         proof -
           fix f g h k
           assume f: "ide f" and g: "ide g" and h: "ide h" and k: "ide k"
           and fg: "src f = trg g" and gh: "src g = trg h" and hk: "src h = trg k"
           have "sources f \<inter> targets g \<noteq> {}"
             using f g fg src_in_sources [of f] trg_in_targets ideD(1) by auto
           moreover have "sources g \<inter> targets h \<noteq> {}"
             using g h gh src_in_sources [of g] trg_in_targets ideD(1) by auto
           moreover have "sources h \<inter> targets k \<noteq> {}"
             using h k hk src_in_sources [of h] trg_in_targets ideD(1) by auto
           moreover have "\<alpha> f g h = \<a>[f, g, h] \<and> \<alpha> g h k = \<a>[g, h, k]"
             using f g h k fg gh hk \<alpha>_ide_simp by simp
           moreover have "\<alpha> f (g \<star> h) k = \<a>[f, g \<star> h, k] \<and> \<alpha> f g (h \<star> k) = \<a>[f, g, h \<star> k] \<and>
                          \<alpha> (f \<star> g) h k = \<a>[f \<star> g, h, k]"
             using f g h k fg gh hk \<alpha>_ide_simp preserves_ide hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H(1) by simp
           ultimately show "(f \<star> \<alpha> g h k) \<cdot> \<alpha> f (g \<star> h) k \<cdot> (\<alpha> f g h \<star> k) =
                            \<alpha> f g (h \<star> k) \<cdot> \<alpha> (f \<star> g) h k"
             using f g h k fg gh hk pentagon\<^sub>A\<^sub>W\<^sub>C [of f g h k] \<alpha>_ide_simp by presburger
         qed
       qed
     qed
 
   end
 
   text \<open>
     The following is the main result of this development:
     Every prebicategory extends to a bicategory, by making an arbitrary choice of
     representatives of each isomorphism class of weak units and using that to
     define the source and target mappings, and then choosing an arbitrary isomorphism
     in \<open>hom (a \<star> a) a\<close> for each weak unit \<open>a\<close>.
   \<close>
 
   context prebicategory
   begin
 
     interpretation prebicategory_with_homs V H \<a> some_src some_trg
       using extends_to_prebicategory_with_homs by auto
 
     interpretation prebicategory_with_units V H \<a> some_unit
       using extends_to_prebicategory_with_units by auto
 
     interpretation prebicategory_with_homs_and_units V H \<a> some_unit some_src some_trg ..
 
     theorem extends_to_bicategory:
     shows "bicategory V H \<alpha> some_unit some_src some_trg"
       using induces_bicategory by simp
 
   end
 
   section "Bicategories as Prebicategories"
 
   subsection "Bicategories are Prebicategories"
 
   text \<open>
     In this section we show that a bicategory determines a prebicategory with homs,
     whose weak units are exactly those arrows that are isomorphic to their chosen source,
     or equivalently, to their chosen target.
     Moreover, the notion of horizontal composability, which in a bicategory is determined
     by the coincidence of chosen sources and targets, agrees with the version defined
     for the induced weak composition in terms of nonempty intersections of source and
     target sets, which is not dependent on any arbitrary choices.
   \<close>
 
   context bicategory
   begin
 
     (* TODO: Why does this get re-introduced? *)
     no_notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     interpretation \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
                          \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> ..
 
     abbreviation \<alpha>'
     where "\<alpha>' \<equiv> \<alpha>'.map"
 
     definition \<a>'  ("\<a>\<^sup>-\<^sup>1[_, _, _]")
     where "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] \<equiv> \<alpha>'.map (\<mu>, \<nu>, \<tau>)"
 
     lemma assoc'_in_hom':
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "in_hhom \<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
     and "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : dom \<mu> \<star> dom \<nu> \<star> dom \<tau> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>\<guillemotright>"
     proof -
       show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : dom \<mu> \<star> dom \<nu> \<star> dom \<tau> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>\<guillemotright>"
       proof -
         have 1: "VVV.in_hom (\<mu>, \<nu>, \<tau>) (dom \<mu>, dom \<nu>, dom \<tau>) (cod \<mu>, cod \<nu>, cod \<tau>)"
           using assms VVV.in_hom_char VVV.arr_char VV.arr_char by auto
         have "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : HoVH (dom \<mu>, dom \<nu>, dom \<tau>) \<Rightarrow> HoHV (cod \<mu>, cod \<nu>, cod \<tau>)\<guillemotright>"
           using 1 \<a>'_def \<alpha>'.preserves_hom by auto
         moreover have "HoVH (dom \<mu>, dom \<nu>, dom \<tau>) = dom \<mu> \<star> dom \<nu> \<star> dom \<tau>"
           using 1 HoVH_def by (simp add: VVV.in_hom_char)
         moreover have "HoHV (cod \<mu>, cod \<nu>, cod \<tau>) = (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>"
           using 1 HoHV_def by (simp add: VVV.in_hom_char)
         ultimately show ?thesis by simp
       qed
       thus "in_hhom \<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
         using assms vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
     qed
 
     lemma assoc'_is_natural_1:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] = ((\<mu> \<star> \<nu>) \<star> \<tau>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<mu>, dom \<nu>, dom \<tau>]"
       using assms \<alpha>'.is_natural_1 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char
             VVV.dom_char HoHV_def src_dom trg_dom \<a>'_def
       by simp
 
     lemma assoc'_is_natural_2:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] = \<a>\<^sup>-\<^sup>1[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> (\<mu> \<star> \<nu> \<star> \<tau>)"
       using assms \<alpha>'.is_natural_2 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char
             VVV.cod_char HoVH_def src_dom trg_dom \<a>'_def
       by simp
 
     lemma assoc'_naturality:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "\<a>\<^sup>-\<^sup>1[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> (\<mu> \<star> \<nu> \<star> \<tau>) = ((\<mu> \<star> \<nu>) \<star> \<tau>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<mu>, dom \<nu>, dom \<tau>]"
       using assms assoc'_is_natural_1 assoc'_is_natural_2 by metis
 
     lemma assoc'_in_hom [intro]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "in_hhom \<a>\<^sup>-\<^sup>1[f, g, h] (src h) (trg f)"
     and "\<guillemotleft>\<a>\<^sup>-\<^sup>1[f, g, h] : dom f \<star> dom g \<star> dom h \<Rightarrow> (cod f \<star> cod g) \<star> cod h\<guillemotright>"
       using assms assoc'_in_hom'(1-2) ideD(1) by meson+
 
     lemma assoc'_simps [simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "arr \<a>\<^sup>-\<^sup>1[f, g, h]"
     and "src \<a>\<^sup>-\<^sup>1[f, g, h] = src h" and "trg \<a>\<^sup>-\<^sup>1[f, g, h] = trg f"
     and "dom \<a>\<^sup>-\<^sup>1[f, g, h] = dom f \<star> dom g \<star> dom h"
     and "cod \<a>\<^sup>-\<^sup>1[f, g, h] = (cod f \<star> cod g) \<star> cod h"
       using assms assoc'_in_hom by blast+
 
     lemma assoc'_eq_inv_assoc [simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "\<a>\<^sup>-\<^sup>1[f, g, h] = inv \<a>[f, g, h]"
       using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char \<alpha>'.map_ide_simp
             \<a>'_def
       by auto
 
     lemma inverse_assoc_assoc' [intro]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "inverse_arrows \<a>[f, g, h] \<a>\<^sup>-\<^sup>1[f, g, h]"
       using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char \<alpha>'.map_ide_simp
             \<alpha>'.inverts_components \<a>'_def
       by auto
 
     lemma iso_assoc' [intro, simp]:
     assumes "ide f" and "ide g" and "ide h"
     and "src f = trg g" and "src g = trg h"
     shows "iso \<a>\<^sup>-\<^sup>1[f, g, h]"
       using assms by simp
 
     lemma comp_assoc_assoc' [simp]:
     assumes "ide f" and "ide g" and "ide h"
     and "src f = trg g" and "src g = trg h"
     shows "\<a>[f, g, h] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h] = f \<star> g \<star> h"
     and "\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> \<a>[f, g, h] = (f \<star> g) \<star> h"
       using assms comp_arr_inv' comp_inv_arr' by auto
 
     lemma unit_in_hom [intro, simp]:
     assumes "obj a"
     shows "\<guillemotleft>\<i>[a] : a \<rightarrow> a\<guillemotright>" and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
     proof -
       show "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
         using assms unit_in_vhom by simp
       thus "\<guillemotleft>\<i>[a] : a \<rightarrow> a\<guillemotright>"
         using assms
         by (metis arrI in_hhom_def obj_simps(2-3) vconn_implies_hpar(1-4))
     qed
 
     interpretation weak_composition V H
       using is_weak_composition by auto
 
     lemma seq_if_composable:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "src \<nu> = trg \<mu>"
       using assms H.is_extensional [of "(\<nu>, \<mu>)"] VV.arr_char by auto
 
     lemma obj_self_composable:
     assumes "obj a"
     shows "a \<star> a \<noteq> null"
     and "isomorphic (a \<star> a) a"
-    proof -
-      show 1: "isomorphic (a \<star> a) a"
-        using assms unit_in_hom iso_unit isomorphic_def by blast
-      obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright>"
-        using 1 isomorphic_def by blast
-      have "ide (a \<star> a)" using 1 \<phi> ide_dom [of \<phi>] by fastforce
-      thus "a \<star> a \<noteq> null" using ideD(1) not_arr_null by metis
-    qed
+       apply (metis arr_dom_iff_arr assms in_homE not_arr_null unit_in_vhom)
+      by (meson assms iso_unit isomorphic_def unit_in_vhom)
 
     lemma obj_is_weak_unit:
     assumes "obj a"
     shows "weak_unit a"
     proof -
       interpret Left_a: subcategory V \<open>left a\<close>
         using assms left_hom_is_subcategory by force
       interpret Right_a: subcategory V \<open>right a\<close>
         using assms right_hom_is_subcategory by force
 
       text \<open>
         We know that \<open>H\<^sub>L a\<close> is fully faithful as a global endofunctor,
         but the definition of weak unit involves its restriction to a
         subcategory.  So we have to verify that the restriction
         is also a fully faithful functor.
       \<close>
 
       interpret La: endofunctor \<open>Left a\<close> \<open>H\<^sub>L a\<close>
         using assms obj_self_composable endofunctor_H\<^sub>L [of a] by force
       interpret La: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
       proof
         show "\<And>f f'. Left_a.par f f' \<Longrightarrow> H\<^sub>L a f = H\<^sub>L a f' \<Longrightarrow> f = f'"
         proof -
           fix \<mu> \<mu>'
           assume par: "Left_a.par \<mu> \<mu>'"
           assume eq: "H\<^sub>L a \<mu> = H\<^sub>L a \<mu>'"
           have 1: "par \<mu> \<mu>'"
             using par Left_a.arr_char Left_a.dom_char Left_a.cod_char left_def
                   composable_implies_arr null_agreement
             by metis
           moreover have "L \<mu> = L \<mu>'"
             using par eq H\<^sub>L_def Left_a.arr_char left_def preserves_arr
                   assms 1 seq_if_composable [of a \<mu>] not_arr_null seq_if_composable [of a \<mu>']
             by auto
           ultimately show "\<mu> = \<mu>'"
             using L.is_faithful by blast
         qed
         show "\<And>f g \<mu>. \<lbrakk> Left_a.ide f; Left_a.ide g; Left_a.in_hom \<mu> (H\<^sub>L a f) (H\<^sub>L a g) \<rbrakk> \<Longrightarrow>
                         \<exists>\<nu>. Left_a.in_hom \<nu> f g \<and> H\<^sub>L a \<nu> = \<mu>"
         proof -
           fix f g \<mu>
           assume f: "Left_a.ide f" and g: "Left_a.ide g"
           and \<mu>: "Left_a.in_hom \<mu> (H\<^sub>L a f) (H\<^sub>L a g)"
           have 1: "a = trg f \<and> a = trg g"
             using assms f g Left_a.ide_char Left_a.arr_char left_def seq_if_composable [of a f]
                   seq_if_composable [of a g]
             by auto
           show "\<exists>\<nu>. Left_a.in_hom \<nu> f g \<and> H\<^sub>L a \<nu> = \<mu>"
           proof -
             have 2: "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> L \<nu> = \<mu>"
               using f g \<mu> 1 Left_a.ide_char H\<^sub>L_def L.preserves_reflects_arr Left_a.arr_char
                     Left_a.in_hom_char L.is_full
               by force
             obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> L \<nu> = \<mu>"
               using 2 by blast
             have "Left_a.arr \<nu>"
               using \<nu> 1 trg_dom Left_a.arr_char left_def hseq_char' by fastforce
             moreover have "H\<^sub>L a \<nu> = \<mu>"
               using \<nu> 1 trg_dom H\<^sub>L_def by auto
             ultimately show ?thesis
               using \<nu> Left_a.dom_simp Left_a.cod_simp by blast
           qed
         qed
       qed
       interpret Ra: endofunctor \<open>Right a\<close> \<open>H\<^sub>R a\<close>
         using assms obj_self_composable endofunctor_H\<^sub>R [of a] by force
       interpret Ra: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
       proof
         show "\<And>f f'. Right_a.par f f' \<Longrightarrow> H\<^sub>R a f = H\<^sub>R a f' \<Longrightarrow> f = f'"
         proof -
           fix \<mu> \<mu>'
           assume par: "Right_a.par \<mu> \<mu>'"
           assume eq: "H\<^sub>R a \<mu> = H\<^sub>R a \<mu>'"
           have 1: "par \<mu> \<mu>'"
             using par Right_a.arr_char Right_a.dom_char Right_a.cod_char right_def
                   composable_implies_arr null_agreement
             by metis
           moreover have "R \<mu> = R \<mu>'"
             using par eq H\<^sub>R_def Right_a.arr_char right_def preserves_arr
                   assms 1 seq_if_composable [of \<mu> a] not_arr_null seq_if_composable [of \<mu>' a]
             by auto
           ultimately show "\<mu> = \<mu>'"
             using R.is_faithful by blast
         qed
         show "\<And>f g \<mu>. \<lbrakk> Right_a.ide f; Right_a.ide g; Right_a.in_hom \<mu> (H\<^sub>R a f) (H\<^sub>R a g) \<rbrakk> \<Longrightarrow>
                         \<exists>\<nu>. Right_a.in_hom \<nu> f g \<and> H\<^sub>R a \<nu> = \<mu>"
         proof -
           fix f g \<mu>
           assume f: "Right_a.ide f" and g: "Right_a.ide g"
           and \<mu>: "Right_a.in_hom \<mu> (H\<^sub>R a f) (H\<^sub>R a g)"
           have 1: "a = src f \<and> a = src g"
             using assms f g Right_a.ide_char Right_a.arr_char right_def seq_if_composable
             by auto
           show "\<exists>\<nu>. Right_a.in_hom \<nu> f g \<and> H\<^sub>R a \<nu> = \<mu>"
           proof -
             have 2: "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> R \<nu> = \<mu>"
               using f g \<mu> 1 Right_a.ide_char H\<^sub>R_def R.preserves_reflects_arr Right_a.arr_char
                     Right_a.in_hom_char R.is_full
               by force
             obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> R \<nu> = \<mu>"
               using 2 by blast
             have "Right_a.arr \<nu>"
               using \<nu> 1 src_dom Right_a.arr_char right_def hseq_char' by fastforce
             moreover have "H\<^sub>R a \<nu> = \<mu>"
               using \<nu> 1 src_dom H\<^sub>R_def by auto
             ultimately show ?thesis
               using \<nu> Right_a.dom_simp Right_a.cod_simp by blast
           qed
         qed
       qed
       have "isomorphic (a \<star> a) a \<and> a \<star> a \<noteq> null"
         using assms obj_self_composable unit_in_hom iso_unit isomorphic_def by blast
       thus ?thesis
         using La.fully_faithful_functor_axioms Ra.fully_faithful_functor_axioms weak_unit_def
         by blast
     qed
 
     lemma src_in_sources:
     assumes "arr \<mu>"
     shows "src \<mu> \<in> sources \<mu>"
       using assms obj_is_weak_unit R.preserves_arr hseq_char' by auto
 
     lemma trg_in_targets:
     assumes "arr \<mu>"
     shows "trg \<mu> \<in> targets \<mu>"
       using assms obj_is_weak_unit L.preserves_arr hseq_char' by auto
 
     lemma weak_unit_cancel_left:
     assumes "weak_unit a" and "ide f" and "ide g"
     and "a \<star> f \<cong> a \<star> g"
     shows "f \<cong> g"
     proof -
       have 0: "ide a"
         using assms weak_unit_def by force
       interpret Left_a: subcategory V \<open>left a\<close>
         using 0 left_hom_is_subcategory by simp
       interpret Left_a: left_hom V H a
         using assms weak_unit_self_composable by unfold_locales auto
       interpret La: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
         using assms weak_unit_def by fast
       obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> f \<Rightarrow> a \<star> g\<guillemotright>"
         using assms by blast
       have 1: "Left_a.iso \<phi> \<and> Left_a.in_hom \<phi> (a \<star> f) (a \<star> g)"
-      proof
-        have "a \<star> \<phi> \<noteq> null"
-        proof -
-          have "a \<star> dom \<phi> \<noteq> null"
-            using assms \<phi> weak_unit_self_composable
-            by (metis arr_dom_iff_arr hseq_char' in_homE match_4)
-          thus ?thesis
-            using hom_connected by simp
-        qed
-        thus "Left_a.in_hom \<phi> (a \<star> f) (a \<star> g)"
-          using \<phi> Left_a.hom_char left_def by auto
-        thus "Left_a.iso \<phi>"
-          using \<phi> Left_a.iso_char by auto
-      qed
+        by (metis H\<^sub>L_def La.is_extensional La.preserves_arr Left_a.arrI Left_a.dom_closed
+            Left_a.in_hom_char Left_a.iso_char Left_a.not_arr_null Left_a.null_char \<phi> assms(4)
+            hom_connected(4) hseq_char' ide_char' in_homE isomorphic_implies_ide(2) left_def)
       hence 2: "Left_a.ide (a \<star> f) \<and> Left_a.ide (a \<star> g)"
         using Left_a.ide_dom [of \<phi>] Left_a.ide_cod [of \<phi>] Left_a.dom_simp Left_a.cod_simp
         by auto
       hence 3: "Left_a.ide f \<and> Left_a.ide g"
         by (metis Left_a.ideI Left_a.ide_def Left_a.null_char assms(2) assms(3) left_def)
       obtain \<psi> where \<psi>: "\<psi> \<in> Left_a.hom f g \<and> a \<star> \<psi> = \<phi>"
         using assms 1 2 3 La.is_full [of g f \<phi>] H\<^sub>L_def by auto
       have "Left_a.iso \<psi>"
         using \<psi> 1 H\<^sub>L_def La.reflects_iso by auto
       hence "iso \<psi> \<and> \<guillemotleft>\<psi> : f \<Rightarrow> g\<guillemotright>"
         using \<psi> Left_a.iso_char Left_a.in_hom_char by auto
       thus ?thesis by auto
     qed
 
     lemma weak_unit_cancel_right:
     assumes "weak_unit a" and "ide f" and "ide g"
     and "f \<star> a \<cong> g \<star> a"
     shows "f \<cong> g"
     proof -
       have 0: "ide a"
         using assms weak_unit_def by force
       interpret Right_a: subcategory V \<open>right a\<close>
         using 0 right_hom_is_subcategory by simp
       interpret Right_a: right_hom V H a
         using assms weak_unit_self_composable by unfold_locales auto
       interpret R: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
         using assms weak_unit_def by fast
       obtain \<phi> where \<phi>: "iso \<phi> \<and> in_hom \<phi> (f \<star> a) (g \<star> a)"
         using assms by blast
       have 1: "Right_a.iso \<phi> \<and> \<phi> \<in> Right_a.hom (f \<star> a) (g \<star> a)"
       proof
         have "\<phi> \<star> a \<noteq> null"
-        proof -
-          have "dom \<phi> \<star> a \<noteq> null"
-            using assms \<phi> weak_unit_self_composable
-            by (metis arr_dom_iff_arr hseq_char' in_homE match_3)
-          thus ?thesis
-            using hom_connected by simp
-        qed
+          by (metis \<phi> assms(1,4) hom_connected(3) ideD(1) in_homE isomorphic_implies_ide(2)
+              match_3 not_arr_null weak_unit_self_composable(3))
         thus "\<phi> \<in> Right_a.hom (f \<star> a) (g \<star> a)"
           using \<phi> Right_a.hom_char right_def by simp
         thus "Right_a.iso \<phi>"
           using \<phi> Right_a.iso_char by auto
       qed
       hence 2: "Right_a.ide (f \<star> a) \<and> Right_a.ide (g \<star> a)"
         using Right_a.ide_dom [of \<phi>] Right_a.ide_cod [of \<phi>] Right_a.dom_simp Right_a.cod_simp
         by auto
       hence 3: "Right_a.ide f \<and> Right_a.ide g"
         using assms Right_a.ide_char Right_a.arr_char right_def Right_a.ide_def Right_a.null_char
         by metis
       obtain \<psi> where \<psi>: "\<psi> \<in> Right_a.hom f g \<and> \<psi> \<star> a = \<phi>"
         using assms 1 2 3 R.is_full [of g f \<phi>] H\<^sub>R_def by auto
       have "Right_a.iso \<psi>"
         using \<psi> 1 H\<^sub>R_def R.reflects_iso by auto
       hence "iso \<psi> \<and> \<guillemotleft>\<psi> : f \<Rightarrow> g\<guillemotright>"
         using \<psi> Right_a.iso_char Right_a.in_hom_char by auto
       thus ?thesis by auto
     qed
 
     text \<open>
       All sources of an arrow ({\em i.e.}~weak units composable on the right with that arrow)
       are isomorphic to the chosen source, and similarly for targets.  That these statements
       hold was somewhat surprising to me.
     \<close>
 
     lemma source_iso_src:
     assumes "arr \<mu>" and "a \<in> sources \<mu>"
     shows "a \<cong> src \<mu>"
     proof -
       have 0: "ide a"
         using assms weak_unit_def by force
       have 1: "src a = trg a"
         using assms ide_dom sources_def weak_unit_iff_self_target seq_if_composable
               weak_unit_self_composable
         by simp
       obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright>"
         using assms weak_unit_def by blast
       have "a \<star> src a \<cong> src a \<star> src a"
       proof -
         have "src a \<cong> src a \<star> src a"
           using 0 obj_is_weak_unit weak_unit_def isomorphic_symmetric by auto
         moreover have "a \<star> src a \<cong> src a"
         proof -
           have "a \<star> a \<star> src a \<cong> a \<star> src a"
           proof -
             have "iso (\<phi> \<star> src a) \<and> \<guillemotleft>\<phi> \<star> src a : (a \<star> a) \<star> src a \<Rightarrow> a \<star> src a\<guillemotright>"
               using 0 1 \<phi> ide_in_hom(2) by auto
             moreover have "iso \<a>\<^sup>-\<^sup>1[a, a, src a] \<and>
                            \<guillemotleft>\<a>\<^sup>-\<^sup>1[a, a, src a] :  a \<star> a \<star> src a \<Rightarrow> (a \<star> a) \<star> src a\<guillemotright>"
               using 0 1 iso_assoc' by force
             ultimately show ?thesis
               using isos_compose isomorphic_def by auto
           qed
           thus ?thesis
             using assms 0 weak_unit_cancel_left by auto
         qed
         ultimately show ?thesis
           using isomorphic_transitive by meson
       qed
       hence "a \<cong> src a"
         using 0 weak_unit_cancel_right [of "src a" a "src a"] obj_is_weak_unit by auto
       thus ?thesis using assms seq_if_composable 1 by auto
     qed
 
     lemma target_iso_trg:
     assumes "arr \<mu>" and "b \<in> targets \<mu>"
     shows "b \<cong> trg \<mu>"
     proof -
       have 0: "ide b"
         using assms weak_unit_def by force
       have 1: "trg \<mu> = src b"
         using assms seq_if_composable by auto
       obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : b \<star> b \<Rightarrow> b\<guillemotright>"
         using assms weak_unit_def by blast
       have "trg b \<star> b \<cong> trg b \<star> trg b"
       proof -
         have "trg b \<cong> trg b \<star> trg b"
           using 0 obj_is_weak_unit weak_unit_def isomorphic_symmetric by auto
         moreover have "trg b \<star> b \<cong> trg b"
         proof -
           have "(trg b \<star> b) \<star> b \<cong> trg b \<star> b"
           proof -
             have "iso (trg b \<star> \<phi>) \<and> \<guillemotleft>trg b \<star> \<phi> : trg b \<star> b \<star> b \<Rightarrow> trg b \<star> b\<guillemotright>"
               using assms 0 1 \<phi> ide_in_hom(2) targetsD(1) weak_unit_self_composable
               apply (intro conjI hcomp_in_vhom) by auto
             moreover have "iso \<a>[trg b, b, b] \<and>
                            \<guillemotleft>\<a>[trg b, b, b] : (trg b \<star> b) \<star> b \<Rightarrow> trg b \<star> b \<star> b\<guillemotright>"
               using assms(2) 0 1 seq_if_composable targetsD(1-2) weak_unit_self_composable
               by auto
             ultimately show ?thesis
               using isos_compose isomorphic_def by auto
           qed
           thus ?thesis
             using assms 0 weak_unit_cancel_right by auto
         qed
         ultimately show ?thesis
           using isomorphic_transitive by meson
       qed
       hence "b \<cong> trg b"
         using 0 weak_unit_cancel_left [of "trg b" b "trg b"] obj_is_weak_unit by simp
       thus ?thesis
         using assms 0 1 seq_if_composable weak_unit_iff_self_source targetsD(1-2) source_iso_src
         by simp
     qed
 
     lemma is_weak_composition_with_homs:
     shows "weak_composition_with_homs V H src trg"
       using src_in_sources trg_in_targets seq_if_composable composable_implies_arr
       by (unfold_locales, simp_all)
 
     interpretation weak_composition_with_homs V H src trg
       using is_weak_composition_with_homs by auto
 
     text \<open>
       In a bicategory, the notion of composability defined in terms of
       the chosen sources and targets coincides with the version defined
       for a weak composition, which does not involve particular choices.
     \<close>
 
     lemma connected_iff_seq:
     assumes "arr \<mu>" and "arr \<nu>"
     shows "sources \<nu> \<inter> targets \<mu> \<noteq> {} \<longleftrightarrow> src \<nu> = trg \<mu>"
     proof
       show "src \<nu> = trg \<mu> \<Longrightarrow> sources \<nu> \<inter> targets \<mu> \<noteq> {}"
         using assms src_in_sources [of \<nu>] trg_in_targets [of \<mu>] by auto
       show "sources \<nu> \<inter> targets \<mu> \<noteq> {} \<Longrightarrow> src \<nu> = trg \<mu>"
       proof -
         assume 1: "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
         obtain a where a: "a \<in> sources \<nu> \<inter> targets \<mu>"
           using assms 1 by blast
         have \<mu>: "arr \<mu>"
           using a composable_implies_arr by auto
         have \<nu>: "arr \<nu>"
           using a composable_implies_arr by auto
-        have 1: "\<And>a'. a' \<in> sources \<nu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
-        proof
-          fix a'
-          assume a': "a' \<in> sources \<nu>"
-          have 1: "a' \<cong> a"
-            using a a' \<nu> src_dom sources_dom source_iso_src isomorphic_transitive
-                  isomorphic_symmetric
-            by (meson IntD1)
-          obtain \<phi> where \<phi>: "iso \<phi> \<and> \<phi> \<in> hom a' a"
-            using 1 by auto
-          show "src a' = src a"
-            using \<phi> src_dom src_cod by auto
-          show "trg a' = trg a"
-            using \<phi> trg_dom trg_cod by auto
-        qed
-        have 2: "\<And>a'. a' \<in> targets \<mu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
-        proof
-          fix a'
-          assume a': "a' \<in> targets \<mu>"
-          have 1: "a' \<cong> a"
-            using a a' \<mu> trg_dom targets_dom target_iso_trg isomorphic_transitive
-                  isomorphic_symmetric
-            by (meson IntD2)
-          obtain \<phi> where \<phi>: "iso \<phi> \<and> \<phi> \<in> hom a' a"
-            using 1 by auto
-          show "src a' = src a"
-            using \<phi> src_dom src_cod by auto
-          show "trg a' = trg a"
-            using \<phi> trg_dom trg_cod by auto
-        qed
+        have 2: "\<And>a'. a' \<in> sources \<nu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
+          by (metis IntE a seq_if_composable sourcesD(2-3) weak_unit_self_composable(3))
         have "src \<nu> = src (src \<nu>)" using \<nu> by simp
         also have "... = src (trg \<mu>)"
-          using \<nu> 1 [of "src \<nu>"] src_in_sources a weak_unit_self_composable seq_if_composable
+          using \<nu> 2 [of "src \<nu>"] src_in_sources a weak_unit_self_composable seq_if_composable
           by auto
         also have "... = trg (trg \<mu>)" using \<mu> by simp
         also have "... = trg \<mu>" using \<mu> by simp
         finally show "src \<nu> = trg \<mu>" by blast
       qed
     qed
 
     lemma is_associative_weak_composition:
     shows "associative_weak_composition V H \<a>"
     proof -
       have 1: "\<And>\<nu> \<mu>. \<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
         using H.is_extensional VV.arr_char by force
       show "associative_weak_composition V H \<a>"
       proof
         show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
                       \<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
           using 1 by auto
         show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
                       iso \<a>[f, g, h]"
           using 1 iso_assoc by presburger
         show "\<And>\<tau> \<mu> \<nu>. \<tau> \<star> \<mu> \<noteq> null \<Longrightarrow> \<mu> \<star> \<nu> \<noteq> null \<Longrightarrow>
                       \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
            using 1 assoc_naturality hseq_char hseq_char' by metis
         show "\<And>f g h k. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> ide k \<Longrightarrow>
                          sources f \<inter> targets g \<noteq> {} \<Longrightarrow>
                          sources g \<inter> targets h \<noteq> {} \<Longrightarrow>
                          sources h \<inter> targets k \<noteq> {} \<Longrightarrow>
                         (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) =
                         \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
            using 1 connected_iff_seq pentagon ideD(1) by auto
       qed
     qed
 
     interpretation associative_weak_composition V H \<a>
       using is_associative_weak_composition by auto
 
     theorem is_prebicategory:
     shows "prebicategory V H \<a>"
       using src_in_sources trg_in_targets by (unfold_locales, auto)
 
     interpretation prebicategory V H \<a>
       using is_prebicategory by auto
 
     corollary is_prebicategory_with_homs:
     shows "prebicategory_with_homs V H \<a> src trg"
       ..
 
     interpretation prebicategory_with_homs V H \<a> src trg
       using is_prebicategory_with_homs by auto
 
     text \<open>
       In a bicategory, an arrow is a weak unit if and only if it is
       isomorphic to its chosen source (or to its chosen target).
     \<close>
 
     lemma weak_unit_char:
     shows "weak_unit a \<longleftrightarrow> a \<cong> src a"
     and "weak_unit a \<longleftrightarrow> a \<cong> trg a"
     proof -
       show "weak_unit a \<longleftrightarrow> a \<cong> src a"
         using isomorphism_respects_weak_units isomorphic_symmetric
         by (meson ideD(1) isomorphic_implies_ide(2) obj_is_weak_unit obj_src source_iso_src
             weak_unit_iff_self_source weak_unit_self_composable(1))
       show "weak_unit a \<longleftrightarrow> a \<cong> trg a"
         using isomorphism_respects_weak_units isomorphic_symmetric
         by (metis \<open>weak_unit a = isomorphic a (src a)\<close> ideD(1) isomorphic_implies_hpar(3)
             isomorphic_implies_ide(1) src_trg target_iso_trg weak_unit_iff_self_target)
     qed
         
     interpretation H: partial_magma H
       using is_partial_magma by auto
 
     text \<open>
       Every arrow with respect to horizontal composition is also an arrow with respect
       to vertical composition.  The converse is not necessarily true.
     \<close>
 
     lemma harr_is_varr:
     assumes "H.arr \<mu>"
     shows "arr \<mu>"
-    proof -
-      have "H.domains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
-      proof -
-        assume 1: "H.domains \<mu> \<noteq> {}"
-        obtain a where a: "H.ide a \<and> \<mu> \<star> a \<noteq> null"
-          using 1 H.domains_def by auto
-        show "arr \<mu>"
-          using a hseq_char' H.ide_def by blast
-      qed
-      moreover have "H.codomains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
-      proof -
-        assume 1: "H.codomains \<mu> \<noteq> {}"
-        obtain a where a: "H.ide a \<and> a \<star> \<mu> \<noteq> null"
-          using 1 H.codomains_def by auto
-        show "arr \<mu>"
-          using a hseq_char' ide_def by blast
-      qed
-      ultimately show ?thesis using assms H.arr_def by auto
-    qed
+      using H.arr_def H.codomains_def H.domains_def assms composable_implies_arr(1)
+            composable_implies_arr(2)
+      by auto
 
     text \<open>
       An identity for horizontal composition is also an identity for vertical composition.
     \<close>
 
     lemma horizontal_identity_is_ide:
     assumes "H.ide \<mu>"
     shows "ide \<mu>"
     proof -
       have \<mu>: "arr \<mu>"
         using assms H.ide_def composable_implies_arr(2) by auto
       hence 1: "\<mu> \<star> dom \<mu> \<noteq> null"
         using assms hom_connected H.ide_def by auto
       have "\<mu> \<star> dom \<mu> = dom \<mu>"
         using assms 1 H.ide_def by simp
       moreover have "\<mu> \<star> dom \<mu> = \<mu>"
         using assms 1 H.ide_def [of \<mu>] null_agreement
         by (metis \<mu> cod_cod cod_dom hcomp_simps\<^sub>W\<^sub>C(3) ideD(2) ide_char' paste_1)
       ultimately have "dom \<mu> = \<mu>"
         by simp
       thus ?thesis
         using \<mu> by (metis ide_dom)
     qed
 
     text \<open>
       Every identity for horizontal composition is a weak unit.
     \<close>
 
     lemma horizontal_identity_is_weak_unit:
     assumes "H.ide \<mu>"
     shows "weak_unit \<mu>"
       using assms weak_unit_char
       by (metis H.ide_def comp_target_ide horizontal_identity_is_ide ideD(1)
           isomorphism_respects_weak_units null_agreement targetsD(2-3) trg_in_targets)
 
   end
 
   subsection "Vertically Discrete Bicategories are Categories"
 
   text \<open>
     In this section we show that if a bicategory is discrete with respect to vertical
     composition, then it is a category with respect to horizontal composition.
     To obtain this result, we need to establish that the set of arrows for the horizontal
     composition coincides with the set of arrows for the vertical composition.
     This is not true for a general bicategory, and even with the assumption that the
     vertical category is discrete it is not immediately obvious from the definitions.
     The issue is that the notion ``arrow'' for the horizontal composition is defined
     in terms of the existence of ``domains'' and ``codomains'' with respect to that
     composition, whereas the axioms for a bicategory only relate the notion ``arrow''
     for the vertical category to the existence of sources and targets with respect
     to the horizontal composition.
     So we have to establish that, under the assumption of vertical discreteness,
     sources coincide with domains and targets coincide with codomains.
     We also need the fact that horizontal identities are weak units, which previously
     required some effort to show.
   \<close>
 
   locale vertically_discrete_bicategory =
     bicategory +
   assumes vertically_discrete: "ide = arr"
   begin
 
     interpretation prebicategory_with_homs V H \<a> src trg
       using is_prebicategory_with_homs by auto
 
     interpretation H: partial_magma H
       using is_partial_magma(1) by auto
 
     lemma weak_unit_is_horizontal_identity:
     assumes "weak_unit a"
     shows "H.ide a"
     proof -
       have "a \<star> a \<noteq> H.null"
         using assms weak_unit_self_composable by simp
       moreover have "\<And>f. f \<star> a \<noteq> H.null \<Longrightarrow> f \<star> a = f"
       proof -
         fix f
         assume "f \<star> a \<noteq> H.null"
         hence "f \<star> a \<cong> f"
           using assms comp_ide_source composable_implies_arr(2) sourcesI vertically_discrete
           by auto
         thus "f \<star> a = f"
           using vertically_discrete isomorphic_def by auto
       qed
       moreover have "\<And>f. a \<star> f \<noteq> H.null \<Longrightarrow> a \<star> f = f"
       proof -
         fix f
         assume "a \<star> f \<noteq> H.null"
         hence "a \<star> f \<cong> f"
           using assms comp_target_ide composable_implies_arr(1) targetsI vertically_discrete
           by auto
         thus "a \<star> f = f"
           using vertically_discrete isomorphic_def by auto
       qed
       ultimately show "H.ide a"
         using H.ide_def by simp
     qed
 
     lemma sources_eq_domains:
     shows "sources \<mu> = H.domains \<mu>"
       using weak_unit_is_horizontal_identity H.domains_def sources_def
             horizontal_identity_is_weak_unit
       by auto
 
     lemma targets_eq_codomains:
     shows "targets \<mu> = H.codomains \<mu>"
       using weak_unit_is_horizontal_identity H.codomains_def targets_def
             horizontal_identity_is_weak_unit
       by auto
 
     lemma arr_agreement:
     shows "arr = H.arr"
       using arr_def H.arr_def arr_iff_has_src arr_iff_has_trg
             sources_eq_domains targets_eq_codomains
       by auto
 
     interpretation H: category H
     proof
       show "\<And>g f. g \<star> f \<noteq> H.null \<Longrightarrow> H.seq g f"
         using arr_agreement hcomp_simps\<^sub>W\<^sub>C(1) by auto
       show "\<And>f. (H.domains f \<noteq> {}) = (H.codomains f \<noteq> {})"
         using sources_eq_domains targets_eq_codomains arr_iff_has_src arr_iff_has_trg
         by simp
       fix f g h
       show "H.seq h g \<Longrightarrow> H.seq (h \<star> g) f \<Longrightarrow> H.seq g f"
         using null_agreement arr_agreement H.not_arr_null preserves_arr VoV.arr_char
         by (metis hseq_char' match_1)
       show "H.seq h (g \<star> f) \<Longrightarrow> H.seq g f \<Longrightarrow> H.seq h g"
         using null_agreement arr_agreement H.not_arr_null preserves_arr VoV.arr_char
         by (metis hseq_char' match_2)
       show "H.seq g f \<Longrightarrow> H.seq h g \<Longrightarrow> H.seq (h \<star> g) f"
         using arr_agreement match_3 hseq_char(1) by auto
       show "H.seq g f \<Longrightarrow> H.seq h g \<Longrightarrow> (h \<star> g) \<star> f = h \<star> g \<star> f"
       proof -
         assume hg: "H.seq h g"
         assume gf: "H.seq g f"
         have "iso \<a>[h, g, f] \<and> \<guillemotleft>\<a>[h, g, f] : (h \<star> g) \<star> f \<Rightarrow> h \<star> g \<star> f\<guillemotright>"
           using hg gf vertically_discrete arr_agreement hseq_char assoc_in_hom iso_assoc
           by auto
         thus ?thesis
           using arr_agreement vertically_discrete by auto
       qed
     qed
 
     proposition is_category:
     shows "category H"
       ..
 
   end
 
   subsection "Obtaining the Unitors"
 
   text \<open>
     We now want to exploit the construction of unitors in a prebicategory with units,
     to obtain left and right unitors in a bicategory.  However, a bicategory is not
     \emph{a priori} a prebicategory with units, because a bicategory only assigns unit
     isomorphisms to each \emph{object}, not to each weak unit.  In order to apply the results
     about prebicategories with units to a bicategory, we first need to extend the bicategory to
     a prebicategory with units, by extending the mapping \<open>\<iota>\<close>, which provides a unit isomorphism
     for each object, to a mapping that assigns a unit isomorphism to all weak units.
     This extension can be made in an arbitrary way, as the values chosen for
     non-objects ultimately do not affect the components of the unitors at objects.
   \<close>
 
   context bicategory
   begin
 
     interpretation prebicategory V H \<a>
       using is_prebicategory by auto
 
     definition \<i>'
     where "\<i>' a \<equiv> SOME \<phi>. iso \<phi> \<and> \<phi> \<in> hom (a \<star> a) a \<and> (obj a \<longrightarrow> \<phi> = \<i>[a])"
 
     lemma \<i>'_extends_\<i>:
     assumes "weak_unit a"
     shows "iso (\<i>' a)" and "\<guillemotleft>\<i>' a : a \<star> a \<Rightarrow> a\<guillemotright>" and "obj a \<Longrightarrow> \<i>' a = \<i>[a]"
     proof -
       let ?P = "\<lambda>a \<phi>. iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright> \<and> (obj a \<longrightarrow> \<phi> = \<i>[a])"
       have "\<exists>\<phi>. ?P a \<phi>"
         by (metis assms iso_some_unit(1) iso_some_unit(2) iso_unit unit_in_vhom)
       hence 1: "?P a (\<i>' a)"
         using \<i>'_def someI_ex [of "?P a"] by simp
       show "iso (\<i>' a)" using 1 by simp
       show "\<guillemotleft>\<i>' a : a \<star> a \<Rightarrow> a\<guillemotright>" using 1 by simp
       show "obj a \<Longrightarrow> \<i>' a = \<i>[a]" using 1 by simp
     qed
 
     proposition extends_to_prebicategory_with_units:
     shows "prebicategory_with_units V H \<a> \<i>'"
       using \<i>'_extends_\<i> by unfold_locales auto
 
     interpretation PB: prebicategory_with_units V H \<a> \<i>'
       using extends_to_prebicategory_with_units by auto
     interpretation PB: prebicategory_with_homs V H \<a> src trg
       using is_prebicategory_with_homs by auto
     interpretation PB: prebicategory_with_homs_and_units V H \<a> \<i>' src trg ..
 
     proposition extends_to_prebicategory_with_homs_and_units:
     shows "prebicategory_with_homs_and_units V H \<a> \<i>' src trg"
       ..
 
     definition lunit                 ("\<l>[_]")
     where "\<l>[a] \<equiv> PB.lunit a"
 
     definition runit                 ("\<r>[_]")
     where "\<r>[a] \<equiv> PB.runit a"
 
     abbreviation lunit'              ("\<l>\<^sup>-\<^sup>1[_]")
     where "\<l>\<^sup>-\<^sup>1[a] \<equiv> inv \<l>[a]"
 
     abbreviation runit'              ("\<r>\<^sup>-\<^sup>1[_]")
     where "\<r>\<^sup>-\<^sup>1[a] \<equiv> inv \<r>[a]"
 
     text \<open>
       \sloppypar
       The characterizations of the left and right unitors that we obtain from locale
       @{locale prebicategory_with_homs_and_units} mention the arbitarily chosen extension \<open>\<i>'\<close>,
       rather than the given \<open>\<i>\<close>.  We want ``native versions'' for the present context.
     \<close>
 
     lemma lunit_char:
     assumes "ide f"
     shows "\<guillemotleft>\<l>[f] : L f \<Rightarrow> f\<guillemotright>" and "L \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
     proof -
       have 1: "trg (PB.lunit f) = trg f"
         using assms PB.lunit_char [of f] vconn_implies_hpar(2) vconn_implies_hpar(4)
         by metis
       show "\<guillemotleft>\<l>[f] : L f \<Rightarrow> f\<guillemotright>"
         unfolding lunit_def
         using assms PB.lunit_char by simp
       show "L \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
         unfolding lunit_def
         using assms 1 PB.lunit_char obj_is_weak_unit \<i>'_extends_\<i> by simp
       let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
       have "?P = (\<lambda>\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and>
                       trg f \<star> \<mu> = (\<i>' (trg f) \<star> f) \<cdot> inv \<a>[trg f, trg f, f])"
       proof -
         have "\<And>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<longleftrightarrow> \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
           using assms by simp
         moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<Longrightarrow>
                             L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f] \<longleftrightarrow>
                             trg f \<star> \<mu> = (\<i>' (trg f) \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
           using calculation obj_is_weak_unit \<i>'_extends_\<i> by auto
         ultimately show ?thesis by blast
       qed
       thus "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
         using assms PB.lunit_char by simp
     qed
 
     lemma lunit_in_hom [intro]:
     assumes "ide f"
     shows "\<guillemotleft>\<l>[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
     proof -
       show "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
         using assms lunit_char by auto
       thus "\<guillemotleft>\<l>[f] : src f \<rightarrow> trg f\<guillemotright>"
         by (metis arrI in_hhomI vconn_implies_hpar(1-4))
     qed
 
     lemma lunit_in_vhom [simp]:
     assumes "ide f" and "trg f = b"
     shows "\<guillemotleft>\<l>[f] : b \<star> f \<Rightarrow> f\<guillemotright>"
       using assms by auto
 
     lemma lunit_simps [simp]:
     assumes "ide f"
     shows "arr \<l>[f]" and "src \<l>[f] = src f" and "trg \<l>[f] = trg f"
     and "dom \<l>[f] = trg f \<star> f" and "cod \<l>[f] = f"
       using assms lunit_in_hom
           apply auto
       using assms lunit_in_hom
        apply blast
       using assms lunit_in_hom
       by blast
 
     lemma runit_char:
     assumes "ide f"
     shows "\<guillemotleft>\<r>[f] : R f \<Rightarrow> f\<guillemotright>" and "R \<r>[f] = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
     proof -
       have 1: "src (PB.runit f) = src f"
         using assms PB.runit_char [of f] vconn_implies_hpar(1) vconn_implies_hpar(3)
         by metis
       show "\<guillemotleft>\<r>[f] : R f \<Rightarrow> f\<guillemotright>"
         unfolding runit_def
         using assms PB.runit_char by simp
       show "R \<r>[f] = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
         unfolding runit_def
         using assms 1 PB.runit_char obj_is_weak_unit \<i>'_extends_\<i> by simp
       let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
       have "?P = (\<lambda>\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and>
                       \<mu> \<star> src f = (f \<star> \<i>' (src f)) \<cdot>  \<a>[f, src f, src f])"
       proof -
         have "\<And>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<longleftrightarrow> \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
           using assms by simp
         moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<Longrightarrow>
                             R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f] \<longleftrightarrow>
                             \<mu> \<star> src f = (f \<star> \<i>' (src f)) \<cdot>  \<a>[f, src f, src f]"
           using calculation obj_is_weak_unit \<i>'_extends_\<i> by auto
         ultimately show ?thesis by blast
       qed
       thus "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
         using assms PB.runit_char by simp
     qed
 
     lemma runit_in_hom [intro]:
     assumes "ide f"
     shows "\<guillemotleft>\<r>[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
     proof -
       show "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
         using assms runit_char by auto
       thus "\<guillemotleft>\<r>[f] : src f \<rightarrow> trg f\<guillemotright>"
         by (metis arrI in_hhom_def vconn_implies_hpar(1-4))
     qed
 
     lemma runit_in_vhom [simp]:
     assumes "ide f" and "src f = a"
     shows "\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>"
       using assms by auto
 
     lemma runit_simps [simp]:
     assumes "ide f"
     shows "arr \<r>[f]" and "src \<r>[f] = src f" and "trg \<r>[f] = trg f"
     and "dom \<r>[f] = f \<star> src f" and "cod \<r>[f] = f"
       using assms runit_in_hom
           apply auto
       using assms runit_in_hom
        apply blast
       using assms runit_in_hom
       by blast
 
     lemma lunit_eqI:
     assumes "ide f" and "\<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
     and "trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
     shows "\<mu> = \<l>[f]"
       unfolding lunit_def
       using assms PB.lunit_eqI \<i>'_extends_\<i> trg.preserves_ide obj_is_weak_unit by simp
 
     lemma runit_eqI:
     assumes "ide f" and "\<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
     and "\<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
     shows "\<mu> = \<r>[f]"
       unfolding runit_def
       using assms PB.runit_eqI \<i>'_extends_\<i> src.preserves_ide obj_is_weak_unit by simp
 
     lemma lunit_naturality:
     assumes "arr \<mu>"
     shows "\<mu> \<cdot> \<l>[dom \<mu>] = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
       unfolding lunit_def
       using assms PB.lunit_naturality by auto
 
     lemma runit_naturality:
     assumes "arr \<mu>"
     shows "\<mu> \<cdot> \<r>[dom \<mu>] = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> src \<mu>)"
       unfolding runit_def
       using assms PB.runit_naturality by auto
 
     lemma iso_lunit [simp]:
     assumes "ide f"
     shows "iso \<l>[f]"
       unfolding lunit_def
       using assms PB.iso_lunit by blast
 
     lemma iso_runit [simp]:
     assumes "ide f"
     shows "iso \<r>[f]"
       unfolding runit_def
       using assms PB.iso_runit by blast
 
     lemma iso_lunit' [simp]:
     assumes "ide f"
     shows "iso \<l>\<^sup>-\<^sup>1[f]"
       using assms iso_lunit by blast
 
     lemma iso_runit' [simp]:
     assumes "ide f"
     shows "iso \<r>\<^sup>-\<^sup>1[f]"
       using assms iso_runit by blast
 
     lemma lunit'_in_hom [intro]:
     assumes "ide f"
     shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> trg f \<star> f\<guillemotright>"
     proof -
       show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> trg f \<star> f\<guillemotright>"
         using assms lunit_char iso_lunit by simp
       thus "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>"
         using assms src_dom trg_dom by simp
     qed
 
     lemma lunit'_in_vhom [simp]:
     assumes "ide f" and "trg f = b"
     shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> b \<star> f\<guillemotright>"
       using assms by auto
 
     lemma lunit'_simps [simp]:
     assumes "ide f"
     shows "arr \<l>\<^sup>-\<^sup>1[f]" and "src \<l>\<^sup>-\<^sup>1[f] = src f" and "trg \<l>\<^sup>-\<^sup>1[f] = trg f"
     and "dom \<l>\<^sup>-\<^sup>1[f] = f" and "cod \<l>\<^sup>-\<^sup>1[f] = trg f \<star> f"
       using assms lunit'_in_hom by auto
 
     lemma runit'_in_hom [intro]:
     assumes "ide f"
     shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> src f\<guillemotright>"
     proof -
       show "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> src f\<guillemotright>"
         using assms runit_char iso_runit by simp
       thus "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>"
         using src_dom trg_dom
         by (simp add: assms)
     qed
 
     lemma runit'_in_vhom [simp]:
     assumes "ide f" and "src f = a"
     shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> a\<guillemotright>"
       using assms by auto
 
     lemma runit'_simps [simp]:
     assumes "ide f"
     shows "arr \<r>\<^sup>-\<^sup>1[f]" and "src \<r>\<^sup>-\<^sup>1[f] = src f" and "trg \<r>\<^sup>-\<^sup>1[f] = trg f"
     and "dom \<r>\<^sup>-\<^sup>1[f] = f" and "cod \<r>\<^sup>-\<^sup>1[f] = f \<star> src f"
       using assms runit'_in_hom by auto
 
     interpretation L: endofunctor V L ..
     interpretation \<ll>: transformation_by_components V V L map lunit
       using lunit_in_hom lunit_naturality by unfold_locales auto
     interpretation \<ll>: natural_isomorphism V V L map \<ll>.map
       using iso_lunit by (unfold_locales, auto)
 
     lemma natural_isomorphism_\<ll>:
     shows "natural_isomorphism V V L map \<ll>.map"
       ..
 
     abbreviation \<ll>
     where "\<ll> \<equiv> \<ll>.map"
 
     lemma \<ll>_ide_simp:
     assumes "ide f"
     shows "\<ll> f = \<l>[f]"
       using assms by simp
 
     interpretation L: equivalence_functor V V L
       using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
 
     lemma equivalence_functor_L:
     shows "equivalence_functor V V L"
       ..
 
     lemma lunit_commutes_with_L:
     assumes "ide f"
     shows "\<l>[L f] = L \<l>[f]"
       unfolding lunit_def
       using assms PB.lunit_commutes_with_L by blast
 
     interpretation R: endofunctor V R ..
     interpretation \<rr>: transformation_by_components V V R map runit
       using runit_in_hom runit_naturality by unfold_locales auto
     interpretation \<rr>: natural_isomorphism V V R map \<rr>.map
       using iso_runit by (unfold_locales, auto)
 
     lemma natural_isomorphism_\<rr>:
     shows "natural_isomorphism V V R map \<rr>.map"
       ..
 
     abbreviation \<rr>
     where "\<rr> \<equiv> \<rr>.map"
 
     lemma \<rr>_ide_simp:
     assumes "ide f"
     shows "\<rr> f = \<r>[f]"
       using assms by simp
 
     interpretation R: equivalence_functor V V R
       using R.isomorphic_to_identity_is_equivalence \<rr>.natural_isomorphism_axioms by simp
 
     lemma equivalence_functor_R:
     shows "equivalence_functor V V R"
       ..
 
     lemma runit_commutes_with_R:
     assumes "ide f"
     shows "\<r>[R f] = R \<r>[f]"
       unfolding runit_def
       using assms PB.runit_commutes_with_R by blast
 
     lemma lunit'_naturality:
     assumes "arr \<mu>"
     shows "(trg \<mu> \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
       using assms iso_lunit lunit_naturality invert_opposite_sides_of_square L.preserves_arr
             L.preserves_cod arr_cod ide_cod ide_dom lunit_simps(1) lunit_simps(4) seqI
       by presburger
 
     lemma runit'_naturality:
     assumes "arr \<mu>"
     shows "(\<mu> \<star> src \<mu>) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
       using assms iso_runit runit_naturality invert_opposite_sides_of_square R.preserves_arr
             R.preserves_cod arr_cod ide_cod ide_dom runit_simps(1) runit_simps(4) seqI
       by presburger
 
     lemma isomorphic_unit_right:
     assumes "ide f"
     shows "f \<star> src f \<cong> f"
       using assms runit'_in_hom iso_runit' isomorphic_def isomorphic_symmetric by blast
 
     lemma isomorphic_unit_left:
     assumes "ide f"
     shows "trg f \<star> f \<cong> f"
       using assms lunit'_in_hom iso_lunit' isomorphic_def isomorphic_symmetric by blast
 
   end
 
   subsection "Further Properties of Bicategories"
 
   text \<open>
     Here we derive further properties of bicategories, now that we
     have the unitors at our disposal.  This section generalizes the corresponding
     development in theory @{theory MonoidalCategory.MonoidalCategory},
     which has some diagrams to illustrate the longer calculations.
     The present section also includes some additional facts that are now nontrivial
     due to the partiality of horizontal composition.
   \<close>
 
   context bicategory
   begin
 
     lemma unit_simps [simp]:
     assumes "obj a"
     shows "arr \<i>[a]" and "src \<i>[a] = a" and "trg \<i>[a] = a"
     and "dom \<i>[a] = a \<star> a" and "cod \<i>[a] = a"
       using assms unit_in_hom by blast+
 
     lemma triangle:
     assumes "ide f" and "ide g" and "src g = trg f"
     shows "(g \<star> \<l>[f]) \<cdot> \<a>[g, src g, f] = \<r>[g] \<star> f"
     proof -
       let ?b = "src g"
       have *: "(g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] = \<r>[g] \<star> ?b \<star> f"
       proof -
         have 1: "((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> \<a>[g \<star> ?b, ?b, f]
                     = (\<r>[g] \<star> ?b \<star> f) \<cdot> \<a>[g \<star> ?b, ?b, f]"
         proof -
           have "((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> \<a>[g \<star> ?b, ?b, f]
                   = (g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> \<a>[g \<star> ?b, ?b, f]"
             using HoVH_def HoHV_def comp_assoc by auto
           also have
               "... = (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> \<a>[?b, ?b, f]) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms pentagon by force
           also have
               "... = ((g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> \<a>[?b, ?b, f])) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms assoc_in_hom HoVH_def HoHV_def comp_assoc by auto
           also have
               "... = ((g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> \<a>[?b, ?b, f])) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms lunit_commutes_with_L lunit_in_hom by force
           also have "... = ((g \<star> (\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]) \<cdot> (g \<star> \<a>[?b, ?b, f]))
                              \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms lunit_char(2) by force
           also have "... = (g \<star> ((\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]) \<cdot> \<a>[?b, ?b, f])
                              \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms interchange [of g g "(\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]" "\<a>[?b, ?b, f]"]
             by auto
           also have "... = ((g \<star> \<i>[?b] \<star> f) \<cdot> \<a>[g, ?b \<star> ?b, f]) \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms comp_arr_dom comp_assoc_assoc' comp_assoc by auto
           also have "... = (\<a>[g, ?b, f] \<cdot> ((g \<star> \<i>[?b]) \<star> f)) \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
             using assms assoc_naturality [of g "\<i>[?b]" f] by simp
           also have "... = \<a>[g, ?b, f] \<cdot> ((g \<star> \<i>[?b]) \<cdot> \<a>[g, ?b, ?b] \<star> f)"
             using assms interchange [of "g \<star> \<i>[?b]" "\<a>[g, ?b, ?b]" f f] comp_assoc by simp
           also have "... = \<a>[g, ?b, f] \<cdot> ((\<r>[g] \<star> ?b) \<star> f)"
             using assms runit_char(2) by force
           also have "... = (\<r>[g] \<star> ?b \<star> f) \<cdot> \<a>[g \<star> ?b, ?b, f]"
             using assms assoc_naturality [of "\<r>[g]" ?b f] by auto
           finally show ?thesis by blast
         qed
         show "(g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] = \<r>[g] \<star> ?b \<star> f"
         proof -
           have "epi \<a>[g \<star> ?b, ?b, f]"
             using assms preserves_ide iso_assoc iso_is_retraction retraction_is_epi by force
           thus ?thesis
             using assms 1 by auto
         qed
       qed
       have "(g \<star> \<l>[f]) \<cdot> \<a>[g, ?b, f] = ((g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot>
                                      (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
       proof -
         have "\<a>[g, ?b, f] = (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
         proof -
           have "\<a>[g, ?b, f] = (g \<star> ?b \<star> f) \<cdot> \<a>[g, ?b, f]"
             using assms comp_cod_arr by simp
           have "\<a>[g, ?b, f] = ((g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot> \<a>[g, ?b, f]"
             using assms comp_cod_arr comp_arr_inv' whisker_left [of g]
                   whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"]
             by simp
           also have "... = (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
             using assms iso_lunit assoc_naturality [of g ?b "\<l>\<^sup>-\<^sup>1[f]"] comp_assoc by force
           finally show ?thesis by blast
         qed
         moreover have "g \<star> \<l>[f] = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])"
         proof -
           have "(g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) = g \<star> ?b \<star> f"
           proof -
             have "(g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) = (g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])"
               using assms lunit_in_hom lunit_commutes_with_L by simp
             also have "... = g \<star> ?b \<star> f"
               using assms comp_arr_inv' whisker_left [of g] whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"]
               by simp
             finally show ?thesis by blast
           qed
           thus ?thesis
             using assms comp_arr_dom by auto
         qed
         ultimately show ?thesis by simp
       qed
       also have "... = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> ((g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) \<cdot> (g \<star> ?b \<star> \<l>[f])) \<cdot>
                        \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
         using comp_assoc by simp
       also have "... = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> ((g \<star> ?b \<star> (?b \<star> f)) \<cdot>
                        \<a>[g, ?b, ?b \<star> f]) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
         using assms iso_lunit comp_inv_arr' interchange [of g g "?b \<star> \<l>\<^sup>-\<^sup>1[f]" "?b \<star> \<l>[f]"]
               interchange [of ?b ?b "\<l>\<^sup>-\<^sup>1[f]" "\<l>[f]"] comp_assoc
         by auto
       also have "... = (g \<star> \<l>[f]) \<cdot> ((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
         using assms comp_cod_arr comp_assoc by auto
       also have "... = \<r>[g] \<star> f"
       proof -
         have "\<r>[g] \<star> f = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> ?b \<star> f) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
         proof -
           have "(g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> ?b \<star> f) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])
                   = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<cdot> (g \<star> ?b) \<star> (?b \<star> f) \<cdot> \<l>\<^sup>-\<^sup>1[f])"
             using assms iso_lunit interchange [of "\<r>[g]" "g \<star> ?b" "?b \<star> f" "\<l>\<^sup>-\<^sup>1[f]"]
             by force
           also have "... = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> \<l>\<^sup>-\<^sup>1[f])"
             using assms comp_arr_dom comp_cod_arr by simp
           also have "... = \<r>[g] \<star> \<l>[f] \<cdot> \<l>\<^sup>-\<^sup>1[f]"
             using assms interchange [of g "\<r>[g]" "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] comp_cod_arr
             by simp
           also have "... = \<r>[g] \<star> f"
             using assms iso_lunit comp_arr_inv' by simp
           finally show ?thesis by argo
         qed
         thus ?thesis using assms * by argo
       qed
       finally show ?thesis by blast
     qed
 
     lemma lunit_hcomp_gen:
     assumes "ide f" and "ide g" and "ide h"
     and "src f = trg g" and "src g = trg h"
     shows "(f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h]) = f \<star> \<l>[g] \<star> h"
     proof -
       have "((f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])) \<cdot> \<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h) =
             (f \<star> (\<l>[g] \<star> h)) \<cdot> \<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)"
       proof -
         have "((f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])) \<cdot> (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)) =
               ((f \<star> \<l>[g \<star> h]) \<cdot> \<a>[f, trg g, g \<star> h]) \<cdot> \<a>[f \<star> trg g, g, h]"
           using assms pentagon comp_assoc by simp
         also have "... = (\<r>[f] \<star> (g \<star> h)) \<cdot> \<a>[f \<star> trg g, g, h]"
           using assms triangle [of "g \<star> h" f] by auto
         also have "... = \<a>[f, g, h] \<cdot> ((\<r>[f] \<star> g) \<star> h)"
           using assms assoc_naturality [of "\<r>[f]" g h] by simp
         also have "... = (\<a>[f, g, h] \<cdot> ((f \<star> \<l>[g]) \<star> h)) \<cdot> (\<a>[f, trg g, g] \<star> h)"
           using assms triangle interchange [of "f \<star> \<l>[g]" "\<a>[f, trg g, g]" h h] comp_assoc
           by auto
         also have "... = (f \<star> (\<l>[g] \<star> h)) \<cdot> (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h))"
           using assms assoc_naturality [of f "\<l>[g]" h] comp_assoc by simp
         finally show ?thesis by blast
       qed
       moreover have "iso (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h))"
         using assms iso_assoc isos_compose by simp
       ultimately show ?thesis
         using assms iso_is_retraction retraction_is_epi
               epiE [of "\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)"
                          "(f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])" "f \<star> \<l>[g] \<star> h"]
          by auto
     qed
 
     lemma lunit_hcomp:
     assumes "ide f" and "ide g" and "src f = trg g"
     shows "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g] = \<l>[f] \<star> g"
     and "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = \<l>\<^sup>-\<^sup>1[f] \<star> g"
     and "\<l>[f \<star> g] = (\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g]"
     and "\<l>\<^sup>-\<^sup>1[f \<star> g] = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
     proof -
       show 1: "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g] = \<l>[f] \<star> g"
       proof -
         have "L (\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]) = L (\<l>[f] \<star> g)"
           using assms interchange [of "trg f" "trg f" "\<l>[f \<star> g]" "\<a>[trg f, f, g]"] lunit_hcomp_gen
           by fastforce
         thus ?thesis
           using assms L.is_faithful [of "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]" "\<l>[f] \<star> g"] by force
       qed
       show "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = \<l>\<^sup>-\<^sup>1[f] \<star> g"
       proof -
         have "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = inv (\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g])"
           using assms by (simp add: inv_comp)
         also have "... = inv (\<l>[f] \<star> g)"
           using 1 by simp
         also have "... = \<l>\<^sup>-\<^sup>1[f] \<star> g"
           using assms by simp
         finally show ?thesis by simp
       qed
       show 2: "\<l>[f \<star> g] = (\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g]"
         using assms 1 invert_side_of_triangle(2) by auto
       show "\<l>\<^sup>-\<^sup>1[f \<star> g] = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
       proof -
         have "\<l>\<^sup>-\<^sup>1[f \<star> g] = inv ((\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g])"
           using 2 by simp
         also have "... = \<a>[trg f, f, g] \<cdot> inv (\<l>[f] \<star> g)"
           using assms inv_comp by simp
         also have "... = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
           using assms by simp
         finally show ?thesis by simp
       qed
     qed
 
     lemma runit_hcomp_gen:
     assumes "ide f" and "ide g" and "ide h"
     and "src f = trg g" and "src g = trg h"
     shows "\<r>[f \<star> g] \<star> h = ((f \<star> \<r>[g]) \<star> h) \<cdot> (\<a>[f, g, src g] \<star> h)"
     proof -
       have "\<r>[f \<star> g] \<star> h = ((f \<star> g) \<star> \<l>[h]) \<cdot> \<a>[f \<star> g, src g, h]"
         using assms triangle by simp
       also have "... = (\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> g \<star> \<l>[h]) \<cdot> \<a>[f, g, src g \<star> h]) \<cdot> \<a>[f \<star> g, src g, h]"
         using assms assoc_naturality [of f g "\<l>[h]"] invert_side_of_triangle(1)
         by simp
       also have "... = \<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> g \<star> \<l>[h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
         using comp_assoc by simp
       also have "... = (\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> (\<r>[g] \<star> h))) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot>
                        \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
         using assms interchange [of f f] triangle comp_assoc
               invert_side_of_triangle(2) [of "\<r>[g] \<star> h" "g \<star> \<l>[h]" "\<a>[g, src g, h]"]
         by simp
       also have "... = ((f \<star> \<r>[g]) \<star> h) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> src g, h] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot>
                        \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
         using assms assoc'_naturality [of f "\<r>[g]" h] comp_assoc by simp
       also have "... = ((f \<star> \<r>[g]) \<star> h) \<cdot> (\<a>[f, g, src g] \<star> h)"
         using assms pentagon [of f g "src g" h] iso_assoc inv_hcomp
               invert_side_of_triangle(1)
                 [of "\<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]" "f \<star> \<a>[g, src g, h]"
                     "\<a>[f, g \<star> src g, h] \<cdot> (\<a>[f, g, src g] \<star> h)"]
               invert_side_of_triangle(1)
                 [of "(f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
                     "\<a>[f, g \<star> src g, h]" "\<a>[f, g, src g] \<star> h"]
         by auto
       finally show ?thesis by blast
     qed
 
     lemma runit_hcomp:
     assumes "ide f" and "ide g" and "src f = trg g"
     shows "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
     and "\<r>\<^sup>-\<^sup>1[f \<star> g] = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
     and "\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g] = f \<star> \<r>[g]"
     and "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = f \<star> \<r>\<^sup>-\<^sup>1[g]"
     proof -
       show 1: "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
         using assms interchange [of "f \<star> \<r>[g]" "\<a>[f, g, src g]" "src g" "src g"]
               runit_hcomp_gen [of f g "src g"]
               R.is_faithful [of "(f \<star> \<r>[g]) \<cdot> (\<a>[f, g, src g])" "\<r>[f \<star> g]"]
         by simp
       show "\<r>\<^sup>-\<^sup>1[f \<star> g] = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
         using assms 1 inv_comp inv_hcomp by auto
       show 2: "\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g] = f \<star> \<r>[g]"
         using assms 1 comp_arr_dom comp_cod_arr comp_assoc hseqI' comp_assoc_assoc' by auto
       show "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = f \<star> \<r>\<^sup>-\<^sup>1[g]"
       proof -
         have "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = inv (\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g])"
           using assms inv_comp by simp
         also have "... = inv (f \<star> \<r>[g])"
           using 2 by simp
         also have "... = f \<star> \<r>\<^sup>-\<^sup>1[g]"
           using assms inv_hcomp [of f "\<r>[g]"] by simp
         finally show ?thesis by simp
       qed
     qed
 
     lemma unitor_coincidence:
     assumes "obj a"
     shows "\<l>[a] = \<i>[a]" and "\<r>[a] = \<i>[a]"
     proof -
       have "R \<l>[a] = R \<i>[a] \<and> R \<r>[a] = R \<i>[a]"
       proof -
         have "R \<l>[a] = (a \<star> \<l>[a]) \<cdot> \<a>[a, a, a]"
           using assms lunit_hcomp [of a a] lunit_commutes_with_L [of a] by auto
         moreover have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = R \<r>[a]"
           using assms triangle [of a a] by auto
         moreover have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = R \<i>[a]"
         proof -
           have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = ((\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a]) \<cdot> \<a>[a, a, a]"
             using assms lunit_char(2) by force
           also have "... = R \<i>[a]"
             using assms comp_arr_dom comp_assoc comp_assoc_assoc'
             apply (elim objE)
             by (simp add: assms)
           finally show ?thesis by blast
         qed
         ultimately show ?thesis by argo
       qed
       moreover have "par \<l>[a] \<i>[a] \<and> par \<r>[a] \<i>[a]"
         using assms by auto
       ultimately have 1: "\<l>[a] = \<i>[a] \<and> \<r>[a] = \<i>[a]"
         using R.is_faithful by blast
       show "\<l>[a] = \<i>[a]" using 1 by auto
       show "\<r>[a] = \<i>[a]" using 1 by auto
     qed
 
     lemma unit_triangle:
     assumes "obj a"
     shows "\<i>[a] \<star> a = (a \<star> \<i>[a]) \<cdot> \<a>[a, a, a]"
     and "(\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] = a \<star> \<i>[a]"
     proof -
       show 1: "\<i>[a] \<star> a = (a \<star> \<i>[a]) \<cdot> \<a>[a, a, a]"
         using assms triangle [of a a] unitor_coincidence by auto
       show "(\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] = a \<star> \<i>[a]"
         using assms 1 invert_side_of_triangle(2) [of "\<i>[a] \<star> a" "a \<star> \<i>[a]" "\<a>[a, a, a]"]
               assoc'_eq_inv_assoc
         by (metis hseqI' iso_assoc objE obj_def' unit_simps(1) unit_simps(2))
     qed
 
     lemma hcomp_assoc_isomorphic:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "(f \<star> g) \<star> h \<cong> f \<star> g \<star> h"
       using assms assoc_in_hom [of f g h] iso_assoc isomorphic_def by auto
 
     lemma hcomp_arr_obj:
     assumes "arr \<mu>" and "obj a" and "src \<mu> = a"
     shows "\<mu> \<star> a = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<r>[dom \<mu>]"
     and "\<r>[cod \<mu>] \<cdot> (\<mu> \<star> a) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
     proof -
       show "\<mu> \<star> a = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<r>[dom \<mu>]"
         using assms iso_runit runit_naturality comp_cod_arr
         by (metis ide_cod ide_dom invert_side_of_triangle(1) runit_simps(1) runit_simps(5) seqI)
       show "\<r>[cod \<mu>] \<cdot> (\<mu> \<star> a) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
         using assms iso_runit runit_naturality [of \<mu>] comp_cod_arr
         by (metis ide_dom invert_side_of_triangle(2) comp_assoc runit_simps(1)
             runit_simps(5) seqI)
     qed
 
     lemma hcomp_obj_arr:
     assumes "arr \<mu>" and "obj b" and "b = trg \<mu>"
     shows "b \<star> \<mu> = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<l>[dom \<mu>]"
     and "\<l>[cod \<mu>] \<cdot> (b \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
     proof -
       show "b \<star> \<mu> = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<l>[dom \<mu>]"
         using assms iso_lunit lunit_naturality comp_cod_arr
         by (metis ide_cod ide_dom invert_side_of_triangle(1) lunit_simps(1) lunit_simps(5) seqI)
       show "\<l>[cod \<mu>] \<cdot> (b \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
         using assms iso_lunit lunit_naturality [of \<mu>] comp_cod_arr
         by (metis ide_dom invert_side_of_triangle(2) comp_assoc lunit_simps(1)
             lunit_simps(5) seqI)
     qed
 
     lemma hcomp_reassoc:
     assumes "arr \<tau>" and "arr \<mu>" and "arr \<nu>"
     and "src \<tau> = trg \<mu>" and "src \<mu> = trg \<nu>"
     shows "(\<tau> \<star> \<mu>) \<star> \<nu> = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
     and "\<tau> \<star> \<mu> \<star> \<nu> = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
     proof -
       show "(\<tau> \<star> \<mu>) \<star> \<nu> = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
       proof -
         have "(\<tau> \<star> \<mu>) \<star> \<nu> = (\<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>]) \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
           using assms comp_assoc_assoc'(2) comp_cod_arr by simp
         also have "... = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
           using comp_assoc by simp
         also have "... = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
           using assms assoc_naturality by simp
         finally show ?thesis by simp
       qed
       show "\<tau> \<star> \<mu> \<star> \<nu> = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
       proof -
         have "\<tau> \<star> \<mu> \<star> \<nu> = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>] \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
           using assms comp_assoc_assoc'(1) comp_arr_dom by simp
         also have "... = ((\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
           using comp_assoc by simp
         also have "... = (\<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
           using assms assoc_naturality by simp
         also have "... = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
           using comp_assoc by simp
         finally show ?thesis by simp
       qed
     qed
 
     lemma triangle':
     assumes "ide f" and "ide g" and "src f = trg g"
     shows "(f \<star> \<l>[g]) = (\<r>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g]"
-    proof -
-      have "(\<r>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g] = ((f \<star> \<l>[g]) \<cdot> \<a>[f, src f, g]) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g]"
-        using assms triangle by auto
-      also have "... = (f \<star> \<l>[g])"
-        using assms comp_arr_dom comp_assoc comp_assoc_assoc' by auto
-      finally show ?thesis by auto
-    qed
+      using assms(1-3) invert_side_of_triangle(2) triangle by force
 
     lemma pentagon':
     assumes "ide f" and "ide g" and "ide h" and "ide k"
     and "src f = trg g" and "src g = trg h" and "src h = trg k"
     shows "((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])
               = \<a>\<^sup>-\<^sup>1[f \<star> g, h, k] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h \<star> k]"
     proof -
       have "((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])
               = inv ((f \<star> \<a>[g, h, k]) \<cdot> (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)))"
       proof -
         have "inv ((f \<star> \<a>[g, h, k]) \<cdot> (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))) =
               inv (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)) \<cdot> inv (f \<star> \<a>[g, h, k])"
           using assms inv_comp [of "\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)" "f \<star> \<a>[g, h, k]"]
           by force
         also have "... = (inv (\<a>[f, g, h] \<star> k) \<cdot> inv \<a>[f, g \<star> h, k]) \<cdot> inv (f \<star> \<a>[g, h, k])"
           using assms iso_assoc inv_comp by simp
         also have "... = ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])"
           using assms inv_hcomp by simp
         finally show ?thesis by simp
       qed
       also have "... = inv (\<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k])"
         using assms pentagon by simp
       also have "... = \<a>\<^sup>-\<^sup>1[f \<star> g, h, k] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h \<star> k]"
         using assms inv_comp by simp
       finally show ?thesis by auto
     qed
 
   end
 
   text \<open>
     The following convenience locale extends @{locale bicategory} by pre-interpreting
     the various functors and natural transformations.
   \<close>
 
   locale extended_bicategory =
     bicategory +
     L: equivalence_functor V V L +
     R: equivalence_functor V V R +
     \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
           \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
     \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
           \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
     \<ll>: natural_isomorphism V V L map \<ll> +
     \<ll>': inverse_transformation V V L map \<ll> +
     \<rr>: natural_isomorphism V V R map \<rr> +
     \<rr>': inverse_transformation V V R map \<rr>
 
   sublocale bicategory \<subseteq> extended_bicategory V H \<a> \<i> src trg
   proof -
     interpret L: equivalence_functor V V L using equivalence_functor_L by auto
     interpret R: equivalence_functor V V R using equivalence_functor_R by auto
     interpret \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
                     \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> ..
     interpret \<ll>: natural_isomorphism V V L map \<ll> using natural_isomorphism_\<ll> by auto
     interpret \<ll>': inverse_transformation V V L map \<ll> ..
     interpret \<rr>: natural_isomorphism V V R map \<rr> using natural_isomorphism_\<rr> by auto
     interpret \<rr>': inverse_transformation V V R map \<rr> ..
     interpret extended_bicategory V H \<a> \<i> src trg ..
     show "extended_bicategory V H \<a> \<i> src trg" ..
   qed
 
 end
diff --git a/thys/Bicategory/BicategoryOfSpans.thy b/thys/Bicategory/BicategoryOfSpans.thy
--- a/thys/Bicategory/BicategoryOfSpans.thy
+++ b/thys/Bicategory/BicategoryOfSpans.thy
@@ -1,14697 +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
-                apply (intro C.commutative_squareI) by auto
+                by (intro C.commutative_squareI) auto
               have "C.commutative_square r0 ?u1 (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
-              proof
-                have 1: "r0 \<cdot> ?p1' = ?u1 \<cdot> \<theta>'.chine"
-                  using \<theta>'.leg1_commutes Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite by simp
-                show "C.cospan r0 ?u1"
-                  using ru.legs_form_cospan(1) by blast
-                show "C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
-                  using \<beta>.chine_in_hom \<theta>'.chine_in_hom
-                  by (metis "1" C.dom_comp C.in_homE C.prj1_simps(1) C.prj1_simps(2)
-                      C.seqI Cod_\<theta>'_1 Dom_\<theta>'.leg_simps(3) Chn_\<beta> \<theta>'.leg1_commutes cospan')
-                show "C.dom r0 = C.cod (?p1' \<cdot> \<beta>.chine)"
-                  using \<beta>.chine_in_hom
-                  by (metis C.cod_comp C.prj1_simps(3)
-                      \<open>C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
-                      cospan' r.dom.apex_def r.chine_eq_apex r.chine_simps(2))
-                show "r0 \<cdot> ?p1' \<cdot> \<beta>.chine = ?u1 \<cdot> \<theta>'.chine \<cdot> \<beta>.chine"
-                  using 1 \<beta>.chine_in_hom C.comp_assoc by metis
-              qed
+                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
-                apply (intro C.commutative_squareI) by auto
+                by (intro C.commutative_squareI) auto
               have "C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0"
-                using cospan'
-                apply (intro C.commutative_squareI)
-                   apply simp_all
-                by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
-                    arrow_of_spans_data.select_convs(2) rfw'.prj_simps(3)
-                    span_data.select_convs(1-2))
+                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>)"
-              proof -
-                have "Chn (g \<star> ?\<gamma>) = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> Chn \<beta>\<rangle>"
-                  using Chn_g\<gamma> by simp
-                also have "... = \<beta>.chine"
-                  text \<open>Here was another score by sledgehammer while I was still trying
-                    to understand it.\<close>
-                  using ** C.prj_joint_monic
-                  by (metis C.prj1_simps(1) C.tuple_prj cospan cospan')
-                finally show ?thesis by simp
-              qed
+                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 "isomorphic ((g \<star> w) \<star> (src w)\<^sup>*) (g \<star> w)"
+        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 "isomorphic (src (g \<star> w)) (src w)\<^sup>*"
+          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>]
-        apply (elim conjE in_homE) by simp
+        by (elim conjE in_homE) simp
       have "hseq (src w) e'"
         using * ide_dom [of \<theta>']
-        apply (elim conjE in_homE) by simp
+        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"
-             proof -
-               have "h \<star> g \<star> f \<cong>\<^sub>B h \<star> gf"
-                 using 1 hgf B.hcomp_ide_isomorphic
-                 by (metis (full_types) B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
-                     B.isomorphic_symmetric B.seq_if_composable)
-               also have "h \<star> gf \<cong>\<^sub>B x"
-                 using 1 by simp
-               finally show ?thesis by blast
-             qed
+               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"
-               using 1 F G H hgf B.is_iso_class_def is_iso_class_Comp [of H G]
-                     B.isomorphic_reflexive [of "h \<star> g"]
-               apply (intro in_CompI)
-                           apply auto[7]
-                 apply blast
-                apply simp
-               by (meson B.isomorphic_symmetric B.isomorphic_transitive)
+               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"
-             proof -
-               have "(h \<star> g) \<star> f \<cong>\<^sub>B hg \<star> f"
-                 using 1 F G H hgf
-                 by (simp add: B.hcomp_isomorphic_ide)
-               also have "hg \<star> f \<cong>\<^sub>B x"
-                 using 1 by simp
-               finally show ?thesis by blast
-             qed
+               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
            REP_simps(2) B.is_iso_classI B.ide_in_iso_class B.iso_class_elems_isomorphic
            B.src.preserves_ide)
 
      lemma isomorphic_REP_trg:
      assumes "ide A"
      shows "REP A \<cong>\<^sub>B trg (REP A)"
        using assms ide_char isomorphic_REP_src by auto
 
      lemma CLS_REP:
      assumes "arr F"
      shows "\<lbrakk>\<lbrakk>REP F\<rbrakk>\<rbrakk> = F"
        by (metis (mono_tags, lifting) MkArr_Map
            is_concrete_category REP_in_Map REP_simps(2) REP_simps(3) assms
            concrete_category.Map_in_Hom in_HomD(6))
 
      lemma REP_CLS:
      assumes "B.is_left_adjoint f"
      shows "REP \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<cong>\<^sub>B f"
        by (metis (mono_tags, lifting) CLS_in_hom Map.simps(1) in_homE REP_in_Map
            assms B.iso_class_def B.isomorphic_symmetric mem_Collect_eq)
 
      lemma isomorphic_hcomp_REP:
      assumes "seq F G"
      shows "REP F \<star> REP G \<cong>\<^sub>B REP (F \<odot> G)"
      proof -
        have 1: "Dom F = Cod G"
          using assms seq_char by simp
        have 2: "Map F = B.iso_class (REP F)"
          using assms seq_char arr_char REP_in_Map in_HomD(6) by meson
        have 3: "Map G = B.iso_class (REP G)"
          using assms seq_char arr_char REP_in_Map
                in_HomD(6) [of "Map G" "Dom G" "Cod G" "REP G"]
          by auto
        have "Map (F \<odot> G) = Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
          using assms seq_char null_char
          by (metis (no_types, lifting) CLS_REP Map.simps(1) Map_comp)
        have "Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B = \<lbrakk>REP F \<star> REP G\<rbrakk>\<^sub>B"
        proof -
          have "REP F \<star> REP G \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
          proof -
            have "REP F \<in> Map F \<and> REP G \<in> Map G"
              using assms seq_char REP_in_Map by auto
            moreover have "REP F \<star> REP G \<cong>\<^sub>B REP F \<star> REP G"
              using assms seq_char 2 B.isomorphic_reflexive by auto                   
            ultimately show ?thesis
              using assms 1 2 3 B.iso_class_def B.is_iso_class_def
              by (intro in_CompI, auto)
          qed
          moreover have "\<lbrakk>REP F\<rbrakk>\<^sub>B \<in> Hom (Cod G) (Cod F)"
            using assms 1 2 arr_char [of F] by auto
          moreover have "\<lbrakk>REP G\<rbrakk>\<^sub>B \<in> Hom (Dom G) (Cod G)"
            using assms 1 3 arr_char [of G] by auto
          ultimately show ?thesis
            using Comp_eq_iso_class_memb assms arr_char arr_char REP_in_Map
            by (simp add: Comp_def)
        qed
        moreover have "REP (F \<odot> G) \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
        proof -
          have "Map (F \<odot> G) = Comp (Map F) (Map G)"
            using assms 1 comp_char [of F G] by simp
          thus ?thesis
            using assms 1 2 3 REP_in_Map [of "F \<odot> G"] by simp
        qed
        ultimately show ?thesis
          using B.iso_class_def by simp
      qed
 
      text \<open>
        We now show that \<open>Maps(B)\<close> has pullbacks.  For this we need to exhibit
        functions \<open>PRJ\<^sub>0\<close> and \<open>PRJ\<^sub>1\<close> that produce the legs of the pullback of a cospan \<open>(H, K)\<close>
        and verify that they have the required universal property.  These are obtained by
        choosing representatives \<open>h\<close> and \<open>k\<close> of \<open>H\<close> and \<open>K\<close>, respectively, and then taking
        \<open>PRJ\<^sub>0 = CLS (tab\<^sub>0 (k\<^sup>* \<star> h))\<close> and \<open>PRJ\<^sub>1 = CLS (tab\<^sub>1 (k\<^sup>* \<star> h))\<close>.  That these constitute a
        pullback in \<open>Maps(B)\<close> follows from the fact that \<open>tab\<^sub>0 (k\<^sup>* \<star> h)\<close> and \<open>tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
        form a pseudo-pullback of \<open>(h, k)\<close> in the underlying bicategory.
 
        For our purposes here, it is not sufficient simply to show that \<open>Maps(B)\<close> has pullbacks
        and then to treat it as an abstract ``category with pullbacks'' where the pullbacks
        are chosen arbitrarily.  Instead, we have to retain the connection between a pullback
        in Maps and the tabulation of \<open>k\<^sup>* \<star> h\<close> that is ultimately used to obtain it.  If we don't
        do this, then it becomes problematic to define the compositor of a pseudofunctor from
        the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>, because the components will go from the
        apex of a composite span (obtained by pullback) to the apex of a tabulation (chosen
        arbitrarily using \<open>BS2\<close>) and these need not be in agreement with each other.
      \<close>
 
      definition PRJ\<^sub>0
      where "PRJ\<^sub>0 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>0 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
      definition PRJ\<^sub>1
      where "PRJ\<^sub>1 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>1 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
 
      interpretation elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
      proof
        show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>0 K H = null"
          unfolding PRJ\<^sub>0_def by auto
        show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>1 K H = null"
          unfolding PRJ\<^sub>1_def by auto
        show "\<And>H K. cospan K H \<Longrightarrow> commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
        proof -
          fix H K
          assume HK: "cospan K H"
          define h where "h = REP H"
          define k where "k = REP K"
          have h: "h \<in> Map H"
            using h_def HK REP_in_Map by blast
          have k: "k \<in> Map K"
            using k_def HK REP_in_Map by blast
          have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
            using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
                  in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
                  in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
            apply auto
            by (metis (no_types, lifting) HK Dom_cod)
          interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
            using 1 by unfold_locales auto
          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 -
+                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 VV.arr_char composable Span.hcomp_def \<rho>\<sigma>.tab_simps(2) by auto
         finally show ?thesis by simp
       qed
       ultimately show ?thesis
         using composable Maps.arr_char Maps.dom_char SPN_r_SPN_s.dom.apex_def
         apply auto
         by (metis (no_types, lifting) Maps.not_arr_null SPN_r_SPN_s.chine_eq_apex
             SPN_r_SPN_s.chine_simps(1))
     qed
 
     text \<open>
       We will be taking the arrow @{term "CLS cmp"} of \<open>Maps\<close> as the composition isomorphism from
       @{term "SPN r \<circ> SPN s"} to @{term "SPN (r \<star> s)"}.  The following result shows that it
       has the right domain and codomain for that purpose.
     \<close>
 
     lemma iso_class_cmp_in_hom:
     shows "Maps.in_hom (Maps.MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
                        SPN_r_SPN_s.apex SPN_rs.apex"
     and "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex"
     proof -
       show "Maps.in_hom (Maps.MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
                         SPN_r_SPN_s.apex SPN_rs.apex"
       proof -
         have "obj (src \<rho>\<sigma>.tab)"
           using obj_src \<rho>\<sigma>.tab_in_hom by blast
         moreover have "obj (src tab)"
           using obj_src by simp
         moreover have "\<lbrakk>cmp\<rbrakk> \<in> Maps.Hom (src \<rho>\<sigma>.tab) (src tab)"
           by (metis (mono_tags, lifting) cmp.is_map cmp_def cmp_props(1) mem_Collect_eq)
         moreover have "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
           using SPN_r_SPN_s_apex_eq by simp
         moreover have "SPN_rs.apex = Maps.MkIde (src tab)"
           using SPN_def composable SPN_rs.cod.apex_def Maps.arr_char Maps.dom_char
                 SPN_rs.dom.leg_simps(1)
           by fastforce
         ultimately show ?thesis
           using Maps.MkArr_in_hom by simp
       qed
       thus "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex" by simp
     qed
 
     interpretation r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
                             V H \<a> \<i> src trg \<open>(Maps.REP R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP S\<^sub>1\<close>
     proof
       show "ide (Maps.REP S\<^sub>1)"
         using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
         by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
       show "ide (Maps.REP R\<^sub>0)\<^sup>*"
         using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
               Maps.REP_in_hhom(2) R\<^sub>0_in_hom by auto
       show "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
         using Maps.REP_in_hhom(2) R\<^sub>0_in_hom composable by auto
     qed
 
     interpretation R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
       by (unfold_locales, simp add: composable)
 
     lemma prj_tab_agreement:
     shows "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
     and "\<rho>\<sigma>.p\<^sub>0 \<cong> prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
     and "\<rho>\<sigma>.p\<^sub>1 \<cong> prj\<^sub>1 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
     proof -
       show 1: "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
       proof -
         have "(tab\<^sub>0 r)\<^sup>* \<cong> (Maps.REP R\<^sub>0)\<^sup>*"
           using Maps.REP_CLS isomorphic_symmetric R\<^sub>0_def composable r.satisfies_T0
                 isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint
           by fastforce
         moreover have "tab\<^sub>1 s \<cong> Maps.REP S\<^sub>1"
           by (metis Maps.REP_CLS isomorphic_symmetric S\<^sub>1_def s.leg1_is_map s.leg1_simps(3-4))
         moreover have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (tab\<^sub>1 s)"
           using composable r.T0.antipar right_adjoint_simps(2) by fastforce
         ultimately show ?thesis
           using hcomp_isomorphic_ide [of "(tab\<^sub>0 r)\<^sup>*" "(Maps.REP R\<^sub>0)\<^sup>*" "tab\<^sub>1 s"]
                 hcomp_ide_isomorphic isomorphic_transitive composable
           by auto
       qed
       show "\<rho>\<sigma>.p\<^sub>0 \<cong> tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
         using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
       show "\<rho>\<sigma>.p\<^sub>1 \<cong> tab\<^sub>1 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
         using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
     qed
 
     lemma chine_hcomp_SPN_SPN:
     shows "Span.chine_hcomp (SPN r) (SPN s) = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
     proof -
       have "Span.chine_hcomp (SPN r) (SPN s) =
             Maps.MkIde (src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)))"
         using Span.chine_hcomp_ide_ide [of "SPN r" "SPN s"] composable
               Maps.pbdom_def Maps.PRJ\<^sub>0_def Maps.CLS_in_hom Maps.dom_char R\<^sub>0_def S\<^sub>1_def
         apply simp
         using Maps.prj0_simps(1) RS_simps(1) RS_simps(16) RS_simps(18) RS_simps(3)
         by presburger
       also have "... = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
         using prj_tab_agreement isomorphic_implies_hpar(3) by force
       finally show ?thesis by simp
     qed
 
   end
 
   text \<open>
     The development above focused on two specific composable 1-cells in bicategory \<open>B\<close>.
     Here we reformulate those results as statements about the entire bicategory.
   \<close>
 
   context bicategory_of_spans
   begin
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp (infixr "\<odot>" 55)
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation SPN: "functor" V Span.vcomp SPN
       using SPN_is_functor by simp
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
       using SPN_is_weak_arrow_of_homs by simp
 
     interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
                                 SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
       ..
     interpretation SPNoH: composite_functor VV.comp V
                             Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
       ..
 
     text \<open>
       Given arbitrary composable 1-cells \<open>r\<close> and \<open>s\<close>, obtain an arrow of spans in \<open>Maps\<close>
       having the isomorphism class of \<open>rs.cmp\<close> as its chine.
     \<close>
 
     definition CMP
     where "CMP r s \<equiv>
            \<lparr>Chn = \<lbrakk>\<lbrakk>two_composable_identities_in_bicategory_of_spans.cmp V H \<a> \<i> src trg r s\<rbrakk>\<rbrakk>,
             Dom = Dom (SPN r \<circ> SPN s), Cod = Dom (SPN (r \<star> s))\<rparr>"
 
     lemma compositor_in_hom [intro]:
     assumes "ide r" and "ide s" and "src r = trg s"
     shows "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
     and "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
     proof -
       have rs: "VV.ide (r, s)"
         using assms VV.ide_char VV.arr_char by simp
       interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
         using rs VV.ide_char VV.arr_char 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 rs.composable
           by auto
       thus "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
         using assms VV.ide_char VV.arr_char VV.in_hom_char SPN.FF_def
         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 VV.arr_char by simp
       next
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
       let ?\<mu> = "fst \<mu>\<nu>"
       let ?\<nu> = "snd \<mu>\<nu>"
       show "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu> =
             SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
       proof -
         let ?LHS = "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu>"
         let ?RHS = "SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
         have LHS:
           "Span.in_hom ?LHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
         proof
           show "Span.in_hom (HoSPN_SPN.map \<mu>\<nu>) (HoSPN_SPN.map (VV.dom \<mu>\<nu>))
                             (HoSPN_SPN.map (VV.cod \<mu>\<nu>))"
             using \<mu>\<nu> by blast
           show "Span.in_hom (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)))
                             (HoSPN_SPN.map (VV.cod \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
             using \<mu>\<nu> VV.cod_simp by (auto simp add: VV.arr_char)
         qed
         have RHS:
           "Span.in_hom ?RHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
           using \<mu>\<nu> VV.dom_simp VV.cod_simp by (auto simp add: VV.arr_char)
         show "?LHS = ?RHS"
         proof (intro Span.arr_eqI)
           show "Span.par ?LHS ?RHS"
             apply (intro conjI)
             using LHS RHS apply auto[2]
           proof -
             show "Span.dom ?LHS = Span.dom ?RHS"
             proof -
               have "Span.dom ?LHS = HoSPN_SPN.map (VV.dom \<mu>\<nu>)"
                 using LHS by auto
               also have "... = Span.dom ?RHS"
                 using RHS by auto
               finally show ?thesis by simp
             qed
             show "Span.cod ?LHS = Span.cod ?RHS"
             proof -
               have "Span.cod ?LHS = SPNoH.map (VV.cod \<mu>\<nu>)"
                 using LHS by auto
               also have "... = Span.cod ?RHS"
                 using RHS by auto
               finally show ?thesis by simp
             qed
           qed
           show "Chn ?LHS = Chn ?RHS"
           proof -
             interpret dom_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                                  \<open>dom ?\<mu>\<close> \<open>dom ?\<nu>\<close>
               using \<mu>\<nu> VV.ide_char VV.arr_char by unfold_locales auto
             interpret cod_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                                  \<open>cod ?\<mu>\<close> \<open>cod ?\<nu>\<close>
               using \<mu>\<nu> VV.ide_char VV.arr_char by unfold_locales auto
             interpret \<mu>_\<nu>: horizontal_composite_of_arrows_of_tabulations_in_maps
                              V H \<a> \<i> src trg
                              \<open>dom ?\<mu>\<close> \<open>tab_of_ide (dom ?\<mu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>)\<close>
                              \<open>dom ?\<nu>\<close> \<open>tab_of_ide (dom ?\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<nu>)\<close>
                              \<open>cod ?\<mu>\<close> \<open>tab_of_ide (cod ?\<mu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>)\<close>
                              \<open>cod ?\<nu>\<close> \<open>tab_of_ide (cod ?\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<nu>)\<close>
                              ?\<mu> ?\<nu>
               using \<mu>\<nu> VV.arr_char by unfold_locales auto
 
             let ?\<mu>\<nu> = "?\<mu> \<star> ?\<nu>"
             interpret dom_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom ?\<mu>\<nu>\<close>
               using \<mu>\<nu> by (unfold_locales, simp)
             interpret cod_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod ?\<mu>\<nu>\<close>
               using \<mu>\<nu> by (unfold_locales, simp)
             interpret \<mu>\<nu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                             \<open>dom ?\<mu>\<nu>\<close> \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
                             \<open>cod ?\<mu>\<nu>\<close> \<open>tab_of_ide (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
                             ?\<mu>\<nu>
               using \<mu>\<nu> by unfold_locales auto
 
             have Chn_LHS_eq:
               "Chn ?LHS = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
             proof -
               have "Chn ?LHS = Chn (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>))) \<odot>
                                  Chn (HoSPN_SPN.map \<mu>\<nu>)"
                 using \<mu>\<nu> LHS Span.Chn_vcomp by blast
               also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Chn (HoSPN_SPN.map \<mu>\<nu>)"
                 using \<mu>\<nu> VV.arr_char VV.cod_char CMP_def by simp
               also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot>
                                  Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
                 using \<mu>\<nu> VV.arr_char SPN.FF_def Span.hcomp_def by simp
               finally show ?thesis by blast
             qed
             have Chn_RHS_eq:
                "Chn ?RHS = Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                       (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                       \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
                            Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                                       \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
             proof -
               have "Chn ?RHS = Chn (SPN (?\<mu> \<star> ?\<nu>)) \<odot>
                                Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                                           \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                 using \<mu>\<nu> RHS Span.vcomp_def VV.arr_char CMP_def Span.arr_char Span.not_arr_Null
                       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 Span.chine_hcomp_in_hom [of "SPN ?\<nu>" "SPN ?\<mu>"]
                     by auto
                   also have "... = Maps.Dom (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
                                                                   (Leg1 (Dom (SPN ?\<nu>)))))"
                   proof -
                     have "Maps.cospan (Leg0 (Dom (SPN (fst \<mu>\<nu>)))) (Leg1 (Dom (SPN (snd \<mu>\<nu>))))"
                       using \<mu>\<nu> VV.arr_char SPN_in_hom Span.arr_char Span.dom_char SPN_def
                             Maps.CLS_in_hom Maps.arr_char Maps.cod_char dom_\<mu>_\<nu>.composable
                             dom_\<mu>_\<nu>.RS_simps(16) dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.RS_simps(1)
                             dom_\<mu>_\<nu>.R\<^sub>0_def Maps.pbdom_in_hom
                       by simp
                     thus ?thesis
                       using \<mu>\<nu> VV.arr_char Maps.pbdom_in_hom by simp
                   qed
                   also have "... = Maps.Dom
                                      (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN (dom ?\<mu>))))
                                                            (Leg1 (Dom (SPN (dom ?\<nu>))))))"
                     using \<mu>\<nu> SPN_def VV.arr_char by simp
                   also have "... = Maps.Dom
                                      (Maps.dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>))))"
                     using \<mu>\<nu> VV.arr_char ide_dom
                     by (simp add: Span.chine_hcomp_ide_ide)
                   also have "... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
                     using Maps.Dom_dom Maps.in_homE SPN.preserves_reflects_arr SPN.preserves_src
                           SPN.preserves_trg Span.chine_hcomp_in_hom dom_\<mu>_\<nu>.composable
                           dom_\<mu>_\<nu>.r.base_simps(2) dom_\<mu>_\<nu>.s.base_simps(2)
                     by (metis (no_types, lifting))
                   finally show ?thesis by simp
                 qed
                 also have "... = src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
                   using "dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN" by simp
                 also have "... = Maps.Dom ?Chn_RHS"
                   using 2 Maps.seq_char Maps.Dom_comp by auto
                 finally show ?thesis by simp
               qed
               show "Maps.Cod ?Chn_LHS = Maps.Cod ?Chn_RHS"
               proof -
                 have "Maps.Cod ?Chn_LHS = src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>))"
                   using \<mu>\<nu> 1 VV.arr_char Maps.seq_char by auto
                 also have "... = src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))"
                   using \<mu>\<nu> VV.arr_char cod_\<mu>\<nu>.tab_simps(2) by auto
                 also have "... = Maps.Cod ?Chn_RHS"
                   by (metis (no_types, lifting) "2" Maps.Cod.simps(1) Maps.Cod_comp Maps.seq_char)
                 finally show ?thesis by simp
               qed
               show "Maps.Map ?Chn_LHS = Maps.Map ?Chn_RHS"
               proof -
                 have RHS: "Maps.Map ?Chn_RHS = iso_class (\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp)"
                 proof -
                   have "Maps.Map ?Chn_RHS = Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                     using \<mu>\<nu> 2 VV.arr_char Maps.Map_comp
                           Maps.comp_char
                             [of "Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                             (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
                                             \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
                                 "Maps.MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
                                             (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
                                             \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"]
                     by simp
                   also have "... = \<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk>"
                   proof -
                     have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
                           Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))"
                     proof -
                       have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
                             Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.tab) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))"
                         using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_props(1-3)
                         by (metis (mono_tags, lifting) equivalence_is_left_adjoint mem_Collect_eq)
                       thus ?thesis
                         using \<mu>\<nu> VV.arr_char dom_\<mu>\<nu>.tab_simps(2) by simp
                     qed
                     moreover have "\<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<in>
                                    Maps.Hom (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
                                             (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
                       using \<mu>\<nu> VV.arr_char \<mu>\<nu>.chine_in_hom \<mu>\<nu>.is_map by auto
                     moreover have
                       "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<in> Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                     proof
                       show "is_iso_class \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                         using is_iso_classI by simp
                       show "is_iso_class \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
                         using is_iso_classI by simp
                       show "dom_\<mu>_\<nu>.cmp \<in> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
                         using ide_in_iso_class [of dom_\<mu>_\<nu>.cmp] by simp
                       show "\<mu>\<nu>.chine \<in> \<lbrakk>\<mu>\<nu>.chine\<rbrakk>" 
                         using ide_in_iso_class by simp
                       show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> \<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp"
                         using \<mu>\<nu> VV.arr_char \<mu>\<nu>.chine_simps dom_\<mu>_\<nu>.cmp_simps dom_\<mu>\<nu>.tab_simps(2)
                               isomorphic_reflexive
                         by auto
                     qed
                     ultimately show ?thesis
                       using \<mu>\<nu> dom_\<mu>_\<nu>.cmp_props \<mu>\<nu>.chine_in_hom \<mu>\<nu>.chine_is_induced_map
                             Maps.Comp_eq_iso_class_memb
                       by blast
                   qed
                   finally show ?thesis by simp
                 qed
 
                 have LHS: "Maps.Map ?Chn_LHS = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
                 proof -
                   have "Maps.Map ?Chn_LHS =
                            Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
                                      (Maps.Map
                                        (Maps.tuple (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
                                                    (Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
                                                    (Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
                                                    (Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))))"
                   proof -
                     have "Maps.Map ?Chn_LHS =
                           Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
                                     (Maps.Map (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
                       using \<mu>\<nu> 1 VV.arr_char Maps.Map_comp cod_\<mu>\<nu>.tab_simps(2)
                             Maps.comp_char
                               [of "Maps.MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
                                               (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
                                               \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
                                   "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"]
                       by simp
                     moreover have "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>) =
                                    Maps.tuple
                                      (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
                                       (Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
                                       (Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
                                      (Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))"
                     proof -
                       have "Maps.PRJ\<^sub>0
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                             \<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<and>
                             Maps.PRJ\<^sub>1
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                               (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                             \<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
                       proof -
                         interpret X: identity_in_bicategory_of_spans V H \<a> \<i> src trg
                                        \<open>(tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)\<close>
                           using \<mu>\<nu> VV.arr_char
                           by (unfold_locales, simp)
                         have "Maps.PRJ\<^sub>0
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                               \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
                                                            \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
                                       Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
                                                            \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
                           unfolding Maps.PRJ\<^sub>0_def
                           using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
                                 dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
                                 dom_\<mu>_\<nu>.S\<^sub>1_def
                           by auto
                         moreover
                         have "Maps.PRJ\<^sub>1
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
                                 (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
                               \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
                                                            \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
                                      Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
                                                           \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
                           unfolding Maps.PRJ\<^sub>1_def
                           using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
                                 dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
                                 dom_\<mu>_\<nu>.S\<^sub>1_def
                           by auto
                         moreover
                         have "(Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
                                                     \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
                               Maps.REP (Maps.MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
                                                    \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) \<cong>
                               (tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)"
                           using VV.arr_char \<mu>\<nu> dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.s.leg1_simps(3)
                                 dom_\<mu>_\<nu>.s.leg1_simps(4) trg_dom dom_\<mu>_\<nu>.R\<^sub>0_def
                                 dom_\<mu>_\<nu>.prj_tab_agreement(1) isomorphic_symmetric
                           by simp
                         ultimately show ?thesis
                            using X.isomorphic_implies_same_tab isomorphic_symmetric by metis
                       qed
                       thus ?thesis
                         unfolding Span.chine_hcomp_def
                         using \<mu>\<nu> VV.arr_char SPN_def isomorphic_reflexive
                               Maps.comp_CLS [of "spn ?\<mu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1 "spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1"]
                               Maps.comp_CLS [of "spn ?\<nu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 "spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"]
                         by simp
                     qed
                     moreover have "Maps.Dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)) =
                                    src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
                       by (metis (no_types, lifting) "1" "2" Maps.Dom.simps(1) Maps.comp_char
                           \<open>Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS\<close>)
                     ultimately show ?thesis by simp
                   qed
                   also have "... = Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
                   proof -
                     let ?tuple = "Maps.tuple \<lbrakk>\<lbrakk>spn (fst \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
                                                \<lbrakk>\<lbrakk>tab\<^sub>0 (cod ?\<mu>)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (cod ?\<nu>)\<rbrakk>\<rbrakk>
                                              \<lbrakk>\<lbrakk>spn (snd \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
                     have "iso_class \<mu>_\<nu>.chine = Maps.Map ?tuple"
                       using \<mu>_\<nu>.CLS_chine spn_def Maps.Map.simps(1)
                       by (metis (no_types, lifting))
                     thus ?thesis by simp
                   qed
                   also have "... = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
                   proof -
                     have "\<lbrakk>\<mu>_\<nu>.chine\<rbrakk> \<in> Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)"
                     proof -
                       have "\<guillemotleft>\<mu>_\<nu>.chine : src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<guillemotright>"
                         using \<mu>\<nu> VV.arr_char by simp
                       thus ?thesis
                         using \<mu>_\<nu>.is_map ide_in_iso_class left_adjoint_is_ide by blast
                     qed
                     moreover have "\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<in>
                                    Maps.Hom (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
                     proof -
                       have "\<guillemotleft>cod_\<mu>_\<nu>.cmp : src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))\<guillemotright>"
                         using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_in_hom cod_\<mu>\<nu>.tab_simps(2)
                         by simp
                       thus ?thesis
                         using cod_\<mu>_\<nu>.cmp_props equivalence_is_left_adjoint left_adjoint_is_ide
                               ide_in_iso_class [of cod_\<mu>_\<nu>.cmp]
                         by (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 dom_\<mu>_\<nu>.cmp_interpretation by simp
                     interpret cod_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                         \<open>cod ?\<mu>\<nu>\<close>
                                         cod_\<mu>_\<nu>.\<rho>\<sigma>.tab
                                         \<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                         \<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                         \<open>cod ?\<mu>\<nu>\<close>
                                         \<open>tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)\<close>
                                         \<open>tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
                                         \<open>tab\<^sub>1 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
                                         \<open>cod ?\<mu>\<nu>\<close>
                       using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_interpretation by simp
                     interpret L: vertical_composite_of_arrows_of_tabulations_in_maps
                                    V H \<a> \<i> src trg
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
                                    \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                    \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                                    cod_\<mu>\<nu>.tab
                                    \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>?\<mu> \<star> ?\<nu>\<close>
                       using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_in_hom
                       by unfold_locales auto
                     interpret R: vertical_composite_of_arrows_of_tabulations_in_maps
                                    V H \<a> \<i> src trg
                                    \<open>dom ?\<mu>\<nu>\<close>
                                    \<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
                                    \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                    \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                                    \<open>cod_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
                                    \<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
                                    \<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                                    cod_\<mu>\<nu>.tab
                                    \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
                                    \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
                                    \<open>?\<mu> \<star> ?\<nu>\<close>
                                    \<open>cod ?\<mu>\<nu>\<close>
                        using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_in_hom
                        by unfold_locales auto
                     have "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> L.chine"
                       using \<mu>\<nu> VV.arr_char L.chine_char dom_\<mu>_\<nu>.cmp_def isomorphic_symmetric
                       by simp
                     also have "... = R.chine"
                       using L.is_ide \<mu>\<nu> comp_arr_dom comp_cod_arr isomorphic_reflexive by force
                     also have "... \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
                       using \<mu>\<nu> VV.arr_char R.chine_char cod_\<mu>_\<nu>.cmp_def by simp
                     finally show ?thesis by simp
                   qed
                 qed
                 show ?thesis
                   using LHS RHS EQ by simp
               qed
             qed
             thus ?thesis
               using Chn_LHS_eq Chn_RHS_eq by simp
           qed
         qed
       qed
     qed
 
     interpretation \<Xi>: natural_isomorphism VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<Xi>.map
       using VV.ide_char VV.arr_char \<Xi>.map_simp_ide compositor_is_iso
       by (unfold_locales, simp)
 
     lemma compositor_is_natural_transformation:
     shows "transformation_by_components VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map
              (\<lambda>rs. CMP (fst rs) (snd rs))"
       ..
 
     lemma compositor_is_natural_isomorphism:
     shows "natural_isomorphism VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map \<Xi>.map"
       ..
 
   end
   
   subsubsection "Associativity Coherence"
 
   locale three_composable_identities_in_bicategory_of_spans =
     bicategory_of_spans V H \<a> \<i> src trg +
     f: identity_in_bicategory_of_spans V H \<a> \<i> src trg f +
     g: identity_in_bicategory_of_spans V H \<a> \<i> src trg g +
     h: identity_in_bicategory_of_spans V H \<a> \<i> src trg h
   for V :: "'a comp"                 (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"     ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and f :: 'a
   and g :: 'a
   and h :: 'a +
   assumes fg: "src f = trg g"
   and gh: "src g = trg h"
   begin
 
     interpretation f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
       using f.is_arrow_of_tabulations_in_maps by simp
     interpretation h: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                         h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h
       using h.is_arrow_of_tabulations_in_maps by simp
 
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     interpretation Maps: maps_category V H \<a> \<i> src trg ..
     interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
 
     no_notation Fun.comp (infixl "\<circ>" 55)
     notation Span.vcomp (infixr "\<bullet>" 55)
     notation Span.hcomp (infixr "\<circ>" 53)
     notation Maps.comp (infixr "\<odot>" 55)
     notation isomorphic (infix "\<cong>" 50)
 
     interpretation SPN: "functor" V Span.vcomp SPN
       using SPN_is_functor by simp
     interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
       using SPN_is_weak_arrow_of_homs by simp
     interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
       using SPN.functor_FF by auto
     interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
                                 SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
       ..
     interpretation SPNoH: composite_functor VV.comp V Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
       ..
 
     text \<open>
       Here come a lot of interpretations for ``composite things''.
       We need these in order to have relatively short, systematic names for entities that will
       appear in the lemmas to follow.
       The names of the interpretations use a prefix notation, where \<open>H\<close> refers to horizontal
       composition of 1-cells and \<open>T\<close> refers to composite of tabulations.
       So, for example, \<open>THfgh\<close> refers to the composite of the tabulation associated with the
       horizontal composition \<open>f \<star> g\<close> with the tabulation associated with \<open>h\<close>.
     \<close>
     interpretation HHfgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation HfHgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation Tfg: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g
       using fg gh by unfold_locales auto
     interpretation Tgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg g h
       using fg gh by unfold_locales auto
     interpretation THfgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                             \<open>f \<star> g\<close> h
       using fg gh by unfold_locales auto
     interpretation THfgh: tabulation V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab
                             \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
       using THfgh.\<rho>\<sigma>.composite_is_tabulation by simp
     interpretation TfHgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
                             f \<open>g \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation TfHgh: tabulation V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab
                             \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
       using TfHgh.\<rho>\<sigma>.composite_is_tabulation by simp
 
     interpretation Tfg_Hfg: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                               \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
                               \<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
                               \<open>f \<star> g\<close>
       by unfold_locales auto
     interpretation Tgh_Hgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                               \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
                               \<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
                               \<open>g \<star> h\<close>
       by unfold_locales auto
     interpretation THfgh_HHfgh:
         arrow_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
           \<open>(f \<star> g) \<star> h\<close> \<open>tab_of_ide ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
           \<open>(f \<star> g) \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation TfHgh_HfHgh:
         arrow_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
           \<open>f \<star> g \<star> h\<close> \<open>tab_of_ide (f \<star> g \<star> h)\<close> \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
           \<open>f \<star> g \<star> h\<close>
       using fg gh by unfold_locales auto
     interpretation TTfgh: composite_tabulation_in_maps V H \<a> \<i> src trg
                             \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
                             h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
       using fg gh by unfold_locales auto
     interpretation TTfgh_THfgh:
         horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
           h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
           \<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
           h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
           \<open>f \<star> g\<close> h
       ..
     interpretation TfTgh: composite_tabulation_in_maps V H \<a> \<i> src trg
                             f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
                             \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
       using fg gh by unfold_locales auto
     interpretation TfTgh_TfHgh:
         horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
           f \<open>g \<star> h\<close>
       ..
     interpretation TfTgh_TfTgh:
         horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
           f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
           \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
           f \<open>g \<star> h\<close>
       ..
     text \<open>
       The following interpretation defines the associativity between the peaks
       of the two composite tabulations \<open>TTfgh\<close> (associated to the left) and \<open>TfTgh\<close>
       (associated to the right).
     \<close>
     (* TODO: Try to get rid of the .\<rho>\<sigma> in, e.g., Tfg.\<rho>\<sigma>.p\<^sub>1. *)
     interpretation TTfgh_TfTgh:
         arrow_of_tabulations_in_maps V H \<a> \<i> src trg
           \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
           \<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
           \<open>\<a>[f, g, h]\<close>
       using fg gh by unfold_locales auto
 
     text \<open>
       This interpretation defines the map, from the apex of the tabulation associated
       with the horizontal composite \<open>(f \<star> g) \<star> h\<close> to the apex of the tabulation associated
       with the horizontal composite \<open>f \<star> g \<star> h\<close>, induced by the associativity isomorphism
       \<open>\<a>[f, g, h]\<close> from \<open>(f \<star> g) \<star> h\<close> to \<open>f \<star> g \<star> h\<close>.
     \<close>
 
     interpretation HHfgh_HfHgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                   \<open>dom (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (dom (\<alpha> (f, g, h)))\<close>
                                   \<open>tab\<^sub>0 (dom (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (dom (\<alpha> (f, g, h)))\<close>
                                   \<open>cod (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (cod (\<alpha> (f, g, h)))\<close>
                                   \<open>tab\<^sub>0 (cod (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (cod (\<alpha> (f, g, h)))\<close>
                                   \<open>\<alpha> (f, g, h)\<close>
     proof -
       have "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
               ((f \<star> g) \<star> h) (tab_of_ide ((f \<star> g) \<star> h)) (tab\<^sub>0 ((f \<star> g) \<star> h)) (tab\<^sub>1 ((f \<star> g) \<star> h))
               (f \<star> g \<star> h) (tab_of_ide (f \<star> g \<star> h)) (tab\<^sub>0 (f \<star> g \<star> h)) (tab\<^sub>1 (f \<star> g \<star> h))
               \<a>[f, g, h]"
         using fg gh by unfold_locales auto
       thus "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
               (dom (\<alpha> (f, g, h))) (tab_of_ide (dom (\<alpha> (f, g, h))))
               (tab\<^sub>0 (dom (\<alpha> (f, g, h)))) (tab\<^sub>1 (dom (\<alpha> (f, g, h))))
               (cod (\<alpha> (f, g, h))) (tab_of_ide (cod (\<alpha> (f, g, h))))
               (tab\<^sub>0 (cod (\<alpha> (f, g, h)))) (tab\<^sub>1 (cod (\<alpha> (f, g, h))))
               (\<alpha> (f, g, h))"
         using fg gh \<alpha>_def by auto
     qed
 
     interpretation SPN_f: arrow_of_spans Maps.comp \<open>SPN f\<close>
       using SPN_in_hom Span.arr_char [of "SPN f"] by simp
     interpretation SPN_g: arrow_of_spans Maps.comp \<open>SPN g\<close>
       using SPN_in_hom Span.arr_char [of "SPN g"] by simp
     interpretation SPN_h: arrow_of_spans Maps.comp \<open>SPN h\<close>
       using SPN_in_hom Span.arr_char [of "SPN h"] by simp
     interpretation SPN_fgh: three_composable_identity_arrows_of_spans Maps.comp
                               Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 \<open>SPN f\<close> \<open>SPN g\<close> \<open>SPN h\<close>
       using fg gh Span.arr_char SPN_in_hom SPN.preserves_ide Span.ide_char
       apply unfold_locales by auto
 
     text \<open>
       The following relates the projections associated with the composite span \<open>SPN_fgh\<close>
       with tabulations in the underlying bicategory.
     \<close>
 
     lemma prj_char:
     shows "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     and "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
     proof -
       show "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "ide (Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
           by (metis TTfgh.composable TTfgh.leg1_simps(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
               Tfg.\<rho>\<sigma>.T0.ide_right Tfg_Hfg.u_simps(3) f.T0.antipar(2) f.T0.ide_right
               f.u_simps(3) fg g.ide_leg1 g.leg1_simps(4) h.ide_leg1 h.leg1_simps(4)
               ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(1))
         thus ?thesis
           using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
                 Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
                 Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>1 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1"]
           by (simp add: TTfgh.composable Tfg.\<rho>\<sigma>.T0.antipar(2))
       qed
       show "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
       proof -
         have "ide (Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
           by (metis TTfgh.leg1_simps(2) bicategory_of_spans.tab\<^sub>0_simps(1)
               bicategory_of_spans.tab\<^sub>1_simps(1) bicategory_of_spans_axioms
               Tfg.\<rho>\<sigma>.T0.antipar(2) Tfg.\<rho>\<sigma>.T0.ide_right Tfg.composable f.T0.antipar(2)
               f.T0.ide_right f.u_simps(3) g.ide_leg1 g.leg1_simps(4)
               Tfg.u_simps(3) THfgh.composable h.ide_leg1 h.leg1_simps(4)
               ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(3))
         thus ?thesis
           using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
                 Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
                 Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>0 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1"]
           by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
       qed
       show "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
         using isomorphic_reflexive TTfgh.prj_char Tfg.\<rho>\<sigma>.prj_char
               Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
         by (simp add: Tfg.composable)
       show "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
         using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
               Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
               TfTgh.prj_char
         by simp
       show "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
        using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
               Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
               Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>1 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0"]
         by simp
       show "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
         using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
               Maps.comp_CLS [of "tab\<^sub>1 g" "Tgh.\<rho>\<sigma>.p\<^sub>1" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
               Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>0 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0"]
         by simp
     qed
 
     interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
       using compositor_is_natural_transformation by simp
     interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
                         HoSPN_SPN.map SPNoH.map \<Phi>.map
       using compositor_is_natural_isomorphism by simp
 
     (*
      * TODO: Figure out how this subcategory gets introduced.
      * The simps in the locale are used in the subsequent proofs.
      *)
     interpretation VVV': subcategory VxVxV.comp
                            \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> arr (fst (snd \<tau>\<mu>\<nu>)) \<and> arr (snd (snd \<tau>\<mu>\<nu>)) \<and>
                                   src (fst (snd \<tau>\<mu>\<nu>)) = trg (snd (snd \<tau>\<mu>\<nu>)) \<and>
                                   src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
       using fg gh VVV.arr_char VV.arr_char VVV.subcategory_axioms by simp
 
     text \<open>
       We define abbreviations for the left and right-hand sides of the equation for
       associativity coherence.
     \<close>
     (*
      * TODO: \<Phi> doesn't really belong in this locale.  Replace it with CMP and rearrange
      * material so that this locale comes first and the definition of \<Phi> comes later
      * in bicategory_of_spans.
      *)
     abbreviation LHS
     where "LHS \<equiv> SPN \<a>[f, g, h] \<bullet> \<Phi>.map (f \<star> g, h) \<bullet> (\<Phi>.map (f, g) \<circ> SPN h)"
 
     abbreviation RHS
     where "RHS \<equiv> \<Phi>.map (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi>.map (g, h)) \<bullet>
                     Span.assoc (SPN f) (SPN g) (SPN h)"
 
     lemma arr_LHS:
     shows "Span.arr LHS"
       using fg gh VVV.arr_char VVV.ide_char VV.arr_char VV.ide_char Span.hseqI'
             HoHV_def compositor_in_hom \<alpha>_def
       apply (intro Span.seqI)
           apply simp_all
       using SPN.FF_def
        apply simp
     proof -
       have "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h)"
         using fg gh compositor_in_hom by simp
       also have "... = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
       proof -
         have "Span.seq (CMP (f \<star> g) h) (CMP f g \<circ> SPN h)"
         proof (intro Span.seqI Span.hseqI)
           show 1: "Span.in_hhom (SPN h) (SPN.map\<^sub>0 (src h)) (SPN.map\<^sub>0 (trg h))"
             using SPN.preserves_src SPN.preserves_trg by simp
           show 2: "Span.in_hhom (CMP f g) (SPN.map\<^sub>0 (trg h)) (SPN.map\<^sub>0 (trg f))"
             using compositor_in_hom SPN_fgh.\<nu>\<pi>.composable fg by auto
           show 3: "Span.arr (CMP (f \<star> g) h)"
             using TTfgh.composable Tfg.\<rho>\<sigma>.ide_base compositor_simps(1) h.is_ide by auto
           show "Span.dom (CMP (f \<star> g) h) = Span.cod (CMP f g \<circ> SPN h)"
             using 1 2 3 fg gh compositor_in_hom SPN_fgh.\<nu>\<pi>.composable SPN_in_hom SPN.FF_def
             by auto
         qed
         thus ?thesis by simp
       qed
       finally show "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
         by blast
     qed
 
     lemma arr_RHS:
     shows "Span.arr RHS"
       using fg gh VV.ide_char VV.arr_char \<Phi>.map_simp_ide SPN.FF_def Span.hseqI'
       by (intro Span.seqI, simp_all)
 
     lemma par_LHS_RHS:
     shows "Span.par LHS RHS"
     proof (intro conjI)
       show "Span.arr LHS"
         using arr_LHS by simp
       show "Span.arr RHS"
         using arr_RHS by simp
       show "Span.dom LHS = Span.dom RHS"
       proof -
         have "Span.dom LHS = Span.dom (\<Phi>.map (f, g) \<circ> SPN h)"
           using arr_LHS by auto
         also have "... = Span.dom (\<Phi>.map (f, g)) \<circ> Span.dom (SPN h)"
           using arr_LHS Span.dom_hcomp [of "SPN h" "\<Phi>.map (f, g)"] by blast
         also have "... = (SPN f \<circ> SPN g) \<circ> SPN h"
           using fg \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def by simp
         also have "... = Span.dom (Span.assoc (SPN f) (SPN g) (SPN h))"
           using fg gh VVV.arr_char VVV.ide_char VV.arr_char VV.ide_char by simp
         also have "... = Span.dom RHS"
           using \<open>Span.arr RHS\<close> by auto
         finally show ?thesis by blast
       qed
       show "Span.cod LHS = Span.cod RHS"
       proof -
         have "Span.cod LHS = Span.cod (SPN \<a>[f, g, h])"
           using arr_LHS by simp
         also have "... = SPN (f \<star> g \<star> h)"
           unfolding \<alpha>_def
           using fg gh VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char HoVH_def
           by simp
         also have "... = Span.cod RHS"
           using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def
                 compositor_in_hom
           by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma Chn_LHS_eq:
     shows "Chn LHS =
            \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
     proof -
       have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot>
                         Span.chine_hcomp (CMP f g) (SPN h)"
       proof -
         have "Chn LHS = Chn (SPN \<a>[f, g, h]) \<odot> Chn (CMP (f \<star> g) h) \<odot>
                           Chn (CMP f g \<circ> SPN h)"
           using fg gh arr_LHS \<Phi>.map_simp_ide VV.ide_char VV.arr_char Span.Chn_vcomp
           by auto
         moreover have "Chn (SPN \<a>[f, g, h]) = Maps.CLS HHfgh_HfHgh.chine"
           using fg gh SPN_def VVV.arr_char VV.arr_char spn_def \<alpha>_def by simp
         moreover have "Chn (CMP (f \<star> g) h) = Maps.CLS THfgh_HHfgh.chine"
           using fg gh CMP_def THfgh.cmp_def by simp
         moreover have "Chn (CMP f g \<circ> SPN h) = Span.chine_hcomp (CMP f g) (SPN h)"
           using fg gh Span.hcomp_def by simp
         ultimately show ?thesis by simp
       qed
       moreover have "Span.chine_hcomp (CMP f g) (SPN h) = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
       proof -
         have "Span.chine_hcomp (CMP f g) (SPN h) =
               Maps.tuple
                 (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
                    \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                 (\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
         proof -
           have "\<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
             using fg isomorphic_reflexive
                   Maps.comp_CLS [of "tab\<^sub>0 g" "Tfg.\<rho>\<sigma>.p\<^sub>0" "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
             by simp
           moreover have "span_in_category.apex Maps.comp
                            \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr> =
                          \<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk>"
           proof -
             interpret h: span_in_category Maps.comp \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr>\<close>
               using h.determines_span by simp
             interpret dom_h: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
                                \<open>dom h\<close> \<open>tab_of_ide (dom h)\<close> \<open>tab\<^sub>0 (dom h)\<close> \<open>tab\<^sub>1 (dom h)\<close>
                                \<open>cod h\<close> \<open>tab_of_ide (cod h)\<close> \<open>tab\<^sub>0 (cod h)\<close> \<open>tab\<^sub>1 (cod h)\<close>
                                h
               by (simp add: h.is_arrow_of_tabulations_in_maps
                   identity_arrow_of_tabulations_in_maps.intro
                   identity_arrow_of_tabulations_in_maps_axioms.intro)
             have "Maps.arr h.leg0"
               using h.leg_simps(1) by simp
             hence "Maps.dom h.leg0 = \<lbrakk>\<lbrakk>dom_h.chine\<rbrakk>\<rbrakk>"
               using Maps.dom_char Maps.CLS_in_hom
               apply simp
             proof -
               have "h.is_induced_map (src (tab\<^sub>0 h))"
                 using h.is_induced_map_iff dom_h.\<Delta>_eq_\<rho> h.apex_is_induced_by_cell by force
               hence "src (tab\<^sub>0 h) \<cong> h.chine"
                 using h.chine_is_induced_map h.induced_map_unique by simp
               thus "\<lbrakk>src (tab\<^sub>0 h)\<rbrakk> = \<lbrakk>h.chine\<rbrakk>"
                 using iso_class_eqI by simp
             qed
             thus ?thesis
               using h.apex_def spn_def by simp
           qed
           ultimately show ?thesis
             unfolding Span.chine_hcomp_def
             using fg gh CMP_def Tfg.\<rho>\<sigma>.prj_char Span.hcomp_def by simp
         qed
         also have "... = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
         proof -
           have "\<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
                 Maps.tuple \<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
                              \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                            \<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
             using TTfgh_THfgh.CLS_chine by simp
           also have "... =
                      Maps.tuple (\<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>)
                                   \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                                 (\<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
           proof -
             have "\<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
             proof -
               have "is_left_adjoint TTfgh.p\<^sub>1"
                 using Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable by simp
               moreover have "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1 \<cong> Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"
                 using TTfgh_THfgh.prj_chine(2) isomorphic_reflexive isomorphic_implies_hpar(2)
                 by blast
               ultimately show ?thesis
                 using Tfg_Hfg.is_map
                       Maps.comp_CLS [of Tfg_Hfg.chine TTfgh.p\<^sub>1 "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"]
                 by simp
             qed
             moreover have "\<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
             proof -
               have "is_left_adjoint TTfgh.p\<^sub>0"
                 by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
               moreover have "h.chine \<star> TTfgh.p\<^sub>0 \<cong> h.chine \<star> TTfgh.p\<^sub>0"
                 using TTfgh_THfgh.prj_chine(1) isomorphic_reflexive isomorphic_implies_hpar(2)
                 by blast
               ultimately show ?thesis
                 using h.is_map Maps.comp_CLS [of h.chine TTfgh.p\<^sub>0 "h.chine \<star> TTfgh.p\<^sub>0"]
                 by simp
             qed
             ultimately show ?thesis by argo
           qed
           also have "... =
                      Maps.tuple (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
                                   \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
                                 (\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
             using Tfg.cmp_def spn_def TTfgh.prj_char by simp
           finally show ?thesis by simp
         qed
         finally show ?thesis by blast
       qed
       ultimately show ?thesis by simp
     qed
 
     abbreviation tuple_BC
     where "tuple_BC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0"
 
     abbreviation tuple_ABC
     where "tuple_ABC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>1\<^sub>1
                                     SPN_fgh.\<mu>.leg0
                                     (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
                                   tuple_BC"
 
     abbreviation tuple_BC'
     where "tuple_BC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
 
     abbreviation tuple_ABC'
     where "tuple_ABC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
                                       \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
                                    tuple_BC'"
 
     lemma csq:
     shows "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
                                     SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
     and "Maps.commutative_square SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
                                  SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
     proof -
       show 1: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
                                        SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
       proof
         show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
           using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
         show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
           using SPN_fgh.prj_simps(2-3,5-6) by presburger
         show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
           using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
           by auto
         show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
           by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
               Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
               SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
       qed
       show "Maps.commutative_square
               SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
               SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
       proof
         show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
           using fg gh SPN_fgh.prj_simps(10) by blast
         show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
           using fg gh 1 Maps.tuple_simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(1)
                 SPN_fgh.prj_simps(4) SPN_fgh.prj_simps(5)
           by presburger
         show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
           using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
         show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 = (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
           using 1 fg gh Maps.comp_assoc Maps.prj_tuple
           by (metis (no_types, lifting) Maps.pullback_commutes' SPN_fgh.cospan_\<mu>\<nu>)
       qed
     qed
 
     lemma tuple_ABC_eq_ABC':
     shows "tuple_BC = tuple_BC'"
     and "tuple_ABC = tuple_ABC'"
     proof -
       have "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
         using prj_char by simp
       moreover have "SPN_fgh.\<mu>.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk>"
         by simp
       moreover have "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
         using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
               Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
         by (simp add: g.T0.antipar(2))
       moreover show "tuple_BC = tuple_BC'"
         using prj_char Tfg.\<rho>\<sigma>.prj_char by simp
       ultimately show "tuple_ABC = tuple_ABC'"
         by argo
     qed
 
     lemma tuple_BC_in_hom:
     shows "Maps.in_hom tuple_BC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0))"
     proof
       show 1: "Maps.arr tuple_BC"
         using csq(1) by simp
       have 2: "Maps.commutative_square
                  \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
         by (metis Tfg.S\<^sub>0_def Tfg.span_legs_eq(3) Tgh.S\<^sub>1_def Tgh.span_legs_eq(4) csq(1)
                   prj_char(2) prj_char(3))
       show "Maps.dom tuple_BC = Maps.MkIde (src TTfgh.p\<^sub>0)"
       proof -
         have "Maps.dom tuple_BC' = Maps.dom \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
           using 2 Maps.tuple_simps by simp
         also have "... = Chn (Span.hcomp (Span.hcomp (SPN f) (SPN g)) (SPN h))"
           using Maps.dom_char
           by (metis SPN_fgh.prj_simps(5) prj_char(2))
         also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
           using 1 fg gh Maps.dom_char csq(1) prj_char(3) tuple_ABC_eq_ABC'(1)
                 Maps.Dom.simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(3,5-6)
           by presburger
         finally have "Maps.dom tuple_BC' = Maps.MkIde (src TTfgh.p\<^sub>0)"
           by blast
         thus ?thesis
           using tuple_ABC_eq_ABC' by simp
       qed
       show "Maps.cod tuple_BC = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
       proof -
         have "Maps.cod tuple_BC' = Maps.pbdom \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>"
           using 1 2 fg gh Maps.tuple_in_hom by blast
         also have "... = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
           using 1 2 fg gh Maps.pbdom_def
           by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
               SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tfg.S\<^sub>0_def Tfg.span_legs_eq(3)
               Tgh.S\<^sub>1_def Tgh.chine_hcomp_SPN_SPN Tgh.span_legs_eq(4) g.is_ide)
         finally show ?thesis
           using tuple_ABC_eq_ABC' by simp
       qed
     qed
 
     lemma tuple_ABC_in_hom:
     shows "Maps.in_hom tuple_ABC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src TfTgh.p\<^sub>0))"
     proof
       show 1: "Maps.arr tuple_ABC"
         using SPN_fgh.chine_assoc_def SPN_fgh.chine_assoc_in_hom by auto
       show "Maps.dom tuple_ABC = Maps.MkIde (src TTfgh.p\<^sub>0)"
       proof -
         have "Maps.dom tuple_ABC = Maps.dom SPN_fgh.chine_assoc"
           by (simp add: SPN_fgh.chine_assoc_def)
         also have "... = Chn ((SPN f \<circ> SPN g) \<circ> SPN h)"
           using SPN_fgh.chine_assoc_in_hom by blast
         also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
           by (metis (lifting) Maps.Dom.simps(1) Maps.dom_char SPN_fgh.prj_simps(3)
               SPN_fgh.prj_simps(6) prj_char(3))
         finally show ?thesis by blast
       qed
       show "Maps.cod tuple_ABC = Maps.MkIde (src TfTgh.p\<^sub>0)"
       proof -
         have "Maps.cod tuple_ABC = Maps.cod SPN_fgh.chine_assoc"
           by (simp add: SPN_fgh.chine_assoc_def)
         also have 1: "... = Chn (SPN f \<circ> SPN g \<circ> SPN h)"
           using SPN_fgh.chine_assoc_in_hom by blast
         also have "... = Maps.MkIde (src TfTgh.p\<^sub>0)"
           by (metis (lifting) Maps.Dom.simps(1) Maps.cod_char Maps.seq_char
               SPN_fgh.prj_chine_assoc(1) SPN_fgh.prj_simps(1) TfTgh.leg1_in_hom(1)
               TfTgh_TfTgh.u_in_hom 1 in_hhomE prj_char(4) src_hcomp)
         finally show ?thesis by argo
       qed
     qed
 
     lemma Chn_RHS_eq:
     shows "Chn RHS = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
     proof -
       have "Chn RHS =
             Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
               Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
       proof -
         have "Chn RHS = Chn (\<Phi>.map (f, g \<star> h)) \<odot>
                           Chn ((SPN f \<circ> \<Phi>.map (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h))"
           using arr_RHS Span.vcomp_eq Span.Chn_vcomp by blast
         also have "... = Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
                            Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
         proof -
           have "Span.seq (SPN f \<circ> \<Phi>.map (g, h)) (Span.assoc (SPN f) (SPN g) (SPN h))"
             using arr_RHS by auto
           thus ?thesis
             using fg gh Span.vcomp_eq [of "SPN f \<circ> \<Phi>.map (g, h)"
                                           "Span.assoc (SPN f) (SPN g) (SPN h)"]
             by simp
         qed
         finally show ?thesis by blast
       qed
       moreover have "Chn (\<Phi>.map (f, g \<star> h)) = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk>"
         using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char VV.arr_char CMP_def TfHgh.cmp_def
         by simp
       moreover have "Chn (SPN f \<circ> \<Phi>.map (g, h)) = Span.chine_hcomp (SPN f) (CMP g h)"
         using fg gh Span.hcomp_def \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def
         by simp
       moreover have "Chn (Span.assoc (SPN f) (SPN g) (SPN h)) = tuple_ABC"
         using fg gh Span.\<alpha>_ide VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
               SPN_fgh.chine_assoc_def Span.\<alpha>_def
         by simp
       moreover have "Span.chine_hcomp (SPN f) (CMP g h) = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
       proof -
         have "Span.chine_hcomp (SPN f) (CMP g h) =
               Maps.tuple
                 (\<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>)
                    \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
                 (\<lbrakk>\<lbrakk>Tgh_Hgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
         proof -
           interpret f: span_in_category Maps.comp
                          \<open>\<lparr>Leg0 = 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
         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 auto
                     by (metis f.base_simps(2) f.satisfies_T0 f.u_in_hom src_hcomp)
                   show "Maps.arr (Leg1 (Dom ?W))"
                     using 1
                     apply (intro Maps.arrI)
                        apply auto
                   proof -
                     let ?f = "tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
                     assume 1: "\<guillemotleft>Maps.REP g.leg1 : Maps.Dom g.apex \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
                     have "\<guillemotleft>?f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
                                    \<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
                           is_left_adjoint ?f \<and> \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>?f\<rbrakk>"
                       using 1 by simp
                     thus "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
                                    \<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
                               is_left_adjoint f \<and>
                               \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>f\<rbrakk>"
                       by blast
                   qed
                   show "Maps.dom (Leg0 (Dom ?W)) = Maps.dom (Leg1 (Dom ?W))"
                   proof -
                     have "Maps.dom (Leg0 (Dom ?W)) =
                           Maps.MkIde (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))"
                       using Maps.dom_char
                       apply simp
                       by (metis (no_types, lifting) Maps.CLS_in_hom Maps.in_homE f.base_simps(2)
                           f.satisfies_T0 f.u_simps(3) hcomp_simps(1))
                     also have "... = Maps.dom (Leg1 (Dom ?W))"
                       using Maps.dom_char Maps.CLS_in_hom f.leg1_is_map f_in_hhom
                       apply simp
                       by (metis (no_types, lifting) Maps.in_homE Maps.REP_simps(3) f.base_simps(2)
                           f.leg1_is_map f.leg1_simps(3) f.leg1_simps(4) g.dom.leg_simps(3)
                           trg_hcomp)
                     finally show ?thesis by blast
                   qed
                 qed
                 show "Maps.span (Leg0 (Dom ?W)) (Leg1 (Dom ?W))"
                   using Dom_W.span_in_category_axioms Dom_W.is_span by blast
                 interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
                   apply unfold_locales by fastforce
                 show "Maps.span (Leg0 (Cod ?W)) (Leg1 (Cod ?W))"
                   by fastforce
                 show "Maps.in_hom (Chn ?W) Dom_W.apex Cod_W.apex"
                 proof
                   show 1: "Maps.arr (Chn ?W)"
                     using w\<theta>\<nu> Maps.CLS_in_hom [of w] equivalence_is_adjoint by auto
                   show "Maps.dom (Chn ?W) = Dom_W.apex"
                   proof -
                     have "Maps.dom (Chn ?W) = Maps.MkIde (src w)"
                       using 1 w\<theta>\<nu> Maps.dom_char by simp
                     also have "... = Dom_W.apex"
                     proof -
                       have "src w = src (tab\<^sub>0 ?f)"
                         using w\<theta>\<nu> by blast
                       thus ?thesis
                         using Dom_W.apex_def Maps.arr_char Maps.dom_char
                         apply simp
                         by (metis (no_types, lifting) f.base_simps(2) f.satisfies_T0
                             f.u_in_hom hcomp_simps(1))
                     qed
                     finally show ?thesis by fastforce
                   qed
                   show "Maps.cod (Chn ?W) = Cod_W.apex"
                   proof -
                     have "Maps.cod (Chn ?W) = Maps.MkIde (trg w)"
                       using 1 w\<theta>\<nu> Maps.cod_char by simp
                     also have "... = Cod_W.apex"
                     proof -
                       have "trg w = src (Maps.REP g.leg0)"
                         using w\<theta>\<nu> by blast
                       thus ?thesis
                         using Cod_W.apex_def Maps.arr_char Maps.cod_char
                         apply simp
                         using g.dom.apex_def Maps.dom_char Maps.REP_simps(2) g.dom.is_span
                         by presburger
                     qed
                     finally show ?thesis by fastforce
                   qed
                 qed
                 show "Cod_W.leg0 \<odot> Chn ?W = Dom_W.leg0"
                 proof -
                   have "Cod_W.leg0 \<odot> Chn ?W = g.leg0 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     by simp
                   also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
                     using g.dom.leg_simps(1) Maps.CLS_REP [of g.leg0]
                     by simp
                   also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0 \<star> w\<rbrakk>\<rbrakk>"
                   proof -
                     have "is_left_adjoint (Maps.REP g.leg0)"
                       by fast
                     moreover have "is_left_adjoint w"
                       using w\<theta>\<nu> equivalence_is_adjoint by simp
                     moreover have "Maps.REP g.leg0 \<star> w \<cong> Maps.REP g.leg0 \<star> w"
                       using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom
                       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/Coherence.thy b/thys/Bicategory/Coherence.thy
--- a/thys/Bicategory/Coherence.thy
+++ b/thys/Bicategory/Coherence.thy
@@ -1,3957 +1,3959 @@
 (*  Title:       Coherence
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Coherence"
 
 theory Coherence
 imports Bicategory
 begin
 
  text \<open>
    \sloppypar
    In this section, we generalize to bicategories the proof of the Coherence Theorem
    that we previously gave for monoidal categories
    (see \<open>MonoidalCategory.evaluation_map.coherence\<close> in @{session MonoidalCategory}).
    As was the case for the previous proof, the current proof takes a syntactic approach.
    First we define a formal ``bicategorical language'' of terms constructed using
    syntactic operators that correspond to the various operations (vertical and horizontal
    composition, associators and unitors) found in a bicategory.
    Terms of the language are classified as formal ``arrows'', ``identities'', or ``objects''
    according to the syntactic operators used in their formation.
    A class of terms called ``canonical'' is also defined in this way.
    Functions that map ``arrows'' to their ``domain'' and ``codomain'', and to their
    ``source'' and ``target'' are defined by recursion on the structure of terms.
    Next, we define a notion of ``normal form'' for terms in this language and we
    give a recursive definition of a function that maps terms to their normal forms.
    Normalization moves vertical composition inside of horizontal composition and
    ``flattens'' horizontal composition by associating all horizontal compositions to the right.
    In addition, normalization deletes from a term any horizontal composites involving an arrow
    and its source or target, replacing such composites by just the arrow itself.
    We then define a ``reduction function'' that maps each identity term \<open>t\<close> to a
    ``canonical'' term \<open>t\<^bold>\<down>\<close> that connects \<open>t\<close> with its normal form.  The definition of reduction
    is also recursive, but it is somewhat more complex than normalization in that it
    involves two mutually recursive functions: one that applies to any identity term
    and another that applies only to terms that are the horizontal composite
    of two identity terms.
 
    The next step is to define an ``evaluation function'' that evaluates terms in a given
    bicategory (which is left as an unspecified parameter).  We show that evaluation respects
    bicategorical structure:
    the domain, codomain, source, and target mappings on terms correspond under evaluation
    to the actual domain, codomain, source and target mappings on the given bicategory,
    the vertical and horizontal composition on terms correspond to the actual vertical
    and horizontal composition of the bicategory, and unit and associativity terms evaluate
    to the actual unit and associativity isomorphisms of the bicategory.
    In addition, ``object terms'' evaluate to objects (\emph{i.e.}~0-cells),
    ``identity terms'' evaluate to identities (\emph{i.e.}~1-cells),
    ``arrow terms'' evaluate to arrows (\emph{i.e.}~2-cells), and ``canonical terms'' evaluate
    to canonical isomorphisms.
    A term is defined to be ``coherent'' if, roughly speaking, it is a formal arrow
    whose evaluation commutes with the evaluations of the reductions to normal form of
    its domain and codomain.
    We then prove the Coherence Theorem, expressed in the form: ``every arrow is coherent.''
    This implies a more classical version of the Coherence Theorem, which says that:
    ``syntactically parallel arrows with the same normal form have equal evaluations''.
   \<close>
 
   subsection "Bicategorical Language"
 
     text \<open>
       For the most part, the definition of the ``bicategorical language'' of terms is
       a straightforward generalization of the ``monoidal language'' that we used for
       monoidal categories.
       Some modifications are required, however, due to the fact that horizontal composition
       in a bicategory is a partial operation, whereas the the tensor product in a monoidal
       category is well-defined for all pairs of arrows.
       One difference is that we have found it necessary to introduce a new class of primitive
       terms whose elements represent ``formal objects'', so that there is some way to
       identify the source and target of what would otherwise be an empty horizontal composite.
       This was not an issue for monoidal categories, because the totality of horizontal
       composition meant that there was no need for syntactically defined sources and targets.
       Another difference is what we have chosen for the ``generators'' of the language
       and how they are used to form primitive terms.  For monoidal categories,
       we supposed that we were given a category \<open>C\<close> and the syntax contained a constructor
       to form a primitive term corresponding to each arrow of \<open>C\<close>.
       We assumed a category as the given data, rather than something less structured,
       such as a graph, because we were primarily interested in the tensor product and
       the associators and unitors, and were relatively uninterested in the strictly
       associative and unital composition of the underlying category.
       For bicategories, we also take the vertical composition as given for the same
       reasons; however, this is not yet sufficient due to the fact that horizontal
       composition in a bicategory is a partial operation, in contrast to the tensor
       product in a monoidal category, which is defined for all pairs of arrows.
       To deal with this issue, for bicategories we assume that source and target
       mappings are also given, so that the given data forms a category with
       ``horizontal homs''.  The given source and target mappings are extended to all terms
       and used to define when two terms are ``formally horizontally composable''.
   \<close>
 
   locale bicategorical_language =
     category V +
     horizontal_homs V src trg
     for V :: "'a comp"                       (infixr "\<cdot>" 55)
     and src :: "'a \<Rightarrow> 'a"
     and trg :: "'a \<Rightarrow> 'a"
   begin
 
     text \<open>
       Constructor \<open>Prim\<^sub>0\<close> is used to construct ``formal objects'' and \<open>Prim\<close> is used to
       construct primitive terms that are not formal objects.
     \<close>
 
     datatype (discs_sels) 't "term" =
       Prim\<^sub>0 't                             ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sub>0")
     | Prim 't                              ("\<^bold>\<langle>_\<^bold>\<rangle>")
     | Hcomp "'t term" "'t term"            (infixr "\<^bold>\<star>" 53)
     | Vcomp "'t term" "'t term"            (infixr "\<^bold>\<cdot>" 55)
     | Lunit "'t term"                      ("\<^bold>\<l>\<^bold>[_\<^bold>]")
     | Lunit' "'t term"                     ("\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
     | Runit "'t term"                      ("\<^bold>\<r>\<^bold>[_\<^bold>]")
     | Runit' "'t term"                     ("\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
     | Assoc "'t term" "'t term" "'t term"  ("\<^bold>\<a>\<^bold>[_, _, _\<^bold>]")
     | Assoc' "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[_, _, _\<^bold>]")
 
     text \<open>
       We define formal domain, codomain, source, and target functions on terms.
     \<close>
 
     primrec Src :: "'a term \<Rightarrow> 'a term"
     where "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>src \<mu>\<^bold>\<rangle>\<^sub>0"
         | "Src (t \<^bold>\<star> u) = Src u"
         | "Src (t \<^bold>\<cdot> u) = Src t"
         | "Src \<^bold>\<l>\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<r>\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Src v"
         | "Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Src v"
 
     primrec Trg :: "'a term \<Rightarrow> 'a term"
     where "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>trg \<mu>\<^bold>\<rangle>\<^sub>0"
         | "Trg (t \<^bold>\<star> u) = Trg t"
         | "Trg (t \<^bold>\<cdot> u) = Trg t"
         | "Trg \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<r>\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Trg t"
         | "Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Trg t"
 
     primrec Dom :: "'a term \<Rightarrow> 'a term"
     where "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>dom \<mu>\<^bold>\<rangle>"
         | "Dom (t \<^bold>\<star> u) = Dom t \<^bold>\<star> Dom u"
         | "Dom (t \<^bold>\<cdot> u) = Dom u"
         | "Dom \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Dom t"
         | "Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
         | "Dom \<^bold>\<r>\<^bold>[t\<^bold>] = Dom t \<^bold>\<star> Src t"
         | "Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
         | "Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Dom t \<^bold>\<star> Dom u) \<^bold>\<star> Dom v"
         | "Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Dom t \<^bold>\<star> (Dom u \<^bold>\<star> Dom v)"
 
     primrec Cod :: "'a term \<Rightarrow> 'a term"
     where "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>"
         | "Cod (t \<^bold>\<star> u) = Cod t \<^bold>\<star> Cod u"
         | "Cod (t \<^bold>\<cdot> u) = Cod t"
         | "Cod \<^bold>\<l>\<^bold>[t\<^bold>] = Cod t"
         | "Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Cod t"
         | "Cod \<^bold>\<r>\<^bold>[t\<^bold>] = Cod t"
         | "Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Cod t \<^bold>\<star> Src t"
         | "Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Cod t \<^bold>\<star> (Cod u \<^bold>\<star> Cod v)"
         | "Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Cod t \<^bold>\<star> Cod u) \<^bold>\<star> Cod v"
 
     text \<open>
       A term is a ``formal arrow'' if it is constructed from primitive arrows in such a way
       that horizontal and vertical composition are applied only to formally composable pairs
       of terms.  The definitions of ``formal identity'' and ``formal object'' follow a
       similar pattern.
     \<close>
 
     primrec Arr :: "'a term \<Rightarrow> bool"
     where "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
         | "Arr (t \<^bold>\<star> u) = (Arr t \<and> Arr u \<and> Src t = Trg u)"
         | "Arr (t \<^bold>\<cdot> u) = (Arr t \<and> Arr u \<and> Dom t = Cod u)"
         | "Arr \<^bold>\<l>\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<r>\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
         | "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
 
     primrec Ide :: "'a term \<Rightarrow> bool"
     where "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
         | "Ide (t \<^bold>\<star> u) = (Ide t \<and> Ide u \<and> Src t = Trg u)"
         | "Ide (t \<^bold>\<cdot> u) = False"
         | "Ide \<^bold>\<l>\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<r>\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
         | "Ide \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
 
     primrec Obj :: "'a term \<Rightarrow> bool"
     where "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle> = False"
         | "Obj (t \<^bold>\<star> u) = False"
         | "Obj (t \<^bold>\<cdot> u) = False"
         | "Obj \<^bold>\<l>\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<r>\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
         | "Obj \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
 
     abbreviation HSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
     where "HSeq t u \<equiv> Arr t \<and> Arr u \<and> Src t = Trg u"
 
     abbreviation VSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
     where "VSeq t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Cod u"
 
     abbreviation HPar :: "'a term => 'a term \<Rightarrow> bool"
     where "HPar t u \<equiv> Arr t \<and> Arr u \<and> Src t = Src u \<and> Trg t = Trg u"
 
     abbreviation VPar :: "'a term => 'a term \<Rightarrow> bool"
     where "VPar t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Dom u \<and> Cod t = Cod u"
 
     abbreviation HHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
     where "HHom a b \<equiv> { t. Arr t \<and> Src t = a \<and> Trg t = b }"
 
     abbreviation VHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
     where "VHom f g \<equiv> { t. Arr t \<and> Dom t = f \<and> Cod t = g }"
 
     lemma is_Prim0_Src:
     shows "is_Prim\<^sub>0 (Src t)"
       by (induct t; simp)
 
     lemma is_Prim0_Trg:
     shows "is_Prim\<^sub>0 (Trg t)"
       by (induct t; simp)
 
     lemma Src_Src [simp]:
     shows "Arr t \<Longrightarrow> Src (Src t) = Src t"
       by (induct t) auto
 
     lemma Trg_Trg [simp]:
     shows "Arr t \<Longrightarrow> Trg (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Src_Trg [simp]:
     shows "Arr t \<Longrightarrow> Src (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Trg_Src [simp]:
     shows "Arr t \<Longrightarrow> Trg (Src t) = Src t"
       by (induct t) auto
 
     lemma Dom_Src [simp]:
     shows "Arr t \<Longrightarrow> Dom (Src t) = Src t"
       by (induct t) auto
 
     lemma Dom_Trg [simp]:
     shows "Arr t \<Longrightarrow> Dom (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Cod_Src [simp]:
     shows "Arr t \<Longrightarrow> Cod (Src t) = Src t"
       by (induct t) auto
 
     lemma Cod_Trg [simp]:
     shows "Arr t \<Longrightarrow> Cod (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Src_Dom_Cod:
     shows "Arr t \<Longrightarrow> Src (Dom t) = Src t \<and> Src (Cod t) = Src t"
        using src_dom src_cod by (induct t) auto
 
     lemma Src_Dom [simp]:
     shows "Arr t \<Longrightarrow> Src (Dom t) = Src t"
       using Src_Dom_Cod by blast
 
     lemma Src_Cod [simp]:
     shows "Arr t \<Longrightarrow> Src (Cod t) = Src t"
       using Src_Dom_Cod by blast
 
     lemma Trg_Dom_Cod:
     shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t \<and> Trg (Cod t) = Trg t"
        using trg_dom trg_cod by (induct t) auto
 
     lemma Trg_Dom [simp]:
     shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t"
       using Trg_Dom_Cod by blast
 
     lemma Trg_Cod [simp]:
     shows "Arr t \<Longrightarrow> Trg (Cod t) = Trg t"
       using Trg_Dom_Cod by blast
 
     lemma VSeq_implies_HPar:
     shows "VSeq t u \<Longrightarrow> HPar t u"
       using Src_Dom [of t] Src_Cod [of u] Trg_Dom [of t] Trg_Cod [of u] by auto
 
     lemma Dom_Dom [simp]:
     shows "Arr t \<Longrightarrow> Dom (Dom t) = Dom t"
       by (induct t, auto)
 
     lemma Cod_Cod [simp]:
     shows "Arr t \<Longrightarrow> Cod (Cod t) = Cod t"
       by (induct t, auto)
 
     lemma Dom_Cod [simp]:
     shows "Arr t \<Longrightarrow> Dom (Cod t) = Cod t"
       by (induct t, auto)
 
     lemma Cod_Dom [simp]:
     shows "Arr t \<Longrightarrow> Cod (Dom t) = Dom t"
       by (induct t, auto)
       
     lemma Obj_implies_Ide (*[simp]*):
     shows "Obj t \<Longrightarrow> Ide t"
       by (induct t) auto
 
     lemma Ide_implies_Arr [simp]:
     shows "Ide t \<Longrightarrow> Arr t"
       by (induct t, auto)
 
     lemma Dom_Ide:
     shows "Ide t \<Longrightarrow> Dom t = t"
       by (induct t, auto)
 
     lemma Cod_Ide:
     shows "Ide t \<Longrightarrow> Cod t = t"
       by (induct t, auto)
 
     lemma Obj_Src [simp]:
     shows "Arr t \<Longrightarrow> Obj (Src t)"
       by (induct t) auto
 
     lemma Obj_Trg [simp]:
     shows "Arr t \<Longrightarrow> Obj (Trg t)"
       by (induct t) auto
 
     lemma Ide_Dom [simp]:
     shows "Arr t \<Longrightarrow> Ide (Dom t)"
       using Obj_implies_Ide
       by (induct t, auto)
 
     lemma Ide_Cod [simp]:
     shows "Arr t \<Longrightarrow> Ide (Cod t)"
       using Obj_implies_Ide
       by (induct t, auto)
 
     lemma Arr_in_Hom:
     assumes "Arr t"
     shows "t \<in> HHom (Src t) (Trg t)" and "t \<in> VHom (Dom t) (Cod t)"
     proof -
       have 1: "Arr t \<Longrightarrow> t \<in> HHom (Src t) (Trg t) \<and> t \<in> VHom (Dom t) (Cod t)"
         by (induct t, auto)
       show "t \<in> HHom (Src t) (Trg t)" using assms 1 by simp
       show "t \<in> VHom (Dom t) (Cod t)" using assms 1 by simp
     qed
 
     lemma Ide_in_Hom:
     assumes "Ide t"
     shows "t \<in> HHom (Src t) (Trg t)" and "t \<in> VHom t t"
     proof -
       have 1: "Ide t \<Longrightarrow> t \<in> HHom (Src t) (Trg t) \<and> t \<in> VHom t t"
         by (induct t, auto)
       show "t \<in> HHom (Src t) (Trg t)" using assms 1 by simp
       show "t \<in> VHom t t" using assms 1 by simp
     qed
 
     lemma Obj_in_Hom:
     assumes "Obj t"
     shows "t \<in> HHom t t" and "t \<in> VHom t t"
     proof -
       have 1: "Obj t \<Longrightarrow> t \<in> HHom t t \<and> t \<in> VHom t t"
         by (induct t, auto)
       show "t \<in> HHom t t" using assms 1 by simp
       show "t \<in> VHom t t" using assms 1 by simp
     qed
 
     text \<open>
       A formal arrow is ``canonical'' if the only primitive arrows used in its construction
       are objects and identities.
     \<close>
 
     primrec Can :: "'a term \<Rightarrow> bool"
     where "Can \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Can \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
         | "Can (t \<^bold>\<star> u) = (Can t \<and> Can u \<and> Src t = Trg u)"
         | "Can (t \<^bold>\<cdot> u) = (Can t \<and> Can u \<and> Dom t = Cod u)"
         | "Can \<^bold>\<l>\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<r>\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v)"
         | "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v)"
 
     lemma Ide_implies_Can:
     shows "Ide t \<Longrightarrow> Can t"
       by (induct t, auto)
 
     lemma Can_implies_Arr:
     shows "Can t \<Longrightarrow> Arr t"
       by (induct t, auto)
 
     text \<open>
       Canonical arrows can be formally inverted.
     \<close>
 
     primrec Inv :: "'a term \<Rightarrow> 'a term"
     where "Inv \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Inv \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>inv \<mu>\<^bold>\<rangle>"
         | "Inv (t \<^bold>\<star> u) = (Inv t \<^bold>\<star> Inv u)"
         | "Inv (t \<^bold>\<cdot> u) = (Inv u \<^bold>\<cdot> Inv t)"
         | "Inv \<^bold>\<l>\<^bold>[t\<^bold>] = \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<l>\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<r>\<^bold>[t\<^bold>] = \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<r>\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
         | "Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
 
     lemma Src_Inv [simp]:
     shows "Can t \<Longrightarrow> Src (Inv t) = Src t"
       using Can_implies_Arr VSeq_implies_HPar
       apply (induct t, auto)
       by metis
 
     lemma Trg_Inv [simp]:
     shows "Can t \<Longrightarrow> Trg (Inv t) = Trg t"
       using Can_implies_Arr VSeq_implies_HPar 
       apply (induct t, auto)
       by metis
 
     lemma Dom_Inv [simp]:
     shows "Can t \<Longrightarrow> Dom (Inv t) = Cod t"
       by (induct t, auto)
 
     lemma Cod_Inv [simp]:
     shows "Can t \<Longrightarrow> Cod (Inv t) = Dom t"
       by (induct t, auto)
 
     lemma Inv_preserves_Ide:
     shows "Ide t \<Longrightarrow> Ide (Inv t)"
       using Ide_implies_Can by (induct t, auto)
 
     lemma Can_Inv [simp]:
     shows "Can t \<Longrightarrow> Can (Inv t)"
       by (induct t, auto)
 
     lemma Inv_in_Hom [intro]:
     assumes "Can t"
     shows "Inv t \<in> HHom (Src t) (Trg t)" and "Inv t \<in> VHom (Cod t) (Dom t)"
       using assms Can_Inv Can_implies_Arr by simp_all
 
     lemma Inv_Ide [simp]:
     assumes "Ide a"
     shows "Inv a = a"
       using assms by (induct a, auto)
 
     lemma Inv_Inv [simp]:
     assumes "Can t"
     shows "Inv (Inv t) = t"
       using assms by (induct t, auto)
 
     subsection "Normal Terms"
 
     text \<open>
       We call a term ``normal'' if it is either a formal object or it is constructed from
       primitive arrows using only horizontal composition associated to the right.
       Essentially, such terms are (typed) composable sequences of arrows of @{term V},
       where the empty list is represented by a formal object and \<open>\<^bold>\<star>\<close> is used as
       the list constructor.
     \<close>
 
     fun Nml :: "'a term \<Rightarrow> bool"
     where "Nml \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Nml \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
         | "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> u) = (arr \<nu> \<and> Nml u \<and> \<not> is_Prim\<^sub>0 u \<and> \<^bold>\<langle>src \<nu>\<^bold>\<rangle>\<^sub>0 = Trg u)"
         | "Nml _ = False"
 
     lemma Nml_HcompD:
     assumes "Nml (t \<^bold>\<star> u)"
     shows "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" and "arr (un_Prim t)" and "Nml t" and "Nml u"
     and "\<not> is_Prim\<^sub>0 u" and "\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u" and "Src t = Trg u"
     proof -
       have 1: "t = \<^bold>\<langle>un_Prim t\<^bold>\<rangle> \<and> arr (un_Prim t) \<and> Nml t \<and> Nml u \<and> \<not> is_Prim\<^sub>0 u \<and>
                \<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u"
         using assms by (cases t; simp; cases u; simp)
       show "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" using 1 by simp
       show "arr (un_Prim t)" using 1 by simp
       show "Nml t" using 1 by simp
       show "Nml u" using 1 by simp
       show "\<not> is_Prim\<^sub>0 u" using 1 by simp
       show "\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u" using 1 by simp
       show "Src t = Trg u"
         using assms
         apply (cases t) by simp_all
     qed
 
     lemma Nml_implies_Arr:
     shows "Nml t \<Longrightarrow> Arr t"
       by (induct t, auto simp add: Nml_HcompD)
 
     lemma Nml_Src [simp]:
     shows "Nml t \<Longrightarrow> Nml (Src t)"
       apply (induct t, simp_all)
       using Nml_HcompD by metis
 
     lemma Nml_Trg [simp]:
     shows "Nml t \<Longrightarrow> Nml (Trg t)"
       apply (induct t, simp_all)
       using Nml_HcompD by metis
 
     lemma Nml_Dom [simp]:
     shows "Nml t \<Longrightarrow> Nml (Dom t)"
     proof (induct t, simp_all add: Nml_HcompD)
       fix u v
       assume I1: "Nml (Dom u)"
       assume I2: "Nml (Dom v)"
       assume uv: "Nml (u \<^bold>\<star> v)"
       show "Nml (Dom u \<^bold>\<star> Dom v)"
       proof -
         have 1: "is_Prim (Dom u) \<and> arr (un_Prim (Dom u)) \<and> Dom u = \<^bold>\<langle>dom (un_Prim u)\<^bold>\<rangle>"
           using uv by (cases u; simp; cases v, simp_all)
         have 2: "Nml v \<and> \<not> is_Prim\<^sub>0 v \<and> \<not> is_Vcomp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
           using uv by (cases u, simp_all; cases v, simp_all)
         have "arr (dom (un_Prim u))"
           using 1 by fastforce
         moreover have "Nml (Dom v) \<and> \<not> is_Prim\<^sub>0 v"
           using 2 I2 by (cases v, simp_all)
         moreover have "\<^bold>\<langle>src (dom (un_Prim u))\<^bold>\<rangle>\<^sub>0 = Trg (Dom v)"
         proof -
           have "Trg (Dom v) = Src (Dom u)"
             using uv Nml_implies_Arr by fastforce
           also have "... = \<^bold>\<langle>src (dom (un_Prim u))\<^bold>\<rangle>\<^sub>0"
             using 1 by fastforce
           finally show ?thesis by argo
         qed
         moreover have "\<not> is_Prim\<^sub>0 (Dom v)"
           using 2 by (cases v, simp_all)
         ultimately show ?thesis using 1 2 by simp
       qed
     qed
     
     lemma Nml_Cod [simp]:
     shows "Nml t \<Longrightarrow> Nml (Cod t)"
     proof (induct t, simp_all add: Nml_HcompD)
       fix u v
       assume I1: "Nml (Cod u)"
       assume I2: "Nml (Cod v)"
       assume uv: "Nml (u \<^bold>\<star> v)"
       show "Nml (Cod u \<^bold>\<star> Cod v)"
       proof -
         have 1: "is_Prim (Cod u) \<and> arr (un_Prim (Cod u)) \<and> Cod u = \<^bold>\<langle>cod (un_Prim u)\<^bold>\<rangle>"
           using uv by (cases u; simp; cases v, simp_all)
         have 2: "Nml v \<and> \<not> is_Prim\<^sub>0 v \<and> \<not> is_Vcomp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
           using uv by (cases u; simp; cases v, simp_all)
         have "arr (cod (un_Prim u))"
           using 1 by fastforce
         moreover have "Nml (Cod v) \<and> \<not> is_Prim\<^sub>0 v"
           using 2 I2 by (cases v, simp_all)
         moreover have "\<^bold>\<langle>src (cod (un_Prim u))\<^bold>\<rangle>\<^sub>0 = Trg (Cod v)"
         proof -
           have "Trg (Cod v) = Src (Cod u)"
             using uv Nml_implies_Arr by fastforce
           also have "... = \<^bold>\<langle>src (cod (un_Prim u))\<^bold>\<rangle>\<^sub>0"
             using 1 by fastforce
           finally show ?thesis by argo
         qed
         moreover have "\<not> is_Prim\<^sub>0 (Cod v)"
           using 2 by (cases v; simp)
         ultimately show ?thesis using 1 2 by simp
       qed
     qed
     
     lemma Nml_Inv [simp]:
     assumes "Can t" and "Nml t"
     shows "Nml (Inv t)"
     proof -
       have "Can t \<and> Nml t \<Longrightarrow> Nml (Inv t)"
         apply (induct t, simp_all)
       proof -
         fix u v
         assume I1: "Nml u \<Longrightarrow> Nml (Inv u)"
         assume I2: "Nml v \<Longrightarrow> Nml (Inv v)"
         assume uv: "Can u \<and> Can v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
         show "Nml (Inv u \<^bold>\<star> Inv v)"
         proof -
           have u: "Arr u \<and> Can u" using uv Can_implies_Arr by blast
           have v: "Arr v \<and> Can v" using uv Can_implies_Arr by blast
           have 1: "\<^bold>\<langle>un_Prim u\<^bold>\<rangle> = u \<and> ide (un_Prim u) \<and> Nml u \<and> Nml v \<and> \<not> is_Prim\<^sub>0 v \<and>
                    \<^bold>\<langle>src (un_Prim u)\<^bold>\<rangle>\<^sub>0 = Trg v"
             using uv Nml_HcompD [of u v] apply simp
             using uv by (cases u, simp_all)
           have 2: "\<^bold>\<langle>un_Prim (Inv u)\<^bold>\<rangle> = Inv u \<and> arr (un_Prim (Inv u)) \<and> Nml (Inv u)"
             using 1 by (cases u; simp)
           moreover have "Nml (Inv v) \<and> \<not> is_Prim\<^sub>0 (Inv v)"
             using 1 I2 by (cases v, simp_all)
           moreover have "\<^bold>\<langle>src (un_Prim (Inv u))\<^bold>\<rangle>\<^sub>0 = Trg (Inv v)"
             using 1 2 v by (cases u, simp_all)
           ultimately show ?thesis
             by (cases u, simp_all)
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text \<open>
       The following function defines a horizontal composition for normal terms.
       If such terms are regarded as lists, this is just (typed) list concatenation.
     \<close>
 
     fun HcompNml  (infixr "\<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor>" 53)
     where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
         | "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
         | "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> u"
         | "(t \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
         | "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = undefined"
 
     lemma HcompNml_Prim [simp]:
     assumes "\<not> is_Prim\<^sub>0 t"
     shows "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = \<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> t"
       using assms by (cases t, simp_all)
 
     lemma HcompNml_term_Prim\<^sub>0 [simp]:
     assumes "Src t = Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
       using assms by (cases t, simp_all)
 
     lemma HcompNml_Nml:
     assumes "Nml (t \<^bold>\<star> u)"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t \<^bold>\<star> u"
       using assms HcompNml_Prim by (metis Nml_HcompD(1) Nml_HcompD(5))
 
     lemma Nml_HcompNml:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
     and "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u"
     and "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u"
     and "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u"
     and "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
     proof -
       have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow>
                      Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
                                       Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
                                       Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
       proof (induct t, simp_all add: Nml_HcompD(1-4))
         fix \<nu> :: 'a and u :: "'a term"
         assume \<nu>: "arr \<nu>"
         assume u: "Nml u"
         assume 1: "\<^bold>\<langle>src \<nu>\<^bold>\<rangle>\<^sub>0 = Trg u"
         show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>dom \<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
                                  Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
                                  Src (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>trg \<nu>\<^bold>\<rangle>\<^sub>0"
           using u \<nu> 1 by (cases u, simp_all)
         next
         fix u v w
         assume I1: "\<And>x. Nml x \<Longrightarrow> Src v = Trg x \<Longrightarrow>
                          Nml (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) \<and> Dom (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom x \<and>
                                           Cod (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod x \<and>
                                           Src (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Src x \<and> Trg (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Trg v"
         assume I2: "\<And>x. Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
                          Nml (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom x \<and>
                                           Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod x \<and>
                                           Src (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Src x \<and> Trg (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Trg w"
         assume vw: "Nml (v \<^bold>\<star> w)"
         assume u: "Nml u"
         assume wu: "Src w = Trg u"
         show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
               Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Dom v \<^bold>\<star> Dom w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
               Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Cod v \<^bold>\<star> Cod w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
               Src ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg v"
         proof -
           have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> Nml v"
             using vw Nml_implies_Arr Nml_HcompD by metis
           have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
             using vw by (simp add: Nml_HcompD)
           have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis" by (cases u; simp add: vw wu)
           moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
           proof -
             assume 1: "\<not> is_Prim\<^sub>0 u"
             have "Src v = Trg (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u v w I2 [of u] by (cases v, simp_all)
             hence "Nml (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
                    Dom (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
                    Cod (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
                    Src (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg v"
               using u v w I1 [of "w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u"] I2 [of u] by argo
             moreover have "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = (v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u"
               using 1 by (cases u, simp_all)
             moreover have "(Dom v \<^bold>\<star> Dom w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using v w u vw 1 I2 Nml_Dom HcompNml_Prim Nml_HcompD(1) Nml_HcompD(5)
               by (cases u, simp_all)
             moreover have "(Cod v \<^bold>\<star> Cod w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using v w u vw 1 I2 Nml_HcompD(1) Nml_HcompD(5) HcompNml_Prim
               by (cases u, simp_all)
             ultimately show ?thesis
               by argo
           qed
           ultimately show ?thesis by blast
         qed
         next
         fix a u
         assume a: "obj a"
         assume u: "Nml u"
         assume au: "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = Trg u"
         show "Nml (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
               Dom (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
               Cod (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
               Src (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg (Trg u)"
           using au
           by (metis Cod.simps(1) Dom.simps(1) HcompNml.simps(1) Trg.simps(1) u)
       qed
       show "Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) " using assms 0 by blast
       show "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u" using assms 0 by blast
       show "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u" using assms 0 by blast
       show "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u" using assms 0 by blast
       show "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t" using assms 0 by blast
     qed
 
     lemma HcompNml_in_Hom [intro]:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg t)"
     and "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<in> VHom (Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u) (Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)"
       using assms Nml_HcompNml Nml_implies_Arr by auto
 
     lemma Src_HcompNml:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u"
       using assms Nml_HcompNml(4) by simp
 
     lemma Trg_HcompNml:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
       using assms Nml_HcompNml(5) by simp
 
     lemma Dom_HcompNml:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u"
       using assms Nml_HcompNml(2) by simp
 
     lemma Cod_HcompNml:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u"
       using assms Nml_HcompNml(3) by simp
 
     lemma is_Hcomp_HcompNml:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     and "\<not> is_Prim\<^sub>0 t" and "\<not> is_Prim\<^sub>0 u"
     shows "is_Hcomp (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
     proof -
       have "\<lbrakk> \<not> is_Hcomp (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u); Nml t; Nml u; Src t = Trg u; \<not> is_Prim\<^sub>0 t; \<not> is_Prim\<^sub>0 u \<rbrakk>
                 \<Longrightarrow> False"
       proof (induct t, simp_all add: Nml_HcompD)
         fix a
         assume a: "obj a"
         assume u: "Nml u"
         assume 1: "\<not> is_Hcomp u"
         assume 2: "\<not> is_Prim\<^sub>0 (Trg u)"
         show "False"
           using u 1 2 by (cases u; simp)
         next
         fix v w
         assume I2: "\<not> is_Hcomp (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<Longrightarrow> False"
         assume vw: "Nml (v \<^bold>\<star> w)"
         assume u: "Nml u"
         assume 1: "\<not> is_Hcomp ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
         assume 2: "\<not> is_Prim\<^sub>0 u"
         assume 3: "Src w = Trg u"
         show "False"
         proof -
           have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle>"
-            using vw Nml_HcompD by force
+            using vw Nml_HcompD by metis
           have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
             using vw Nml_HcompD [of v w] by blast
           have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
           proof -
             have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u v 2 by (cases u, simp_all)
             also have "... = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u w I2 by fastforce
             also have "... = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using v by simp
             finally show ?thesis by simp
           qed
           thus ?thesis using 1 by simp
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text \<open>
       The following function defines the ``dimension'' of a term,
       which is the number of inputs (or outputs) when the term is regarded as an
       interconnection matrix.
       For normal terms, this is just the length of the term when regarded as a list
       of arrows of @{term C}.
       This function is used as a ranking of terms in the subsequent associativity proof.
     \<close>
 
     primrec dim :: "'a term \<Rightarrow> nat"
     where "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = 0"
         | "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle> = 1"
         | "dim (t \<^bold>\<star> u) = (dim t + dim u)"
         | "dim (t \<^bold>\<cdot> u) = dim t"
         | "dim \<^bold>\<l>\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<r>\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
         | "dim \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
 
     lemma HcompNml_assoc:
     assumes "Nml t" and "Nml u" and "Nml v" and "Src t = Trg u" and "Src u = Trg v"
     shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
     proof -
       have "\<And>n t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
                         (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
       proof -
         fix n
         show "\<And>t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
                         (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
         proof (induction n rule: nat_less_induct)
           fix n :: nat and t :: "'a term" and u v
           assume I: "\<forall>m<n. \<forall>t u v. dim t = m \<longrightarrow> Nml t \<longrightarrow> Nml u \<longrightarrow> Nml v \<longrightarrow>
                                    Src t = Trg u \<longrightarrow> Src u = Trg v \<longrightarrow>
                                    (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
           assume dim: "dim t = n"
           assume t: "Nml t"
           assume u: "Nml u"
           assume v: "Nml v"
           assume tu: "Src t = Trg u"
           assume uv: "Src u = Trg v"
           show "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
           proof -
             have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis" by (cases t; simp)
             moreover have "\<not>is_Prim\<^sub>0 t \<Longrightarrow> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
               by (cases t; simp; cases u; simp)
             moreover have "\<not> is_Prim\<^sub>0 t \<Longrightarrow> \<not> is_Prim\<^sub>0 u \<Longrightarrow> is_Prim\<^sub>0 v \<Longrightarrow> ?thesis"
             proof -
               assume 1: "\<not> is_Prim\<^sub>0 t"
               assume 2: "\<not> is_Prim\<^sub>0 u"
               assume 3: "is_Prim\<^sub>0 v"
               have "\<not>is_Prim\<^sub>0 (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
                 using 1 2 t u tu is_Hcomp_HcompNml [of t u]
                 by (cases t, simp, cases u, auto)
               thus ?thesis
                 using 1 2 3 tu uv by (cases v, simp, cases "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u", simp_all)
             qed
             moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Prim t \<Longrightarrow> ?thesis"
               using v by (cases t, simp_all, cases u, simp_all; cases v, simp_all)
             moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Hcomp t \<Longrightarrow> ?thesis"
             proof (cases t, simp_all)
               fix w :: "'a term" and x :: "'a term"
               assume 1: " \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v"
               assume 2: "t = (w \<^bold>\<star> x)"
               show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
               proof -
                 have w: "w = \<^bold>\<langle>un_Prim w\<^bold>\<rangle>"
-                  using t 1 2 Nml_HcompD by auto
+                  using t 1 2 Nml_HcompD by metis
                 have x: "Nml x"
                   using t w 1 2 by (metis Nml.simps(3))
                 have "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
                   using u v w x 1 2 by (cases u, simp_all)
                 also have "... = (w \<^bold>\<star> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
                   using t w u 1 2 HcompNml_Prim is_Hcomp_HcompNml Nml_HcompD
                   by (metis Src.simps(3) term.distinct_disc(3) tu)
                 also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
                   using u v w x 1 by (cases u, simp_all; cases v, simp_all)
                 also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v))"
                 proof -
                   have "dim x < dim t"
                     using 2 w by (cases w; simp)
                   moreover have "Src x = Trg u \<and> Src u = Trg v"
                     using tu uv 2 by auto
                   ultimately show ?thesis 
                     using u v x dim I by simp
                 qed
                 also have "... = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
                 proof -
                   have 3: "is_Hcomp (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
                     using u v uv 1 is_Hcomp_HcompNml by auto
                   obtain u' :: "'a term" and v' where uv': "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = u' \<^bold>\<star> v'"
                     using 3 is_Hcomp_def by blast
                   thus ?thesis by simp
                 qed
                 finally show ?thesis by simp
               qed
             qed
             moreover have "is_Prim\<^sub>0 t \<or> is_Prim t \<or> is_Hcomp t"
               using t by (cases t, simp_all)
             ultimately show ?thesis by blast
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma HcompNml_Trg_Nml:
     assumes "Nml t"
     shows "Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
     proof -
       have "Nml t \<Longrightarrow> Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
       proof (induct t, simp_all add: Nml_HcompD)
         fix u v
         assume uv: "Nml (u \<^bold>\<star> v)"
         assume I1: "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
         have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
           using uv Nml_HcompD by blast
         have 2: "Trg (u \<^bold>\<star> v) = Trg u"
           using uv by auto
         show "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = u \<^bold>\<star> v"
         proof -
           have "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
             using uv HcompNml_Nml by simp
           also have "... = (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
             using 1 2 HcompNml_assoc Src_Trg Nml_Trg Nml_implies_Arr by simp
           also have "... = u \<^bold>\<star> v"
             using I1 uv HcompNml_Nml by simp
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis using assms by simp
     qed
 
     lemma HcompNml_Nml_Src:
     assumes "Nml t"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
     proof -
       have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
       proof (induct t, simp_all add: Nml_HcompD)
         fix u v
         assume uv: "Nml (u \<^bold>\<star> v)"
         assume I2: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = v"
         have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
           using uv Nml_HcompD by blast
         have 2: "Src (u \<^bold>\<star> v) = Src v"
           using uv Trg_HcompNml by auto
         show "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = u \<^bold>\<star> v"
         proof -
           have "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v"
             using uv HcompNml_Nml by simp
           also have "... = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v)"
             using 1 2 HcompNml_assoc Trg_Src Nml_Src Nml_implies_Arr by simp
           also have "... = u \<^bold>\<star> v"
             using I2 uv HcompNml_Nml by simp
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis using assms by simp
     qed
 
     lemma HcompNml_Obj_Nml:
     assumes "Obj t" and "Nml u" and "Src t = Trg u"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
       using assms by (cases t, simp_all add: HcompNml_Trg_Nml)
 
     lemma HcompNml_Nml_Obj:
     assumes "Nml t" and "Obj u" and "Src t = Trg u"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t"
       using assms by (cases u, simp_all)
 
     lemma Ide_HcompNml:
     assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Ide (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
       using assms
       by (metis (mono_tags, lifting) Nml_HcompNml(1) Nml_implies_Arr Dom_HcompNml
           Ide_Dom Ide_in_Hom(2) mem_Collect_eq)
 
     lemma Can_HcompNml:
     assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
       proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
         show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow> Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
           by (metis Ide.simps(1-2) Ide_implies_Can Can.simps(3) Nml.elims(2)
               Nml.simps(2) HcompNml.simps(12) HcompNml_Prim Ide_HcompNml
               Src.simps(2) term.disc(2))
         show "\<And>v w u.
                  (\<And>u. Nml v \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> Trg w = Trg u \<Longrightarrow> Can (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<Longrightarrow>
                  (\<And>ua. Nml w \<Longrightarrow> Can ua \<and> Nml ua \<Longrightarrow> Trg u = Trg ua \<Longrightarrow> Can (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ua)) \<Longrightarrow>
                  Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w) \<Longrightarrow>
                  Can u \<and> Nml u \<Longrightarrow> Src w = Trg u \<Longrightarrow> Can ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
           by (metis Nml_HcompD(3-4) HcompNml_Nml Nml_HcompNml(1)
               HcompNml_assoc Trg_HcompNml)
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Inv_HcompNml:
     assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk>
                    \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
       proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
         show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg u \<rbrakk> \<Longrightarrow> Inv u = Inv (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
           by (metis HcompNml.simps(1) Inv.simps(1))
         show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow>  
                     Inv (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
           by (metis Ide.simps(2) HcompNml.simps(2) HcompNml_Prim Inv.simps(1,3)
                     Inv_Ide Inv_Inv is_Prim\<^sub>0_def)
         fix v w u
         assume I1: "\<And>x. Nml v \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg w = Trg x \<Longrightarrow>
                         Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
         assume I2: "\<And>x. Nml w \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
                               Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
         assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
         assume wu: "Src w = Trg u"
         assume u: "Can u \<and> Nml u"
         have v: "Can v \<and> Nml v"
           using vw Nml_HcompD by blast
         have w: "Can w \<and> Nml w"
           using v vw by (cases v, simp_all)
         show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
         proof -
           have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
             apply (cases u) by simp_all
           moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
           proof -
             assume 1: "\<not> is_Prim\<^sub>0 u"
             have "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u))"
               using 1 by (cases u, simp_all)
             also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u v w vw wu I1 Nml_HcompNml Can_HcompNml Nml_Inv Can_Inv
               by simp
             also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u)"
               using u v w I2 Nml_HcompNml by simp
             also have "... = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
               using v 1 by (cases u, simp_all)
             finally show ?thesis by blast
           qed
           ultimately show ?thesis by blast
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text \<open>
        The following function defines vertical composition for compatible normal terms,
        by ``pushing the composition down'' to arrows of @{text V}.
     \<close>
 
     fun VcompNml :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term"  (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
     where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = u"
         | "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>\<nu> \<cdot> \<mu>\<^bold>\<rangle>"
         | "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (w \<^bold>\<star> x) = (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<^bold>\<star> v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
         | "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
         | "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> _ = undefined \<^bold>\<cdot> undefined"
 
     text \<open>
       Note that the last clause above is not relevant to normal terms.
       We have chosen a provably non-normal value in order to validate associativity.
     \<close>
 
     lemma Nml_VcompNml:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     and "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
     and "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
     proof -
       have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
                      Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
       proof (induct t, simp_all add: Nml_HcompD)
         show "\<And>x u. obj x \<Longrightarrow> Nml u \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow>
                      Nml (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
                      Cod (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod (Cod u)"
           by (metis Cod.simps(1) VcompNml.simps(1))
         fix \<nu> u
         assume \<nu>: "arr \<nu>"
         assume u: "Nml u"
         assume 1: "\<^bold>\<langle>dom \<nu>\<^bold>\<rangle> = Cod u"
         show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle>"
           using \<nu> u 1 by (cases u, simp_all)
         next
         fix u v w
         assume I2: "\<And>u. \<lbrakk> Nml u; Dom w = Cod u \<rbrakk> \<Longrightarrow>
                           Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod w"
         assume vw: "Nml (v \<^bold>\<star> w)"
         have v: "Nml v"
-          using vw Nml_HcompD by force
+          using vw Nml_HcompD by blast
         have w: "Nml w"
-          using vw Nml_HcompD by force
+          using vw Nml_HcompD by blast
         assume u: "Nml u"
         assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
         show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
                                      Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod v \<^bold>\<star> Cod w"
           using u v w 1
         proof (cases u, simp_all)
           fix x y
           assume 2: "u = x \<^bold>\<star> y"
           have 4: "is_Prim x \<and> x = \<^bold>\<langle>un_Prim x\<^bold>\<rangle> \<and> arr (un_Prim x) \<and> Nml y \<and> \<not> is_Prim\<^sub>0 y"
             using u 2 by (cases x, cases y, simp_all)
           have 5: "is_Prim v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v) \<and> Nml w \<and> \<not> is_Prim\<^sub>0 w"
             using v w vw by (cases v, simp_all)
           have 6: "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
           proof -
             have "\<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w" using vw Nml_HcompD [of v w] by simp
             thus "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
               using 1 2 4 5 apply (cases u, simp_all)
               by (metis Cod.simps(2) Dom.simps(2) term.simps(2))
           qed
           have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y"
             using 2 4 5 6 VcompNml.simps(2) [of "un_Prim v" "un_Prim x"] by simp
           moreover have "Nml (\<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
           proof -
             have "Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using I2 4 5 6 by simp
             moreover have "\<not> is_Prim\<^sub>0 (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using vw 4 5 6 I2 Nml_Cod Nml_HcompD(5) is_Prim\<^sub>0_def
               by (metis Cod.simps(1) Cod.simps(3))
             moreover have "\<^bold>\<langle>src (un_Prim v \<cdot> un_Prim x)\<^bold>\<rangle>\<^sub>0 = Trg (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using vw 4 5 6 I2 Nml_HcompD(6) Nml_implies_Arr
                     src.as_nat_trans.is_natural_1 src.as_nat_trans.preserves_comp_2
                     Trg_Cod src_cod
               by (metis seqI)
             ultimately show ?thesis
               using 4 5 6 Nml.simps(3) [of "un_Prim v \<cdot> un_Prim x" "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"]
               by simp
           qed
           ultimately show "Nml (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) \<and>
                            Dom (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Dom x \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Dom y \<and>
                            Cod (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Cod v \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Cod w"
             using 4 5 6 I2
             by (metis (no_types, lifting) Cod.simps(2) Dom.simps(2) VcompNml.simps(2)
                 cod_comp dom_comp seqI)
         qed
       qed
       show "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)" using assms 0 by blast
       show "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u" using assms 0 by blast
       show "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t" using assms 0 by blast
     qed
 
     lemma VcompNml_in_Hom [intro]:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg u)" and "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> VHom (Dom u) (Cod t)"
     proof -
       show 1: "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> VHom (Dom u) (Cod t)"
         using assms Nml_VcompNml Nml_implies_Arr by simp
       show "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg u)"
         using assms 1 Src_Dom Trg_Dom Nml_implies_Arr by fastforce
     qed
 
     lemma Src_VcompNml:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Src (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Src u"
       using assms VcompNml_in_Hom by simp
 
     lemma Trg_VcompNml:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Trg (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Trg u"
       using assms VcompNml_in_Hom by simp
 
     lemma Dom_VcompNml:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
       using assms Nml_VcompNml(2) by simp
 
     lemma Cod_VcompNml:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
       using assms Nml_VcompNml(3) by simp
 
     lemma VcompNml_Cod_Nml [simp]:
     assumes "Nml t"
     shows "VcompNml (Cod t) t = t"
     proof -
       have "Nml t \<Longrightarrow> Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
         apply (induct t)
         by (auto simp add: Nml_HcompD comp_cod_arr)
       thus ?thesis using assms by blast
     qed
 
     lemma VcompNml_Nml_Dom [simp]:
     assumes "Nml t"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Dom t) = t"
     proof -
       have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
         apply (induct t) by (auto simp add: Nml_HcompD comp_arr_dom)
       thus ?thesis using assms by blast
     qed
 
     lemma VcompNml_Ide_Nml [simp]:
     assumes "Nml t" and "Ide a" and "Dom a = Cod t"
     shows "a \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
       using assms Ide_in_Hom by simp
 
     lemma VcompNml_Nml_Ide [simp]:
     assumes "Nml t" and "Ide a" and "Dom t = Cod a"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> a = t"
       using assms Ide_in_Hom by auto
 
     lemma VcompNml_assoc:
     assumes "Nml t" and "Nml u" and "Nml v"
     and "Dom t = Cod u" and "Dom u = Cod v"
     shows "(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
     proof -
       have "\<And>u v. \<lbrakk> Nml t; Nml u; Nml v; Dom t = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                     (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
       proof (induct t, simp_all)
         show "\<And>x u v. obj x \<Longrightarrow> Nml u \<Longrightarrow> Nml v \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow> Dom u = Cod v \<Longrightarrow>
                        u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
           by (metis VcompNml.simps(1))
         fix f u v
         assume f: "arr f"
         assume u: "Nml u"
         assume v: "Nml v"
         assume 1: "\<^bold>\<langle>dom f\<^bold>\<rangle> = Cod u"
         assume 2: "Dom u = Cod v"
         show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
           using u v f 1 2 comp_assoc
           apply (cases u)
                    apply simp_all
           apply (cases v)
           by simp_all
         next
         fix u v w x
         assume I1: "\<And>u v. \<lbrakk> Nml w; Nml u; Nml v; Dom w = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                             (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume I2: "\<And>u v. \<lbrakk> Nml x; Nml u; Nml v; Dom x = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                             (x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume wx: "Nml (w \<^bold>\<star> x)"
         assume u: "Nml u"
         assume v: "Nml v"
         assume 1: "(Dom w \<^bold>\<star> Dom x) = Cod u"
         assume 2: "Dom u = Cod v"
         show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
         proof -
           have w: "Nml w"
             using wx Nml_HcompD by blast
           have x: "Nml x"
             using wx Nml_HcompD by blast
           have "is_Hcomp u"
             using u 1 by (cases u) simp_all
           thus ?thesis
             using u v apply (cases u, simp_all, cases v, simp_all)
           proof -
             fix u1 u2 v1 v2
             assume 3: "u = (u1 \<^bold>\<star> u2)"
             assume 4: "v = (v1 \<^bold>\<star> v2)"
             show "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<and>
                   (x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2 = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2"
             proof -
               have "Nml u1 \<and> Nml u2"
                 using u 3 Nml_HcompD by blast
               moreover have "Nml v1 \<and> Nml v2"
                 using v 4 Nml_HcompD by blast
               ultimately show ?thesis using w x I1 I2 1 2 3 4 by simp
             qed
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Ide_VcompNml:
     assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Ide (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Ide t; Ide u; Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Ide (VcompNml t u)"
         by (induct t, simp_all)
       thus ?thesis using assms by blast
     qed
 
     lemma Can_VcompNml:
     assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
       proof (induct t, simp_all)
         fix t u v
         assume I1: "\<And>v. \<lbrakk> Nml t; Can v \<and> Nml v; Dom t = Cod v \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume I2: "\<And>v. \<lbrakk> Nml u; Can v \<and> Nml v; Dom u = Cod v \<rbrakk> \<Longrightarrow> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume tu: "Can t \<and> Can u \<and> Src t = Trg u \<and> Nml (t \<^bold>\<star> u)"
         have t: "Can t \<and> Nml t"
           using tu Nml_HcompD by blast
         have u: "Can u \<and> Nml u"
           using tu Nml_HcompD by blast
         assume v: "Can v \<and> Nml v"
         assume 1: "(Dom t \<^bold>\<star> Dom u) = Cod v"
         show "Can ((t \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         proof -
           have 2: "(Dom t \<^bold>\<star> Dom u) = Cod v" using 1 by simp
           show ?thesis
             using v 2
           proof (cases v; simp)
             fix w x
             assume wx: "v = (w \<^bold>\<star> x)"
             have "Can w \<and> Nml w" using v wx Nml_HcompD Can.simps(3) by blast
             moreover have "Can x \<and> Nml x" using v wx Nml_HcompD Can.simps(3) by blast
             moreover have "Dom t = Cod w" using 2 wx by simp
             moreover have ux: "Dom u = Cod x" using 2 wx by simp
             ultimately show "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) \<and> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) \<and> Src (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) = Trg (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
               using t u v tu wx I1 I2
               by (metis Nml_HcompD(7) Src_VcompNml Trg_VcompNml)
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Inv_VcompNml:
     assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
               Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
       proof (induct t, simp_all)
         show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<rbrakk> \<Longrightarrow> Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
           by (simp add: Can_implies_Arr)
         show "\<And>x u. \<lbrakk> ide x \<and> arr x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle> = Cod u \<rbrakk> \<Longrightarrow>
                       Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
           by (simp add: Can_implies_Arr)
         fix v w u
         assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
         have v: "Can v \<and> Nml w"
           using vw Nml_HcompD by blast
         have w: "Can w \<and> Nml w"
           using vw Nml_HcompD by blast
         assume I1: "\<And>x. \<lbrakk> Nml v; Can x \<and> Nml x; Dom v = Cod x \<rbrakk> \<Longrightarrow>
                           Inv (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv v"
         assume I2: "\<And>x. \<lbrakk> Nml w; Can x \<and> Nml x; Dom w = Cod x \<rbrakk> \<Longrightarrow>
                           Inv (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv w"
         assume u: "Can u \<and> Nml u"
         assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
         show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv w)"
           using v 1
         proof (cases w, simp_all)
           show "\<And>\<mu>. obj \<mu> \<Longrightarrow> Dom v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow> w = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> Can v \<Longrightarrow>
                      Inv ((v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0)"
             using Nml_HcompD(5) is_Prim\<^sub>0_def vw by blast
           show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Dom v \<^bold>\<star> \<^bold>\<langle>dom \<mu>\<^bold>\<rangle> = Cod u \<Longrightarrow> w = \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<Longrightarrow> Can v \<Longrightarrow>
                      Inv ((v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> \<^bold>\<langle>inv \<mu>\<^bold>\<rangle>)"
             by (metis Ide.simps(2) Can.simps(2) Nml_HcompD(1) Dom.simps(2) Inv_Ide
                       Dom_Inv Nml_Inv ideD(2) inv_ide VcompNml_Cod_Nml VcompNml_Nml_Dom
                       u vw)
           show "\<And>y z. Nml (y \<^bold>\<star> z) \<Longrightarrow> Dom v \<^bold>\<star> Dom y \<^bold>\<star> Dom z = Cod u \<Longrightarrow>
                            w = y \<^bold>\<star> z \<Longrightarrow> Can v \<Longrightarrow>
                           Inv ((v \<^bold>\<star> y \<^bold>\<star> z) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv y \<^bold>\<star> Inv z)"
           proof -
             fix y z
             assume 2: "Nml (y \<^bold>\<star> z)"
             assume yz: "w = y \<^bold>\<star> z"
             show "Inv ((v \<^bold>\<star> y \<^bold>\<star> z) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv y \<^bold>\<star> Inv z)"
               using u vw yz I1 I2 1 2 VcompNml_Nml_Ide
               apply (cases u)
                        apply simp_all
               by (metis Nml_HcompD(3-4))
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Can_and_Nml_implies_Ide:
     assumes "Can t" and "Nml t"
     shows "Ide t"
     proof -
       have "\<lbrakk> Can t; Nml t \<rbrakk> \<Longrightarrow> Ide t"
         apply (induct t) by (simp_all add: Nml_HcompD)
       thus ?thesis using assms by blast
     qed
 
     lemma VcompNml_Can_Inv [simp]:
     assumes "Can t" and "Nml t"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t = Cod t"
       using assms Can_and_Nml_implies_Ide Ide_in_Hom by simp
       
     lemma VcompNml_Inv_Can [simp]:
     assumes "Can t" and "Nml t"
     shows "Inv t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = Dom t"
       using assms Can_and_Nml_implies_Ide Ide_in_Hom by simp
 
     text \<open>
       The next fact is a syntactic version of the interchange law, for normal terms.
     \<close>
 
     lemma VcompNml_HcompNml:
     assumes "Nml t" and "Nml u" and "Nml v" and "Nml w"
     and "VSeq t v" and "VSeq u w" and "Src v = Trg w"
     shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
     proof -
       have "\<And>u v w. \<lbrakk> Nml t; Nml u; Nml v; Nml w; VSeq t v; VSeq u w;
                       Src t = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
                       (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
       proof (induct t, simp_all)
         fix u v w x
         assume u: "Nml u"
         assume v: "Nml v"
         assume w: "Nml w"
         assume uw: "VSeq u w"
         show "\<And>x. Arr v \<and> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod v \<Longrightarrow> (Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
           using u v w uw by (cases v) simp_all
         show "\<And>x. \<lbrakk> arr x; Arr v \<and> \<^bold>\<langle>dom x\<^bold>\<rangle> = Cod v; \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
                   (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
         proof -
           fix x
           assume x: "arr x"
           assume 1: "Arr v \<and> \<^bold>\<langle>dom x\<^bold>\<rangle> = Cod v"
           assume tu: "\<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u"
           assume vw: "Src v = Trg w"
           show "(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
           proof -
             have 2: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v)" using v 1 by (cases v) simp_all
             have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
               using u v w x tu uw vw 1 2 Cod.simps(3) VcompNml_Cod_Nml Dom.simps(2)
                     HcompNml_Prim HcompNml_term_Prim\<^sub>0 Nml_HcompNml(3) HcompNml_Trg_Nml
               apply (cases u)
                 apply simp_all
               by (cases w, simp_all add: Src_VcompNml)
             moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
             proof -
               assume 3: "\<not> is_Prim\<^sub>0 u"
               hence 4: "\<not> is_Prim\<^sub>0 w" using u w uw by (cases u, simp_all; cases w, simp_all)
               have "(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<star> w)"
               proof -
                 have "\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> u"
                   using u x 3 HcompNml_Nml by (cases u, simp_all)
                 moreover have "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w = v \<^bold>\<star> w"
                   using w 2 4 HcompNml_Nml by (cases v, simp_all; cases w, simp_all)
                 ultimately show ?thesis by simp
               qed
               also have 5: "... = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<star> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)" by simp
               also have "... = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                 using x u w uw vw 1 2 3 4 5
                       HcompNml_Nml HcompNml_Prim Nml_HcompNml(1)
                 by (metis Cod.simps(3) Nml.simps(3) Dom.simps(2) Dom.simps(3)
                     Nml_VcompNml(1) tu v)
               finally show ?thesis by blast
             qed
             ultimately show ?thesis by blast
           qed
         qed
         fix t1 t2
         assume t12: "Nml (t1 \<^bold>\<star> t2)"
         assume I1: "\<And>u v w. \<lbrakk> Nml t1; Nml u; Nml v; Nml w;
                               Arr v \<and> Dom t1 = Cod v; VSeq u w;
                               Trg t2 = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
                               (t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
         assume I2: "\<And>u' v w. \<lbrakk> Nml t2; Nml u'; Nml v; Nml w;
                                Arr v \<and> Dom t2 = Cod v; VSeq u' w;
                                Trg u = Trg u'; Src v = Trg w \<rbrakk> \<Longrightarrow>
                               (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u') \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u' \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
         have t1: "t1 = \<^bold>\<langle>un_Prim t1\<^bold>\<rangle> \<and> arr (un_Prim t1) \<and> Nml t1"
           using t12 by (cases t1, simp_all)
         have t2: "Nml t2 \<and> \<not>is_Prim\<^sub>0 t2"
           using t12 by (cases t1, simp_all)
         assume vw: "Src v = Trg w"
         assume tu: "Src t2 = Trg u"
         assume 1: "Arr t1 \<and> Arr t2 \<and> Src t1 = Trg t2 \<and> Arr v \<and> (Dom t1 \<^bold>\<star> Dom t2) = Cod v"
         show "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
         proof -
           have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
             using u v w uw tu vw t12 I1 I2 1 Obj_Src
             apply (cases u)
               apply simp_all
             by (cases w, simp_all add: Src_VcompNml)
           moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
           proof -
             assume u': "\<not> is_Prim\<^sub>0 u"
             hence w': "\<not> is_Prim\<^sub>0 w" using u w uw by (cases u, simp_all; cases w, simp_all)
             show ?thesis
               using 1 v
             proof (cases v, simp_all)
               fix v1 v2
               assume v12: "v = v1 \<^bold>\<star> v2"
               have v1: "v1 =  \<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<and> arr (un_Prim v1) \<and> Nml v1"
                 using v v12 by (cases v1, simp_all)
               have v2: "Nml v2 \<and> \<not> is_Prim\<^sub>0 v2"
                 using v v12 by (cases v1, simp_all)
               have 2: "v = (\<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<^bold>\<star> v2)"
                 using v1 v12 by simp
               show "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<star> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<^bold>\<star> t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
               proof -
                 have 3: "(t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
                   using u u' by (cases u, simp_all)
                 have 4: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w = v1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
                 proof -
                   have "Src v1 = Trg v2"
                     using v v12 1 Arr.simps(3) Nml_HcompD(7) by blast
                   moreover have "Src v2 = Trg w"
                     using v v12 vw by simp
                   ultimately show ?thesis
                     using v w v1 v2 v12 2 HcompNml_assoc [of v1 v2 w] HcompNml_Nml by metis
                 qed
                 have "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<star> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)
                         = (t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w))"
                   using 3 4 v12 by simp
                 also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w))"
                 proof -
                   have "is_Hcomp (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
                     using t2 u u' tu is_Hcomp_HcompNml by auto
                   moreover have "is_Hcomp (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)"
                     using v2 v12 w w' vw is_Hcomp_HcompNml by auto
                   ultimately show ?thesis
                     using u u' v w t1 v1 t12 v12 HcompNml_Prim
                     by (metis VcompNml.simps(2) VcompNml.simps(3) is_Hcomp_def
                         term.distinct_disc(3))
                 qed
                 also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                   using u w tu uw vw t2 v2 1 2 Nml_implies_Arr I2 by auto
                 also have "... = ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<star> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                 proof -
                   have "\<not>is_Prim\<^sub>0 (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                     using u w u' w' by (cases u, simp_all; cases w, simp_all)
                   hence "((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<star> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)
                            = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w))"
                     by (cases "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w") simp_all
                   thus ?thesis by presburger
                 qed
                 finally show ?thesis by blast
               qed
             qed
           qed
           ultimately show ?thesis by blast
         qed
       qed
       moreover have "Src t = Trg u"
         using assms Src_Dom Trg_Dom Src_Cod Trg_Cod Nml_implies_Arr by metis
       ultimately show ?thesis using assms by simp
     qed
 
     text \<open>
       The following function reduces a formal arrow to normal form.
     \<close>
 
     fun Nmlize :: "'a term \<Rightarrow> 'a term"   ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
     where "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle>"
         | "\<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
 
     lemma Nml_Nmlize:
     assumes "Arr t"
     shows "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t" and "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t"
     and "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
     proof -
       have 0: "Arr t \<Longrightarrow> Nml \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t \<and> Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t \<and>
                                      Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
         using Nml_HcompNml Nml_VcompNml HcompNml_assoc
               Src_VcompNml Trg_VcompNml VSeq_implies_HPar
         apply (induct t)
                  apply auto
       proof -
         fix t
         assume 1: "Arr t"
         assume 2: "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         assume 3: "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t"
         assume 4: "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t"
         assume 5: "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
         assume 6: "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
         have 7: "Nml \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
           using 2 5 Nml_Dom by fastforce
         have 8: "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor>"
           using 1 2 4 Nml_Trg Obj_Trg
           by (metis Nml.elims(2) Nmlize.simps(1) Nmlize.simps(2) Obj.simps(3))
         have 9: "Nml \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
           using 2 6 Nml_Cod by fastforce
         have 10: "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
           using 1 2 3 Nml_Src Obj_Src
           by (metis Nml.elims(2) Nmlize.simps(1) Nmlize.simps(2) Obj.simps(3))
         show "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
           using 2 5 7 8 Nml_implies_Arr Trg_Dom HcompNml_Trg_Nml by metis
         show "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
           using 2 6 8 9 Nml_implies_Arr Trg_Cod HcompNml_Trg_Nml by metis
         show "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
           using 2 5 7 10 Nml_implies_Arr Src_Dom HcompNml_Nml_Src by metis
         show "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
           using 2 6 9 10 Nml_implies_Arr Src_Cod HcompNml_Nml_Src by metis
         next
         fix t1 t2 t3
         assume "Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>" and "Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>" and "Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
         assume "Src t1 = Trg t2" and "Src t2 = Trg t3"
         assume "Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2" and "Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3"
         assume "Trg \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t1" and "Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2" and "Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3"
         assume "Dom \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>"
         and "Cod \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"
         show "\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> =
               (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>"
           using Nml_Dom Nml_implies_Arr Src_Dom Trg_Dom
                 HcompNml_assoc [of "\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>"]
                 \<open>Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>\<close>
                 \<open>Dom \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>\<close> \<open>Dom \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>\<close> \<open>Dom \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>\<close>
                 \<open>Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2\<close> \<open>Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2\<close>
                 \<open>Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3\<close> \<open>Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3\<close>
           by metis
         show "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> = (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"
           using Nml_Cod Nml_implies_Arr Src_Cod Trg_Cod
                 HcompNml_assoc [of "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"]
                 \<open>Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>\<close>
                 \<open>Cod \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>\<close> \<open>Cod \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>\<close> \<open>Cod \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>\<close>
                 \<open>Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2\<close> \<open>Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2\<close>
                 \<open>Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3\<close> \<open>Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3\<close>
           by metis
       qed
       show "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" using assms 0 by blast
       show "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t" using assms 0 by blast
       show "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t" using assms 0 by blast
       show "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" using assms 0 by blast
       show "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>" using assms 0 by blast
     qed
 
     lemma Nmlize_in_Hom [intro]:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> HHom (Src t) (Trg t)" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
       using assms Nml_Nmlize Nml_implies_Arr by auto
 
     lemma Nmlize_Src:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src t"
     proof -
       have 1: "Obj (Src t)"
         using assms by simp
       obtain a where a: "obj a \<and> Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
         using 1 by (cases "Src t", simp_all)
       show "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src t"
         using a by simp
       thus "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using assms Nmlize_in_Hom by simp
     qed
 
     lemma Nmlize_Trg:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg t"
     proof -
       have 1: "Obj (Trg t)"
         using assms by simp
       obtain a where a: "obj a \<and> Trg t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
         using 1 by (cases "Trg t", simp_all)
       show "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg t"
         using a by simp
       thus "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using assms Nmlize_in_Hom by simp
     qed
 
     lemma Nmlize_Dom:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Nmlize_in_Hom by simp
 
     lemma Nmlize_Cod:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Nmlize_in_Hom by simp
 
     lemma Ide_Nmlize_Ide:
     assumes "Ide t"
     shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Ide t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using Ide_HcompNml Nml_Nmlize
         by (induct t, simp_all)
       thus ?thesis using assms by blast
     qed
 
     lemma Ide_Nmlize_Can:
     assumes "Can t"
     shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Can t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using Can_implies_Arr Ide_HcompNml Nml_Nmlize Ide_VcompNml Nml_HcompNml
         apply (induct t)
           apply (auto simp add: Dom_Ide Cod_Ide)
         by (metis Ide_VcompNml)
       thus ?thesis using assms by blast
     qed
 
     lemma Can_Nmlize_Can:
     assumes "Can t"
     shows "Can \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Ide_Nmlize_Can Ide_implies_Can by auto
 
     lemma Nmlize_Nml [simp]:
     assumes "Nml t"
     shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
     proof -
       have "Nml t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
         apply (induct t, simp_all)
         using HcompNml_Prim Nml_HcompD by metis
       thus ?thesis using assms by blast
     qed
 
     lemma Nmlize_Nmlize [simp]:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Nml_Nmlize Nmlize_Nml by blast
 
     lemma Nmlize_Hcomp:
     assumes "Arr t" and "Arr u"
     shows "\<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<^bold>\<rfloor>"
       using assms Nmlize_Nmlize by simp
 
     lemma Nmlize_Hcomp_Obj_Arr [simp]:
     assumes "Arr u"
     shows "\<^bold>\<lfloor>\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
       using assms by simp
 
     lemma Nmlize_Hcomp_Arr_Obj [simp]:
     assumes "Arr t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
     shows "\<^bold>\<lfloor>t \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms HcompNml_Nml_Src Nmlize_in_Hom by simp
 
     lemma Nmlize_Hcomp_Prim_Arr [simp]:
     assumes "Arr u" and "\<not> is_Prim\<^sub>0 \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     shows "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
       using assms by simp
 
     lemma Nmlize_Hcomp_Hcomp:
     assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
     shows "\<^bold>\<lfloor>(t \<^bold>\<star> u) \<^bold>\<star> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>v\<^bold>\<rfloor>)\<^bold>\<rfloor>"
       using assms Nml_Nmlize Nmlize_Nmlize by (simp add: HcompNml_assoc)
 
     lemma Nmlize_Hcomp_Hcomp':
     assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
     shows "\<^bold>\<lfloor>t \<^bold>\<star> u \<^bold>\<star> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>v\<^bold>\<rfloor>\<^bold>\<rfloor>"
       using assms Nml_Nmlize Nmlize_Nmlize by (simp add: HcompNml_assoc)
 
     lemma Nmlize_Vcomp_Cod_Arr:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Arr t \<Longrightarrow> \<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       proof (induct t, simp_all)
         show "\<And>x. arr x \<Longrightarrow> cod x \<cdot> x = x"
           using comp_cod_arr by blast
         fix t1 t2
         show "\<And>t1 t2. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> HSeq t1 t2 \<Longrightarrow>
                       (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
           using VcompNml_HcompNml Ide_Cod Nml_Nmlize Nmlize_in_Hom
           by simp
         show "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> VSeq t1 t2 \<Longrightarrow>
               \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
           using VcompNml_assoc [of "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t2\<^bold>\<rfloor>"] Ide_Cod
                 Nml_Nmlize
           by simp
         next
         show "\<And>t. \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> (\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
           by (metis Arr.simps(6) Cod.simps(6) Nmlize.simps(3) Nmlize.simps(6)
               Nmlize_Cod)
         show "\<And>t. \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> (\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
           by (simp add: Nml_Nmlize(1) Nml_Nmlize(2) Nmlize_Src(2) HcompNml_Nml_Obj)
         show "\<And>t1 t2 t3. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
                           \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
                           Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
                          (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) =
                          (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
           using VcompNml_HcompNml Ide_Cod HcompNml_in_Hom Nml_HcompNml
                 Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
           by simp
         show "\<And>t1 t2 t3. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
                           \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
                           Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
                           ((\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) =
                           \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
           using VcompNml_HcompNml Ide_Cod HcompNml_in_Hom Nml_HcompNml
                 Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
           by simp
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Nmlize_Vcomp_Arr_Dom:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Arr t \<Longrightarrow> \<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       proof (induct t, simp_all)
         show "\<And>x. arr x \<Longrightarrow> x \<cdot> local.dom x = x"
           using comp_arr_dom by blast
         fix t1 t2
         show "\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> HSeq t1 t2 \<Longrightarrow>
               (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
           using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
                 Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
           by simp
         show "\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> VSeq t1 t2 \<Longrightarrow>
               (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
           using VcompNml_assoc [of "\<^bold>\<lfloor>t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>"] Ide_Dom Nml_Nmlize
           by simp
         next
         show "\<And>t. \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
           by (simp add: Nml_Nmlize(1) Nml_Nmlize(3) Nmlize_Trg(2)
               HcompNml_Obj_Nml bicategorical_language.Ide_Dom
               bicategorical_language_axioms)
         show "\<And>t. \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
           by (simp add: Nml_Nmlize(1) Nml_Nmlize(2) Nmlize_Src(2) HcompNml_Nml_Obj)
         show "\<And>t1 t2 t3. \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
                           \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
                           Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
                           ((\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>) =
                           (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
           using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
                 Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
           by simp
         show "\<And>t1 t2 t3. \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
                           \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
                           Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
                           (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>) =
                           \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
           using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
                 Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
           by simp
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Nmlize_Inv:
     assumes "Can t"
     shows "\<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Can t \<Longrightarrow> \<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       proof (induct t, simp_all)
         fix u v
         assume I1: "\<^bold>\<lfloor>Inv u\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         assume I2: "\<^bold>\<lfloor>Inv v\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>"
         show "Can u \<and> Can v \<and> Src u = Trg v \<Longrightarrow> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
           using Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
                 I1 I2
           by simp
         show "Can u \<and> Can v \<and> Dom u = Cod v \<Longrightarrow> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
           using Inv_VcompNml Nml_Nmlize Can_implies_Arr Nmlize_in_Hom Can_Nmlize_Can
                 I1 I2
           by simp
         fix w
         assume I3: "\<^bold>\<lfloor>Inv w\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>"
         assume uvw: "Can u \<and> Can v \<and> Can w \<and> Src u = Trg v \<and> Src v = Trg w"
         show "Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>) = Inv ((\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
           using uvw I1 I2 I3
                 Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
                 Nml_HcompNml Can_HcompNml HcompNml_assoc
           by simp
         show "(Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>))"
           using uvw I1 I2 I3
                 Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
                 Nml_HcompNml Can_HcompNml HcompNml_assoc Can_Inv
           by simp
       qed
       thus ?thesis using assms by blast
     qed
 
     subsection "Reductions"
 
     text \<open>
       Function \<open>red\<close> defined below takes a formal identity @{term t} to a canonical arrow
       \<open>f\<^bold>\<down> \<in> Hom f \<^bold>\<lfloor>f\<^bold>\<rfloor>\<close>.  The auxiliary function \<open>red2\<close> takes a pair @{term "(f, g)"}
       of normalized formal identities and produces a canonical arrow
       \<open>f \<^bold>\<Down> g \<in> Hom (f \<^bold>\<star> g) \<^bold>\<lfloor>f \<^bold>\<star> g\<^bold>\<rfloor>\<close>.
     \<close>
 
     fun red2                       (infixr "\<^bold>\<Down>" 53)
     where "\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<Down> u = \<^bold>\<l>\<^bold>[u\<^bold>]"
         | "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]"
         | "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> u"
         | "(t \<^bold>\<star> u) \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = \<^bold>\<r>\<^bold>[t \<^bold>\<star> u\<^bold>]"
         | "(t \<^bold>\<star> u) \<^bold>\<Down> v = (t \<^bold>\<Down> \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>) \<^bold>\<cdot> (t \<^bold>\<star> (u \<^bold>\<Down> v)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
         | "t \<^bold>\<Down> u = undefined"
 
     fun red                         ("_\<^bold>\<down>" [56] 56)
     where "\<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0"
         | "\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>"
         | "(t \<^bold>\<star> u)\<^bold>\<down> = (if Nml (t \<^bold>\<star> u) then t \<^bold>\<star> u else (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<cdot> (t\<^bold>\<down> \<^bold>\<star> u\<^bold>\<down>))"
         | "t\<^bold>\<down> = undefined"
 
     lemma red_Nml [simp]:
     assumes "Nml a"
     shows "a\<^bold>\<down> = a"
       using assms by (cases a, simp_all)
 
     lemma red2_Nml:
     assumes "Nml (a \<^bold>\<star> b)"
     shows "a \<^bold>\<Down> b = a \<^bold>\<star> b"
     proof -
       have a: "a = \<^bold>\<langle>un_Prim a\<^bold>\<rangle>"
         using assms Nml_HcompD by metis
       have b: "Nml b \<and> \<not> is_Prim\<^sub>0 b"
         using assms Nml_HcompD by metis
       show ?thesis using a b
         apply (cases b)
           apply simp_all
          apply (metis red2.simps(3))
         by (metis red2.simps(4))
     qed
 
     lemma Can_red2:
     assumes "Ide a" and "Nml a" and "Ide b" and "Nml b" and "Src a = Trg b"
     shows "Can (a \<^bold>\<Down> b)"
     and "a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>"
     proof -
       have 0: "\<And>b. \<lbrakk> Ide a \<and> Nml a; Ide b \<and> Nml b; Src a = Trg b \<rbrakk> \<Longrightarrow>
                      Can (a \<^bold>\<Down> b) \<and> a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>"
       proof (induct a, simp_all add: HcompNml_Nml_Src HcompNml_Trg_Nml)
         fix x b
         show "Ide b \<and> Nml b \<Longrightarrow> Can (Trg b \<^bold>\<Down> b) \<and> Arr (Trg b \<^bold>\<Down> b) \<and>
                                  Dom (Trg b \<^bold>\<Down> b) = Trg b \<^bold>\<star> b \<and> Cod (Trg b \<^bold>\<Down> b) = b"
           using Ide_implies_Can Ide_in_Hom Nmlize_Nml
           apply (cases b, simp_all)
         proof -
           fix u v
           assume uv: "Ide u \<and> Ide v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
           show "Can (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) \<and> Arr (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) \<and>
                 Dom (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) = Trg u \<^bold>\<star> u \<^bold>\<star> v \<and>
                 Cod (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) = u \<^bold>\<star> v"
             using uv Ide_implies_Can Can_implies_Arr Ide_in_Hom
             by (cases u, simp_all)
         qed
         show "ide x \<and> arr x \<Longrightarrow> Ide b \<and> Nml b \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg b \<Longrightarrow>
               Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Arr (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Dom (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> b \<and> Cod (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) =
               \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b"
             using Ide_implies_Can Can_implies_Arr Nmlize_Nml Ide_in_Hom
             by (cases b, simp_all)
         next
         fix u v w
         assume uv: "Ide u \<and> Ide v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
         assume vw: "Src v = Trg w"
         assume w: "Ide w \<and> Nml w"
         assume I1: "\<And>w. \<lbrakk> Nml u; Ide w \<and> Nml w; Trg v = Trg w \<rbrakk> \<Longrightarrow>
                           Can (u \<^bold>\<Down> w) \<and> Arr (u \<^bold>\<Down> w) \<and>
                           Dom (u \<^bold>\<Down> w) = u \<^bold>\<star> w \<and> Cod (u \<^bold>\<Down> w) = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
         assume I2: "\<And>x. \<lbrakk> Nml v; Ide x \<and> Nml x; Trg w = Trg x \<rbrakk> \<Longrightarrow>
                           Can (v \<^bold>\<Down> x) \<and> Arr (v \<^bold>\<Down> x) \<and>
                           Dom (v \<^bold>\<Down> x) = v \<^bold>\<star> x \<and> Cod (v \<^bold>\<Down> x) = v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x"
         show "Can ((u \<^bold>\<star> v) \<^bold>\<Down> w) \<and> Arr ((u \<^bold>\<star> v) \<^bold>\<Down> w) \<and>
               Dom ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (u \<^bold>\<star> v) \<^bold>\<star> w \<and>
               Cod ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
         proof -
           have u: "Nml u \<and> Ide u"
             using uv Nml_HcompD by blast
           have v: "Nml v \<and> Ide v"
             using uv Nml_HcompD by blast
           have "is_Prim\<^sub>0 w \<Longrightarrow> ?thesis"
           proof -
             assume 1: "is_Prim\<^sub>0 w"
             have 2: "(u \<^bold>\<star> v) \<^bold>\<Down> w = \<^bold>\<r>\<^bold>[u \<^bold>\<star> v\<^bold>]"
               using 1 by (cases w, simp_all)
             have 3: "Can (u \<^bold>\<Down> v) \<and> Arr (u \<^bold>\<Down> v) \<and> Dom (u \<^bold>\<Down> v) = u \<^bold>\<star> v \<and> Cod (u \<^bold>\<Down> v) = u \<^bold>\<star> v"
               using u v uv 1 2 I1 Nmlize_Nml Nmlize.simps(3) by metis
             hence 4: "VSeq (u \<^bold>\<Down> v) \<^bold>\<r>\<^bold>[u \<^bold>\<star> v\<^bold>]"
               using uv
               by (metis (mono_tags, lifting) Arr.simps(7) Cod.simps(3) Cod.simps(7)
                   Nml_implies_Arr Ide_in_Hom(2) mem_Collect_eq)
             have "Can ((u \<^bold>\<star> v) \<^bold>\<Down> w)"
               using 1 2 3 4 uv by (simp add: Ide_implies_Can)
             moreover have "Dom ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (u \<^bold>\<star> v) \<^bold>\<star> w"
               using 1 2 3 4 u v w uv vw I1 Ide_in_Hom Nml_HcompNml Ide_in_Hom
               apply (cases w) by simp_all
             moreover have "Cod ((u \<^bold>\<star> v) \<^bold>\<Down> w) = \<^bold>\<lfloor>(u \<^bold>\<star> v) \<^bold>\<star> w\<^bold>\<rfloor>"
               using 1 2 3 4 uv
               using Nmlize_Nml apply (cases w, simp_all)
               by (metis Nmlize.simps(3) Nmlize_Nml HcompNml.simps(3))
             ultimately show ?thesis using w Can_implies_Arr by (simp add: 1 uv)
           qed
           moreover have "\<not> is_Prim\<^sub>0 w \<Longrightarrow> ?thesis"
           proof -
             assume 1: "\<not> is_Prim\<^sub>0 w"
             have 2: "(u \<^bold>\<star> v) \<^bold>\<Down> w = (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<^bold>\<cdot> (u \<^bold>\<star> v \<^bold>\<Down> w) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[u, v, w\<^bold>]"
               using 1 u v uv w by (cases w; simp)
             have 3: "Can (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<and> Dom (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> \<and>
                                          Cod (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = \<^bold>\<lfloor>u \<^bold>\<star> (v \<^bold>\<star> w)\<^bold>\<rfloor>"
             proof -
               have "Can (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<and> Dom (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> \<and>
                                         Cod (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
                 using w uv Ide_HcompNml Nml_HcompNml(1)
                 apply (cases u, simp_all)
                 using u v vw I1 Nmlize_in_Hom(1) [of "v \<^bold>\<star> w"] Nml_Nmlize Ide_Nmlize_Ide
                 by simp
               moreover have "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> = \<^bold>\<lfloor>u \<^bold>\<star> (v \<^bold>\<star> w)\<^bold>\<rfloor>"
                 using uv u w Nmlize_Hcomp Nmlize_Nmlize Nml_implies_Arr by simp
               ultimately show ?thesis by presburger
             qed
             have 4: "Can (v \<^bold>\<Down> w) \<and> Dom (v \<^bold>\<Down> w) = v \<^bold>\<star> w \<and> Cod (v \<^bold>\<Down> w) = \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
               using v w vw 1 2 I2 by simp
             hence 5: "Src (v \<^bold>\<Down> w) = Src w \<and> Trg (v \<^bold>\<Down> w) = Trg v"
               using Src_Dom Trg_Dom Can_implies_Arr by fastforce
             have "Can (u \<^bold>\<star> (v \<^bold>\<Down> w)) \<and> Dom (u \<^bold>\<star> (v \<^bold>\<Down> w)) = u \<^bold>\<star> (v \<^bold>\<star> w) \<and>
                                        Cod (u \<^bold>\<star> (v \<^bold>\<Down> w)) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
               using u uv vw 4 5 Ide_implies_Can Ide_in_Hom by simp
             moreover have "\<^bold>\<lfloor>u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
             proof -
               have "\<^bold>\<lfloor>u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>\<^bold>\<rfloor> = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)"
                 using u v w 4
                 by (metis Ide_Dom Can_implies_Arr Ide_implies_Arr
                     Nml_Nmlize(1) Nmlize.simps(3) Nmlize_Nml)
               also have "... = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
                 using u v w uv vw HcompNml_assoc by metis
               also have "... = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
                 using u v w by (metis Nmlize.simps(3) Nmlize_Nml)
               finally show ?thesis by blast
             qed
             moreover have "Can \<^bold>\<a>\<^bold>[u, v, w\<^bold>] \<and> Dom \<^bold>\<a>\<^bold>[u, v, w\<^bold>] = (u \<^bold>\<star> v) \<^bold>\<star> w \<and>
                                             Cod \<^bold>\<a>\<^bold>[u, v, w\<^bold>] = u \<^bold>\<star> (v \<^bold>\<star> w)"
               using uv vw w Ide_implies_Can Ide_in_Hom by auto
             ultimately show ?thesis
               using uv w 2 3 4 Nml_implies_Arr Nmlize_Nmlize Ide_implies_Can
                     Nmlize_Nml Ide_Dom Can_implies_Arr
               by (metis Can.simps(4) Cod.simps(4) Dom.simps(4) Nmlize.simps(3))
           qed
           ultimately show ?thesis by blast
         qed
       qed
       show "Can (a \<^bold>\<Down> b)" using assms 0 by blast
       show "a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>" using 0 assms by blast
     qed
 
     lemma red2_in_Hom [intro]:
     assumes "Ide u" and "Nml u" and "Ide v" and "Nml v" and "Src u = Trg v"
     shows "u \<^bold>\<Down> v \<in> HHom (Src v) (Trg u)" and "u \<^bold>\<Down> v \<in> VHom (u \<^bold>\<star> v) \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
     proof -
       show 1: "u \<^bold>\<Down> v \<in> VHom (u \<^bold>\<star> v) \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
         using assms Can_red2 Can_implies_Arr by simp
       show "u \<^bold>\<Down> v \<in> HHom (Src v) (Trg u)"
         using assms 1 Src_Dom [of "u \<^bold>\<Down> v"] Trg_Dom [of "u \<^bold>\<Down> v"] Can_red2 Can_implies_Arr by simp
     qed
 
     lemma red2_simps [simp]:
     assumes "Ide u" and "Nml u" and "Ide v" and "Nml v" and "Src u = Trg v"
     shows "Src (u \<^bold>\<Down> v) = Src v" and "Trg (u \<^bold>\<Down> v) = Trg u"
     and "Dom (u \<^bold>\<Down> v) = u \<^bold>\<star> v" and "Cod (u \<^bold>\<Down> v) = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
       using assms red2_in_Hom by auto
 
     lemma Can_red:
     assumes "Ide u"
     shows "Can (u\<^bold>\<down>)" and "u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     proof -
       have 0: "Ide u \<Longrightarrow> Can (u\<^bold>\<down>) \<and> u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>"
       proof (induct u, simp_all add: Dom_Ide Cod_Ide)
         fix v w
         assume v: "Can (v\<^bold>\<down>) \<and> Arr (v\<^bold>\<down>) \<and> Dom (v\<^bold>\<down>) = v \<and> Cod (v\<^bold>\<down>) = \<^bold>\<lfloor>v\<^bold>\<rfloor>"
         assume w: "Can (w\<^bold>\<down>) \<and> Arr (w\<^bold>\<down>) \<and> Dom (w\<^bold>\<down>) = w \<and> Cod (w\<^bold>\<down>) = \<^bold>\<lfloor>w\<^bold>\<rfloor>"
         assume vw: "Ide v \<and> Ide w \<and> Src v = Trg w"
         show "(Nml (v \<^bold>\<star> w) \<longrightarrow>
                  Can v \<and> Can w \<and> v \<^bold>\<star> w = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and>
               (\<not> Nml (v \<^bold>\<star> w) \<longrightarrow>
                  Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
                  Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
                  Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
         proof
           show "Nml (v \<^bold>\<star> w) \<longrightarrow>
                   Can v \<and> Can w \<and> v \<^bold>\<star> w = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
             using vw Nml_HcompD Ide_implies_Can Dom_Inv VcompNml_Ide_Nml Inv_Ide
                   Nmlize.simps(3) Nmlize_Nml
             by metis
           show "\<not> Nml (v \<^bold>\<star> w) \<longrightarrow>
                   Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
                   Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
                   Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
           proof
             assume 1: "\<not> Nml (v \<^bold>\<star> w)"
             have "Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
               using v w vw Can_red2 Nml_Nmlize Ide_Nmlize_Ide Nml_HcompNml Ide_HcompNml
               by simp
             moreover have "Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>)"
               using v w vw Src_Dom Trg_Dom by metis
             moreover have "Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
               using v w vw Can_red2 Nml_Nmlize Ide_Nmlize_Ide by simp
             ultimately show "Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
                              Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and>
                              Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and> Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and>
                              Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
               using Can_implies_Arr by blast
           qed
         qed
       qed
       show "Can (u\<^bold>\<down>)" using assms 0 by blast
       show "u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>" using assms 0 by blast
     qed
 
     lemma red_in_Hom [intro]:
     assumes "Ide t"
     shows "t\<^bold>\<down> \<in> HHom (Src t) (Trg t)" and "t\<^bold>\<down> \<in> VHom t \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       show 1: "t\<^bold>\<down> \<in> VHom t \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using assms Can_red Can_implies_Arr by simp
       show "t\<^bold>\<down> \<in> HHom (Src t) (Trg t)"
         using assms 1 Src_Dom [of "t\<^bold>\<down>"] Trg_Dom [of "t\<^bold>\<down>"] Can_red Can_implies_Arr by simp
     qed
 
     lemma red_simps [simp]:
     assumes "Ide t"
     shows "Src (t\<^bold>\<down>) = Src t" and "Trg (t\<^bold>\<down>) = Trg t"
     and "Dom (t\<^bold>\<down>) = t" and "Cod (t\<^bold>\<down>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms red_in_Hom by auto
 
     lemma red_Src:
     assumes "Ide t"
     shows "Src t\<^bold>\<down> = Src t"
       using assms is_Prim0_Src [of t]
       by (cases "Src t", simp_all)
 
     lemma red_Trg:
     assumes "Ide t"
     shows "Trg t\<^bold>\<down> = Trg t"
       using assms is_Prim0_Trg [of t]
       by (cases "Trg t", simp_all)
 
     lemma Nmlize_red [simp]:
     assumes "Ide t"
     shows "\<^bold>\<lfloor>t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Can_red Ide_Nmlize_Can Nmlize_in_Hom Ide_in_Hom by fastforce
 
     lemma Nmlize_red2 [simp]:
     assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "\<^bold>\<lfloor>t \<^bold>\<Down> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor>"
       using assms Can_red2 Ide_Nmlize_Can Nmlize_in_Hom [of "t \<^bold>\<Down> u"] red2_in_Hom Ide_in_Hom
       by simp
 
   end
 
   subsection "Evaluation"
 
   text \<open>
     The following locale is concerned with the evaluation of terms of the bicategorical
     language determined by \<open>C\<close>, \<open>src\<^sub>C\<close>, and \<open>trg\<^sub>C\<close> in a bicategory \<open>(V, H, \<a>, \<i>, src, trg)\<close>,
     given a source and target-preserving functor from \<open>C\<close> to \<open>V\<close>.
   \<close>
 
   locale evaluation_map =
     C: horizontal_homs C src\<^sub>C trg\<^sub>C +
     bicategorical_language C src\<^sub>C trg\<^sub>C +
     bicategory V H \<a> \<i> src trg +
     E: "functor" C V E
     for C :: "'c comp"                   (infixr "\<cdot>\<^sub>C" 55)
     and src\<^sub>C :: "'c \<Rightarrow> 'c"
     and trg\<^sub>C :: "'c \<Rightarrow> 'c"
     and V :: "'b comp"                   (infixr "\<cdot>" 55)
     and H :: "'b comp"                   (infixr "\<star>" 53)
     and \<a> :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b"       ("\<a>[_, _, _]")
     and \<i> :: "'b \<Rightarrow> 'b"                   ("\<i>[_]")
     and src :: "'b \<Rightarrow> 'b"
     and trg :: "'b \<Rightarrow> 'b"
     and E :: "'c \<Rightarrow> 'b" +
     assumes preserves_src: "E (src\<^sub>C x) = src (E x)"
     and preserves_trg: "E (trg\<^sub>C x) = trg (E x)"
   begin
 
     (* TODO: Figure out why this notation has to be reinstated. *)
     notation Nmlize  ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
     notation HcompNml    (infixr "\<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor>" 53)
     notation VcompNml    (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
     notation red          ("_\<^bold>\<down>" [56] 56)
     notation red2         (infixr "\<^bold>\<Down>" 53)
 
     primrec eval :: "'c term \<Rightarrow> 'b"    ("\<lbrace>_\<rbrace>")
     where "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0\<rbrace> = E f"
         | "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = E f"
         | "\<lbrace>t \<^bold>\<star> u\<rbrace> = \<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>"
         | "\<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         | "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<ll> \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<ll>'.map \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<rr> \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<rr>'.map \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
         | "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
 
     lemma preserves_obj:
     assumes "C.obj a"
     shows "obj (E a)"
     proof (unfold obj_def)
       show "arr (E a) \<and> src (E a) = E a"
       proof
         show "arr (E a)" using assms C.obj_simps by simp
         have "src (E a) = E (src\<^sub>C a)"
            using assms preserves_src by metis
         also have "... = E a"
            using assms C.obj_simps by simp
         finally show "src (E a) = E a" by simp
       qed
     qed
 
     lemma eval_in_hom':
     shows "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
     proof (induct t)
       show "\<And>x. Arr \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 \<Longrightarrow>
                  \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> : \<lbrace>Src \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> : \<lbrace>Dom \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>\<guillemotright>"
         apply (simp add: preserves_src preserves_trg)
         using preserves_src preserves_trg C.objE
         by (metis (full_types) C.obj_def' E.preserves_arr E.preserves_ide in_hhom_def
             ide_in_hom(2))
       show "\<And>x. Arr \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow>
                 \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> : \<lbrace>Src \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> : \<lbrace>Dom \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>\<guillemotright>"
         by (auto simp add: preserves_src preserves_trg)
       show "\<And>t1 t2.
               (Arr t1 \<Longrightarrow> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Src t1\<rbrace> \<rightarrow> \<lbrace>Trg t1\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Dom t1\<rbrace> \<Rightarrow> \<lbrace>Cod t1\<rbrace>\<guillemotright>) \<Longrightarrow>
               (Arr t2 \<Longrightarrow> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Src t2\<rbrace> \<rightarrow> \<lbrace>Trg t2\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Dom t2\<rbrace> \<Rightarrow> \<lbrace>Cod t2\<rbrace>\<guillemotright>) \<Longrightarrow>
               Arr (t1 \<^bold>\<star> t2) \<Longrightarrow>
               \<guillemotleft>\<lbrace>t1 \<^bold>\<star> t2\<rbrace> : \<lbrace>Src (t1 \<^bold>\<star> t2)\<rbrace> \<rightarrow> \<lbrace>Trg (t1 \<^bold>\<star> t2)\<rbrace>\<guillemotright> \<and>
               \<guillemotleft>\<lbrace>t1 \<^bold>\<star> t2\<rbrace> : \<lbrace>Dom (t1 \<^bold>\<star> t2)\<rbrace> \<Rightarrow> \<lbrace>Cod (t1 \<^bold>\<star> t2)\<rbrace>\<guillemotright>"
         using hcomp_in_hhom in_hhom_def vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
       show "\<And>t1 t2.
               (Arr t1 \<Longrightarrow> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Src t1\<rbrace> \<rightarrow> \<lbrace>Trg t1\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Dom t1\<rbrace> \<Rightarrow> \<lbrace>Cod t1\<rbrace>\<guillemotright>) \<Longrightarrow>
               (Arr t2 \<Longrightarrow> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Src t2\<rbrace> \<rightarrow> \<lbrace>Trg t2\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Dom t2\<rbrace> \<Rightarrow> \<lbrace>Cod t2\<rbrace>\<guillemotright>) \<Longrightarrow>
               Arr (t1 \<^bold>\<cdot> t2) \<Longrightarrow>
               \<guillemotleft>\<lbrace>t1 \<^bold>\<cdot> t2\<rbrace> : \<lbrace>Src (t1 \<^bold>\<cdot> t2)\<rbrace> \<rightarrow> \<lbrace>Trg (t1 \<^bold>\<cdot> t2)\<rbrace>\<guillemotright> \<and>
               \<guillemotleft>\<lbrace>t1 \<^bold>\<cdot> t2\<rbrace> : \<lbrace>Dom (t1 \<^bold>\<cdot> t2)\<rbrace> \<Rightarrow> \<lbrace>Cod (t1 \<^bold>\<cdot> t2)\<rbrace>\<guillemotright>"
         using VSeq_implies_HPar seqI' by auto
       show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
                 Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow>
                 \<guillemotleft>\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
       proof (simp add: preserves_src preserves_trg)
         fix t
         assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         assume 1: "Arr t"
         show "\<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         proof -
           have "src (\<ll> \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
             using t 1
             by (metis (no_types, lifting) \<ll>.preserves_cod arr_cod in_hhomE map_simp src_cod)
           moreover have "trg (\<ll> \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
             using t 1
             by (metis (no_types, lifting) \<ll>.preserves_cod arr_cod in_hhomE map_simp trg_cod)
           moreover have "\<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
             using t 1
             apply (elim conjE in_hhomE)
             by (intro in_homI, auto)
           ultimately show ?thesis by auto
         qed
       qed
       show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
                 Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow>
                 \<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and>
                 \<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
       proof (simp add: preserves_src preserves_trg)
         fix t
         assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         assume 1: "Arr t"
         show "\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
               \<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         proof -
           have "src (\<ll>'.map \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
             using t 1 \<ll>'.preserves_dom arr_dom map_simp \<ll>'.preserves_reflects_arr src_dom
             by (metis (no_types, lifting) in_hhomE)
           moreover have "trg (\<ll>'.map \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
             using t 1 \<ll>'.preserves_dom arr_dom map_simp \<ll>'.preserves_reflects_arr trg_dom
             by (metis (no_types, lifting) in_hhomE)
           moreover have "\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Cod t\<rbrace>\<guillemotright>"
             using t 1 \<ll>'.preserves_hom
             apply (intro in_homI)
               apply auto[1]
              apply fastforce
             by fastforce
           ultimately show ?thesis by blast
         qed
       qed
       show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
                  Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow>
                  \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
       proof (simp add: preserves_src preserves_trg)
         fix t
         assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         assume 1: "Arr t"
         show "\<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Src t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         proof -
           have "src (\<rr> \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
             using t 1 \<rr>.preserves_cod arr_cod map_simp \<rr>.preserves_reflects_arr src_cod
             by (metis (no_types, lifting) in_hhomE)
           moreover have "trg (\<rr> \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
             using t 1 \<rr>.preserves_cod arr_cod map_simp \<rr>.preserves_reflects_arr trg_cod
             by (metis (no_types, lifting) in_hhomE)
           moreover have "\<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Src t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
             using t 1 by force
           ultimately show ?thesis by blast
         qed
       qed
       show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
                  Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow>
                  \<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and>
                  \<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
       proof (simp add: preserves_src preserves_trg)
         fix t
         assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         assume 1: "Arr t"
         show "\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
               \<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Src t\<rbrace>\<guillemotright>"
         proof -
           have "src (\<rr>'.map \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
             using t 1 \<rr>'.preserves_dom arr_dom map_simp \<rr>'.preserves_reflects_arr src_dom
             by (metis (no_types, lifting) in_hhomE)
           moreover have "trg (\<rr>'.map \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
             using t 1 \<rr>'.preserves_dom arr_dom map_simp \<rr>'.preserves_reflects_arr trg_dom
             by (metis (no_types, lifting) in_hhomE)
           moreover have "\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Src t\<rbrace>\<guillemotright>"
             using t 1 src_cod arr_cod \<rr>'.preserves_hom [of "\<lbrace>t\<rbrace>" "\<lbrace>Dom t\<rbrace>" "\<lbrace>Cod t\<rbrace>"]
             apply (elim conjE in_hhomE)
             by (intro in_homI, auto)
           ultimately show ?thesis by blast
         qed
       qed
       show "\<And>t u v.
             (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
             (Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Src u\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>) \<Longrightarrow>
             (Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>) \<Longrightarrow>
             Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow>
             \<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright> \<and>
             \<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
       proof (simp add: preserves_src preserves_trg)
         fix t u v
         assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Trg u\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         assume u: "\<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Trg v\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
         assume v: "\<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
         assume tuv: "Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v"
         show "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
               \<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
                  (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace> \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
         proof -
           have 1: "VVV.in_hom (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)
                                 (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
           proof -
             have "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) \<in>
                     VxVxV.hom (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
               using t u v tuv by simp
             moreover have "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) \<in>
                              {\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and> 
                                    src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))}"
               using t u v tuv by fastforce
             ultimately show ?thesis
               using VVV.hom_char
                       [of "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)" "(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
               by blast
           qed
           have 4: "VVV.arr (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
             using 1 VVV.ide_dom VVV.dom_simp by (elim VVV.in_homE) force
           have 5: "VVV.arr (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
-            using 1 VVV.ide_cod VVV.cod_simp by (elim VVV.in_homE) force
+            using 1 VVV.ide_cod VVV.cod_simp VVV.in_hom_char by blast
           have 2: "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
                       (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace> \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
             using 1 4 5 HoHV_def HoVH_def \<alpha>_def
                   \<alpha>.preserves_hom [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
                                       "(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
             by simp
           have 3: "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>"
           proof
             show "arr (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
               using 2 by auto
             show "src (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Src v\<rbrace>"
             proof -
               have "src (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = src ((\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace>)"
                 using 2 src_dom [of "\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
               also have "... = src \<lbrace>Dom v\<rbrace>"
                 using 4 VVV.arr_char VV.arr_char by simp
               also have "... = src (dom \<lbrace>v\<rbrace>)"
                 using v by fastforce
               also have "... = \<lbrace>Src v\<rbrace>"
                 using v by auto
               finally show ?thesis by auto
             qed
             show "trg (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Trg t\<rbrace>"
             proof -
               have "trg (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = trg ((\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace>)"
                 using 2 trg_dom [of "\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
               also have "... = trg \<lbrace>Dom t\<rbrace>"
                 using 4 VVV.arr_char VV.arr_char by simp
               also have "... = trg (dom \<lbrace>t\<rbrace>)"
                 using t by fastforce
               also have "... = \<lbrace>Trg t\<rbrace>"
                 using t by auto
               finally show ?thesis by auto
             qed
           qed
           show ?thesis using 2 3 by simp
         qed
       qed
       show "\<And>t u v.
             (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
             (Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Src u\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>) \<Longrightarrow>
             (Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>) \<Longrightarrow>
             Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow>
             \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright> \<and>
             \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
       proof (simp add: preserves_src preserves_trg)
         fix t u v
         assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Trg u\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
         assume u: "\<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Trg v\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
         assume v: "\<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
         assume tuv: "Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v"
         show "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
               \<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
                  \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> (\<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace>) \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
         proof -
           have 1: "VVV.in_hom (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)
                                 (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
             using t u v tuv VVV.hom_char VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char
             apply (elim conjE in_hhomE in_homE)
             apply (intro VVV.in_homI)
             by simp_all
           have 4: "VVV.arr (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
             using "1" VVV.in_hom_char by blast
           have 5: "VVV.arr (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
             using "1" VVV.in_hom_char by blast
           have 2: "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
                       \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> (\<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace>) \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
             using 1 4 5 HoHV_def HoVH_def \<alpha>'.map_def
                   \<alpha>'.preserves_hom [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
                                        "(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
             by simp
           have 3: "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>"
           proof
             show "arr (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
               using 2 by auto
             show "src (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Src v\<rbrace>"
             proof -
               have "src (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = src (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace>)"
                 using 2 src_dom [of "\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
               also have "... = src \<lbrace>Dom v\<rbrace>"
                 using 4 VVV.arr_char VV.arr_char by simp
               also have "... = src (dom \<lbrace>v\<rbrace>)"
                 using v by fastforce
               also have "... = \<lbrace>Src v\<rbrace>"
                 using v by auto
               finally show ?thesis by auto
             qed
             show "trg (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Trg t\<rbrace>"
             proof -
               have "trg (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = trg (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace>)"
                 using 2 trg_dom [of "\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
               also have "... = trg \<lbrace>Dom t\<rbrace>"
                 using 4 VVV.arr_char VV.arr_char hseqI' by simp
               also have "... = trg (dom \<lbrace>t\<rbrace>)"
                 using t by fastforce
               also have "... = \<lbrace>Trg t\<rbrace>"
                 using t by auto
               finally show ?thesis by auto
             qed
           qed
           show ?thesis using 2 3 by simp
         qed
       qed
     qed
 
     lemma eval_in_hom [intro]:
     assumes "Arr t"
     shows "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>" and "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
       using assms eval_in_hom' by simp_all
 
     (*
      * TODO: It seems to me that the natural useful orientation of these facts is syntax
      * to semantics.  However, having this as the default makes it impossible to do various
      * proofs by simp alone.  This has to be sorted out.  For right now, I am going to include
      * both versions, which will have to be explicitly invoked where needed.
      *)
     lemma eval_simps:
     assumes "Arr f"
     shows "arr \<lbrace>f\<rbrace>" and "\<lbrace>Src f\<rbrace> = src \<lbrace>f\<rbrace>" and "\<lbrace>Trg f\<rbrace> = trg \<lbrace>f\<rbrace>"
     and "\<lbrace>Dom f\<rbrace> = dom \<lbrace>f\<rbrace>" and "\<lbrace>Cod f\<rbrace> = cod \<lbrace>f\<rbrace>"
       using assms eval_in_hom [of f] by auto
 
     lemma eval_simps':
     assumes "Arr f"
     shows "arr \<lbrace>f\<rbrace>" and "src \<lbrace>f\<rbrace> = \<lbrace>Src f\<rbrace>" and "trg \<lbrace>f\<rbrace> = \<lbrace>Trg f\<rbrace>"
     and "dom \<lbrace>f\<rbrace> = \<lbrace>Dom f\<rbrace>" and "cod \<lbrace>f\<rbrace> = \<lbrace>Cod f\<rbrace>"
       using assms eval_in_hom by auto
 
     lemma obj_eval_Obj:
     shows "Obj t \<Longrightarrow> obj \<lbrace>t\<rbrace>"
       using preserves_obj
       by (induct t) auto
 
     lemma ide_eval_Ide:
     shows "Ide t \<Longrightarrow> ide \<lbrace>t\<rbrace>"
       by (induct t, auto simp add: eval_simps')
 
     lemma arr_eval_Arr [simp]:
     assumes "Arr t"
     shows "arr \<lbrace>t\<rbrace>"
       using assms by (simp add: eval_simps')
 
     (*
      * TODO: The next few results want eval_simps oriented from syntax to semantics.
      *)
 
     lemma eval_Lunit [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>Cod t\<rbrace>] \<cdot> (trg \<lbrace>t\<rbrace> \<star> \<lbrace>t\<rbrace>)"
       using assms \<ll>.is_natural_2 \<ll>_ide_simp by (simp add: eval_simps)
 
     lemma eval_Lunit' [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
       using assms \<ll>'.is_natural_2 \<ll>_ide_simp by (simp add: eval_simps)
 
     lemma eval_Runit [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> src \<lbrace>t\<rbrace>)"
       using assms \<rr>.is_natural_2 \<rr>_ide_simp by (simp add: eval_simps)
 
     lemma eval_Runit' [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
       using assms \<rr>'.is_natural_2 \<rr>_ide_simp by (simp add: eval_simps)
 
     lemma eval_Assoc [simp]:
     assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
     shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>)"
     proof -
       have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" by simp
       also have "... = \<alpha> (VVV.cod (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) \<cdot> HoHV (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
         using assms \<alpha>.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] VVV.arr_char VVV.cod_char
               \<alpha>.is_extensional \<alpha>_def
         by auto
       also have "... = \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>)"
         unfolding HoHV_def \<alpha>_def
         using assms VVV.arr_char VV.arr_char VVV.cod_char \<alpha>.is_extensional
         by auto
       finally show ?thesis by simp
     qed
 
     lemma eval_Assoc' [simp]:
     assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
     shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>)"
     proof -
       have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" by simp
       also have "... = \<alpha>'.map (VVV.cod (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) \<cdot> HoVH (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
         using assms \<alpha>'.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] VVV.arr_char VVV.cod_char
               \<alpha>'.is_extensional
         by simp
       also have "... = \<alpha>'.map (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>)"
         unfolding HoVH_def
         using assms VVV.arr_char VV.arr_char VVV.cod_char \<alpha>'.is_extensional
         apply simp
         using eval_simps'(2) eval_simps'(3) by presburger
       finally show ?thesis
         using \<a>'_def by simp
     qed
 
     lemma eval_Lunit_Ide [simp]:
     assumes "Ide t"
     shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>t\<rbrace>]"
       using assms \<ll>_ide_simp ide_eval_Ide by simp
 
     lemma eval_Lunit'_Ide [simp]:
     assumes "Ide t"
     shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>]"
       using assms \<ll>_ide_simp ide_eval_Ide by simp
 
     lemma eval_Runit_Ide [simp]:
     assumes "Ide t"
     shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
       using assms \<rr>_ide_simp ide_eval_Ide by simp
 
     lemma eval_Runit'_Ide [simp]:
     assumes "Ide t"
     shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>]"
       using assms \<rr>_ide_simp ide_eval_Ide by simp
 
     lemma eval_Assoc_Ide [simp]:
     assumes "Ide t" and "Ide u" and "Ide v" and "Src t = Trg u" and "Src u = Trg v"
     shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
       using assms by simp
 
     lemma eval_Assoc'_Ide [simp]:
     assumes "Ide t" and "Ide u" and "Ide v" and "Src t = Trg u" and "Src u = Trg v"
     shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>]"
       using assms \<a>'_def by simp
 
     lemma iso_eval_Can:
     shows "Can t \<Longrightarrow> iso \<lbrace>t\<rbrace>"
     proof (induct t; simp add: fsts.intros snds.intros)
       show "\<And>x. C.obj x \<Longrightarrow> iso (E x)" by auto
       show "\<And>t1 t2. \<lbrakk> iso \<lbrace>t1\<rbrace>; iso \<lbrace>t2\<rbrace>; Can t1 \<and> Can t2 \<and> Src t1 = Trg t2 \<rbrakk> \<Longrightarrow>
                       iso (\<lbrace>t1\<rbrace> \<star> \<lbrace>t2\<rbrace>)"
         using Can_implies_Arr by (simp add: eval_simps')
       show "\<And>t1 t2. \<lbrakk> iso \<lbrace>t1\<rbrace>; iso \<lbrace>t2\<rbrace>; Can t1 \<and> Can t2 \<and> Dom t1 = Cod t2 \<rbrakk> \<Longrightarrow>
                       iso (\<lbrace>t1\<rbrace> \<cdot> \<lbrace>t2\<rbrace>)"
         using Can_implies_Arr isos_compose by (simp add: eval_simps')
       show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<ll> \<lbrace>t\<rbrace>)"
         using \<ll>.preserves_iso by auto
       show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<ll>'.map \<lbrace>t\<rbrace>)"
         using \<ll>'.preserves_iso by simp
       show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<rr> \<lbrace>t\<rbrace>)"
         using \<rr>.preserves_iso by auto
       show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<rr>'.map \<lbrace>t\<rbrace>)"
         using \<rr>'.preserves_iso by simp
       fix t1 t2 t3
       assume t1: "iso \<lbrace>t1\<rbrace>" and t2: "iso \<lbrace>t2\<rbrace>" and t3: "iso \<lbrace>t3\<rbrace>"
       assume 1: "Can t1 \<and> Can t2 \<and> Can t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3"
       have 2: "VVV.iso (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>)"
       proof -
         have 3: "VxVxV.iso (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>)"
           using t1 t2 t3 Can_implies_Arr VxVxV.iso_char VxV.iso_char by simp
         moreover have "VVV.arr (VxVxV.inv (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
         proof -
           have "VxVxV.inv (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>) = (inv \<lbrace>t1\<rbrace>, inv \<lbrace>t2\<rbrace>, inv \<lbrace>t3\<rbrace>)"
             using t1 t2 t3 3 by simp
           thus ?thesis
             using t1 t2 t3 1 Can_implies_Arr VVV.arr_char VV.arr_char
             by (simp add: eval_simps')
         qed
         ultimately show ?thesis
           using t1 t2 t3 1 Can_implies_Arr VVV.iso_char VVV.arr_char
           by (auto simp add: eval_simps')
       qed
       show "iso (\<alpha> (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
         using 2 \<alpha>_def \<alpha>.preserves_iso by auto
       show "iso (\<alpha>'.map (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
         using 2 \<alpha>'.preserves_iso by simp
     qed
 
     lemma eval_Inv_Can:
     shows "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
     proof (induct t)
       show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<lbrace>Inv \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> = inv \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>" by auto
       show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow> \<lbrace>Inv \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> = inv \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>" by simp
       show "\<And>t1 t2. (Can t1 \<Longrightarrow> \<lbrace>Inv t1\<rbrace> = inv \<lbrace>t1\<rbrace>) \<Longrightarrow>
                     (Can t2 \<Longrightarrow> \<lbrace>Inv t2\<rbrace> = inv \<lbrace>t2\<rbrace>) \<Longrightarrow>
                      Can (t1 \<^bold>\<star> t2) \<Longrightarrow> \<lbrace>Inv (t1 \<^bold>\<star> t2)\<rbrace> = inv \<lbrace>t1 \<^bold>\<star> t2\<rbrace>"
         using iso_eval_Can Can_implies_Arr
         by (simp add: eval_simps')
       show "\<And>t1 t2. (Can t1 \<Longrightarrow> \<lbrace>Inv t1\<rbrace> = inv \<lbrace>t1\<rbrace>) \<Longrightarrow>
                     (Can t2 \<Longrightarrow> \<lbrace>Inv t2\<rbrace> = inv \<lbrace>t2\<rbrace>) \<Longrightarrow>
                      Can (t1 \<^bold>\<cdot> t2) \<Longrightarrow> \<lbrace>Inv (t1 \<^bold>\<cdot> t2)\<rbrace> = inv \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
         using iso_eval_Can inv_comp Can_implies_Arr
         by (simp add: eval_simps')
       fix t
       assume I: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
       show "Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
       proof -
         assume t: "Can \<^bold>\<l>\<^bold>[t\<^bold>]"
         have "\<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]\<rbrace>" by simp
         also have "... = \<ll>'.map (inv \<lbrace>t\<rbrace>)"
           using t I by simp
         also have "... = \<ll>'.map (cod (inv \<lbrace>t\<rbrace>)) \<cdot> inv \<lbrace>t\<rbrace>"
           using t \<ll>'.is_natural_2 iso_inv_iso iso_eval_Can iso_is_arr
           by (metis (no_types, lifting) Can.simps(5) map_simp)
         also have "... = inv (\<lbrace>t\<rbrace> \<cdot> \<ll> (dom \<lbrace>t\<rbrace>))"
         proof -
           have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
           moreover have "iso (\<ll> (dom \<lbrace>t\<rbrace>))"
             using t 1 \<ll>.components_are_iso ide_dom by blast
           moreover have "seq \<lbrace>t\<rbrace> (\<ll> (dom \<lbrace>t\<rbrace>))"
             using t 1 iso_is_arr by auto
           ultimately show ?thesis
             using t 1 inv_comp by auto
         qed
         also have "... = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
           using t iso_eval_Can \<ll>_ide_simp lunit_naturality Can_implies_Arr eval_Lunit
           by (auto simp add: eval_simps)
         finally show ?thesis by blast
       qed
       show "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
       proof -
         assume t: "Can (Lunit' t)"
         have "\<lbrace>Inv (Lunit' t)\<rbrace> = \<lbrace>Lunit (Inv t)\<rbrace>" by simp
         also have "... = \<ll> (inv \<lbrace>t\<rbrace>)"
           using t I by simp
         also have "... = inv \<lbrace>t\<rbrace> \<cdot> \<ll> (dom (inv \<lbrace>t\<rbrace>))"
           using t \<ll>.is_natural_1 iso_inv_iso iso_eval_Can iso_is_arr
           by (metis (no_types, lifting) Can.simps(6) map_simp)
         also have "... = inv (\<ll>'.map (cod \<lbrace>t\<rbrace>) \<cdot> \<lbrace>t\<rbrace>)"
         proof -
           have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
           moreover have "iso (\<ll>'.map (cod \<lbrace>t\<rbrace>))"
             using t 1 \<ll>'.components_are_iso ide_cod by blast
           moreover have "seq (\<ll>'.map (cod \<lbrace>t\<rbrace>)) \<lbrace>t\<rbrace>"
             using t 1 iso_is_arr by auto
           ultimately show ?thesis
             using t 1 inv_comp by auto
         qed
         also have "... = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
           using t \<ll>'.is_natural_2 iso_eval_Can iso_is_arr by force
         finally show ?thesis by auto
       qed
       show "Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
       proof -
         assume t: "Can \<^bold>\<r>\<^bold>[t\<^bold>]"
         have "\<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]\<rbrace>" by simp
         also have "... = \<rr>'.map (inv \<lbrace>t\<rbrace>)"
           using t I by simp
         also have "... = \<rr>'.map (cod (inv \<lbrace>t\<rbrace>)) \<cdot> inv \<lbrace>t\<rbrace>"
           using t \<rr>'.is_natural_2 map_simp iso_inv_iso iso_eval_Can iso_is_arr
           by (metis (no_types, lifting) Can.simps(7))
         also have "... = inv (\<lbrace>t\<rbrace> \<cdot> \<rr> (dom \<lbrace>t\<rbrace>))"
         proof -
           have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
           moreover have "iso (\<rr> (dom \<lbrace>t\<rbrace>))"
             using t 1 \<rr>.components_are_iso ide_dom by blast
           moreover have "seq \<lbrace>t\<rbrace> (\<rr> (dom \<lbrace>t\<rbrace>))"
             using t 1 iso_is_arr by simp
           ultimately show ?thesis
             using t 1 inv_comp by auto
         qed
         also have "... = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
           using t \<rr>_ide_simp iso_eval_Can runit_naturality Can_implies_Arr eval_Runit
           by (auto simp add: eval_simps)
         finally show ?thesis by blast
       qed
       show "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
       proof -
         assume t: "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         have "\<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^bold>[Inv t\<^bold>]\<rbrace>"
           by simp
         also have "... = \<rr> (inv \<lbrace>t\<rbrace>)"
           using t I by simp
         also have "... = inv \<lbrace>t\<rbrace> \<cdot> \<rr> (dom (inv \<lbrace>t\<rbrace>))"
           using t \<rr>.is_natural_1 map_simp iso_inv_iso iso_eval_Can iso_is_arr
           by (metis (no_types, lifting) Can.simps(8))
         also have "... = inv (\<rr>'.map (cod \<lbrace>t\<rbrace>) \<cdot> \<lbrace>t\<rbrace>)"
         proof -
           have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
           moreover have "iso (\<rr>'.map (cod \<lbrace>t\<rbrace>))"
             using t 1 \<rr>'.components_are_iso ide_cod by blast
           moreover have "seq (\<rr>'.map (cod \<lbrace>t\<rbrace>)) \<lbrace>t\<rbrace>"
             using t 1 iso_is_arr by auto
           ultimately show ?thesis
             using t 1 inv_comp by auto
         qed
         also have "... = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
           using t \<rr>'.is_natural_2 iso_eval_Can iso_is_arr by auto
         finally show ?thesis by auto
       qed
       next
       fix t u v
       assume I1: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
       assume I2: "Can u \<Longrightarrow> \<lbrace>Inv u\<rbrace> = inv \<lbrace>u\<rbrace>"
       assume I3: "Can v \<Longrightarrow> \<lbrace>Inv v\<rbrace> = inv \<lbrace>v\<rbrace>"
       show "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
       proof -
         assume "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
         hence tuv: "Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v" by simp
         have "\<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]\<rbrace>" by simp
         also have "... = \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] \<cdot> (inv \<lbrace>t\<rbrace> \<star> inv \<lbrace>u\<rbrace> \<star> inv \<lbrace>v\<rbrace>)"
           using tuv I1 I2 I3 eval_in_hom \<alpha>'.map_ide_simp inv_in_hom iso_eval_Can assoc'_naturality
                 Can_implies_Arr Src_Inv Trg_Inv eval_Assoc' Dom_Inv Can_Inv cod_inv
           by presburger
         also have "... = inv ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>) \<cdot> \<alpha> (dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>))"
           using tuv iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3) \<alpha>_def
           by (simp add: inv_comp)
         also have "... = inv (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
           using tuv Can_implies_Arr \<alpha>_def
           by (metis assoc_is_natural_1 arr_eval_Arr eval_simps'(2) eval_simps'(3) fst_conv snd_conv)
         also have "... = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>" by simp
         finally show ?thesis by blast
       qed
       show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
       proof -
         assume tuv: "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
         have t: "Can t" using tuv by simp
         have u: "Can u" using tuv by simp
         have v: "Can v" using tuv by simp
         have "\<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]\<rbrace>" by simp
         also have "... = (inv \<lbrace>t\<rbrace> \<star> inv \<lbrace>u\<rbrace> \<star> inv \<lbrace>v\<rbrace>) \<cdot> \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>)"
           using \<alpha>_def tuv I1 I2 I3 iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3)
           apply simp
           using assoc_is_natural_1 arr_inv dom_inv src_inv trg_inv by presburger
         also have "... = inv (\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>))"
           using tuv inv_comp [of "\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>" "\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>]"]
                 Can_implies_Arr iso_assoc \<alpha>_def
           by (simp add: eval_simps'(2) eval_simps'(3) iso_eval_Can)
         also have 1: "... = inv (((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
           using tuv assoc'_naturality [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] Can_implies_Arr
                 eval_simps'(2) eval_simps'(3)
           by simp
         also have "... = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
           using tuv 1 Can_implies_Arr eval_Assoc' by auto
         finally show ?thesis by blast
       qed
     qed
 
     lemma eval_VcompNml:
     assumes "Nml t" and "Nml u" and "VSeq t u"
     shows "\<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
     proof -
       have "\<And>u. \<lbrakk> Nml t; Nml u; VSeq t u \<rbrakk> \<Longrightarrow> \<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
       proof (induct t, simp_all add: eval_simps)
         fix u a
         assume u: "Nml u"
         assume 1: "Arr u \<and> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = Cod u"
         show "\<lbrace>u\<rbrace> = cod \<lbrace>u\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
           using 1 comp_cod_arr by simp
         next
         fix u f
         assume u: "Nml u"
         assume f: "C.arr f"
         assume 1: "Arr u \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
         show "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = E f \<cdot> \<lbrace>u\<rbrace>"
           using f u 1 as_nat_trans.preserves_comp_2 by (cases u; simp)
         next
         fix u v w
         assume I1: "\<And>u. \<lbrakk> Nml v; Nml u; Arr u \<and> Dom v = Cod u \<rbrakk> \<Longrightarrow> \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>v\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         assume I2: "\<And>u. \<lbrakk> Nml w; Nml u; Arr u \<and> Dom w = Cod u \<rbrakk> \<Longrightarrow> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>w\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         assume vw: "Nml (v \<^bold>\<star> w)"
         have v: "Nml v \<and> v = Prim (un_Prim v)"
           using vw by (simp add: Nml_HcompD)
         have w: "Nml w"
           using vw by (simp add: Nml_HcompD)
         assume u: "Nml u"
         assume 1: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Arr u \<and> Dom v \<^bold>\<star> Dom w = Cod u"
         show "\<lbrace>(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
           using u 1 HcompNml_in_Hom apply (cases u, simp_all)
         proof -
           fix x y
           assume 3: "u = x \<^bold>\<star> y"
           have x: "Nml x"
-            using u 1 3 Nml_HcompD by simp
+            using u 1 3 Nml_HcompD by blast
           have y: "Nml y"
-            using u x 1 3 Nml_HcompD by simp
+            using u x 1 3 Nml_HcompD by blast
           assume 4: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Dom v = Cod x \<and> Dom w = Cod y"
           have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
             using v w x y 4 HcompNml_in_Hom by simp
           moreover have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>" by simp
           moreover have "... = \<lbrace>v\<rbrace> \<cdot> \<lbrace>x\<rbrace> \<star> \<lbrace>w\<rbrace> \<cdot> \<lbrace>y\<rbrace>"
             using v w x y 4 I1 [of x] I2 [of y] Nml_implies_Arr by simp
           moreover have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
             using v w x y 4 Nml_implies_Arr interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>x\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>y\<rbrace>"]
             by (simp add: eval_simps')
           ultimately have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)" by presburger
           moreover have "arr \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<and> arr \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
             using v w x y 4 VcompNml_in_Hom by simp
           ultimately show "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
             by simp
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma eval_red_Hcomp:
     assumes "Ide a" and "Ide b"
     shows "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
     proof -
       have "Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
       proof -
         assume 1: "Nml (a \<^bold>\<star> b)"
         hence 2: "Nml a \<and> Nml b \<and> Src a = Trg b"
           using Nml_HcompD(3-4,7) by simp
         have "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>"
-          using 1 Nml_HcompD by simp
+          using 1 Nml_HcompD
+          by (metis eval.simps(3) red_Nml)
         also have "... = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
           using assms 1 2 ide_eval_Ide Nmlize_in_Hom red2_Nml Nmlize_Nml
           by (simp add: eval_simps')
         finally show ?thesis by simp
       qed
       moreover have "\<not> Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
         using assms Can_red2 by (simp add: Can_red(1) iso_eval_Can)
       ultimately show ?thesis by blast
     qed
 
     (* TODO: Would the following still be useful if \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 is replaced by Src t? *)
     lemma eval_red2_Nml_Prim\<^sub>0:
     assumes "Ide t" and "Nml t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
     shows "\<lbrace>t \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
       using assms \<rr>_ide_simp
       apply (cases t)
                apply simp_all
     proof -
       show "C.obj a \<Longrightarrow> t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<ll> (E a) = \<r>[E a]"
         using unitor_coincidence obj_eval_Obj [of t] \<ll>_ide_simp by auto
       show "\<And>b c. Ide b \<and> Ide c \<and> Src b = Trg c \<Longrightarrow> \<rr> (\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<r>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]"
         using \<rr>_ide_simp by (simp add: eval_simps' ide_eval_Ide)
     qed
 
   end
 
   text \<open>
     Most of the time when we interpret the @{locale evaluation_map} locale, we are evaluating
     terms formed from the arrows in a bicategory as arrows of the bicategory itself.
     The following locale streamlines that use case.
   \<close>
 
   locale self_evaluation_map =
     bicategory
   begin
 
     sublocale bicategorical_language V src trg ..
 
     sublocale evaluation_map V src trg V H \<a> \<i> src trg \<open>\<lambda>\<mu>. if arr \<mu> then \<mu> else null\<close>
       using src.is_extensional trg.is_extensional
       by (unfold_locales, auto)
 
     notation eval ("\<lbrace>_\<rbrace>")
     notation Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
 
   end
 
   subsection "Coherence"
 
   text \<open>
     We define an individual term to be \emph{coherent} if it commutes, up to evaluation,
     with the reductions of its domain and codomain.  We then formulate the coherence theorem
     as the statement ``every formal arrow is coherent''.  Because reductions evaluate
     to isomorphisms, this implies the standard version of coherence, which says that
     ``parallel canonical terms have equal evaluations''.
   \<close>
 
   context evaluation_map
   begin
 
     abbreviation coherent
     where "coherent t \<equiv> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
 
     lemma Nml_implies_coherent:
     assumes "Nml t"
     shows "coherent t"
       using assms Nml_implies_Arr Ide_Dom Ide_Cod Nml_Dom Nml_Cod Nmlize_Nml red_Nml
       by (metis Dom_Cod VcompNml_Cod_Nml arr_eval_Arr comp_arr_dom eval_VcompNml
           eval_simps(4))
 
     lemma canonical_factorization:
     assumes "Arr t"
     shows "coherent t \<longleftrightarrow> \<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
     proof
       assume 1: "coherent t"
       have "inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>"
         using 1 by simp
       also have "... = (inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>t\<rbrace>"
         using comp_assoc by simp
       also have "... = \<lbrace>t\<rbrace>"
         using assms red_in_Hom Ide_Cod Can_red iso_eval_Can comp_cod_arr
         by (simp add: comp_inv_arr' eval_simps'(4) eval_simps'(5))
       finally show "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
         by presburger
       next
       assume 1: "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
       hence "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
       also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
       proof -
         have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> = cod \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
           using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
                 inv_is_inverse Nmlize_in_Hom comp_arr_inv
           by (simp add: eval_simps')
         thus ?thesis
           using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
                 Ide_Dom Nmlize_in_Hom comp_cod_arr
           by (auto simp add: eval_simps')
       qed
       finally show "coherent t" by blast
     qed
 
     lemma coherent_iff_coherent_Inv:
     assumes "Can t"
     shows "coherent t \<longleftrightarrow> coherent (Inv t)"
     proof
       have 1: "\<And>t. Can t \<Longrightarrow> coherent t \<Longrightarrow> coherent (Inv t)"
       proof -
         fix t
         assume "Can t"
         hence t: "Can t \<and> Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and>
                   arr \<lbrace>t\<rbrace> \<and> iso \<lbrace>t\<rbrace> \<and> inverse_arrows \<lbrace>t\<rbrace> (inv \<lbrace>t\<rbrace>) \<and>
                   Can \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Arr \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> arr \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> iso \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                   inverse_arrows \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<and> Inv t \<in> VHom (Cod t) (Dom t)"
           using assms Can_implies_Arr Ide_Dom Ide_Cod iso_eval_Can inv_is_inverse
                 Nmlize_in_Hom Can_Nmlize_Can Inv_in_Hom
           by simp
         assume coh: "coherent t"
         have "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace> = (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<cdot> \<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>"
           using t comp_inv_arr red_in_Hom
                 comp_cod_arr [of "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>" "inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"]
           by (auto simp add: eval_simps')
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
           using t eval_Inv_Can comp_assoc by auto
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
           using comp_assoc by simp
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
           using t coh by simp
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
           using comp_assoc by simp
         also have "... = \<lbrace>\<^bold>\<lfloor>Inv t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
         proof -
           have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace> = \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
             using t eval_Inv_Can red_in_Hom comp_arr_inv comp_arr_dom
             by (simp add: eval_simps')
           thus ?thesis
             using t Nmlize_Inv eval_Inv_Can by simp
         qed
         finally show "coherent (Inv t)" by blast
       qed
       show "coherent t \<Longrightarrow> coherent (Inv t)" using assms 1 by simp
       show "coherent (Inv t) \<Longrightarrow> coherent t"
       proof -
         assume "coherent (Inv t)"
         hence "coherent (Inv (Inv t))"
           using assms 1 Can_Inv by blast
         thus ?thesis using assms by simp
       qed
     qed
 
     text \<open>
       The next two facts are trivially proved by the simplifier, so formal named facts
       are not really necessary, but we include them for logical completeness of the
       following development, which proves coherence by structural induction.
     \<close>
 
     lemma coherent_Prim\<^sub>0:
     assumes "C.obj a"
     shows "coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
       by simp
 
     lemma coherent_Prim:
     assumes "Arr \<^bold>\<langle>f\<^bold>\<rangle>"
     shows "coherent \<^bold>\<langle>f\<^bold>\<rangle>"
       using assms by simp
 
     lemma coherent_Lunit_Ide:
     assumes "Ide t"
     shows "coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
     proof -
       have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
                ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_in_Hom Ide_Nmlize_Ide
               red_in_Hom eval_in_hom ide_eval_Ide
         by force
       have 1: "Obj (Trg t)" using t by auto
       have "\<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
         using t \<ll>_ide_simp lunit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"] red_in_Hom
         by (simp add: eval_simps')
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
          using t 1 lunit_in_hom Nmlize_in_Hom ide_eval_Ide red_in_Hom comp_cod_arr
                Obj_implies_Ide
          by (auto simp add: eval_simps')
       also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace>"
         using 1 t Nml_Trg \<ll>_ide_simp by (cases "Trg t"; simp)
       finally show ?thesis by simp
     qed
       
     text \<open>
       Unlike many of the other results, the next one was not quite so straightforward to adapt
       from @{session \<open>MonoidalCategory\<close>}.
     \<close>
 
     lemma coherent_Runit_Ide:
     assumes "Ide t"
     shows "coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
     proof -
       have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
                ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_in_Hom Ide_Nmlize_Ide
               red_in_Hom eval_in_hom ide_eval_Ide
         by force
       have "\<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
         using t \<rr>_ide_simp red_in_Hom runit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"]
         by (simp add: eval_simps')
       also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace>"
       proof -
          have "\<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
            using t by (cases t; simp; cases "Src t"; simp)
          also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
          proof -
            have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<in> hom \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
              using t Nmlize_in_Hom by auto
            moreover have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<in> hom (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>) \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
            proof -
              have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<in> hom \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
              proof -
                have "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>Src t\<^bold>\<rfloor> \<and> \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
                  using t Nmlize_Src Nml_Nmlize HcompNml_Nml_Src [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"]
                  by simp
                thus ?thesis
                  using t Ide_Nmlize_Ide Nml_Nmlize Obj_Src red2_in_Hom(2) Obj_implies_Ide
                  by (auto simp add: eval_simps')
              qed
              thus ?thesis using t Nmlize_in_Hom Nmlize_Src by simp
            qed
            moreover have "\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace> \<in> hom (\<lbrace>t\<rbrace> \<star> \<lbrace>Src t\<rbrace>) (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
              using t red_in_Hom red_Src Obj_Src eval_simps' Obj_implies_Ide by auto
            ultimately show ?thesis using comp_assoc by fastforce
          qed
          also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
          proof -
            have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>]"
            proof -
              have "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" using t Nml_Nmlize by blast
              moreover have "is_Prim\<^sub>0 \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
                using t is_Prim0_Src Nmlize_Src by presburger
              ultimately show ?thesis
                apply (cases "\<^bold>\<lfloor>t\<^bold>\<rfloor>"; simp; cases "\<^bold>\<lfloor>Src t\<^bold>\<rfloor>"; simp)
                using t unitor_coincidence \<ll>_ide_simp \<rr>_ide_simp Nmlize_in_Hom
                  apply simp_all
                using t is_Prim0_Src
                apply (cases "\<^bold>\<lfloor>t\<^bold>\<rfloor>"; simp)
                using t Nmlize_Src unitor_coincidence preserves_obj by simp
            qed
            moreover have "\<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<in> hom (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>) \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
              using t Nmlize_in_Hom by (auto simp add: eval_simps'(2))
            ultimately show ?thesis
              using comp_cod_arr [of "\<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>]"] by fastforce
          qed
          also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
            using t red_Src by auto
          finally show ?thesis by argo
       qed
       finally show ?thesis by blast
     qed
 
     lemma coherent_Lunit'_Ide:
     assumes "Ide a"
     shows "coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
       using assms Ide_implies_Can coherent_Lunit_Ide
             coherent_iff_coherent_Inv [of "Lunit a"]
       by simp
 
     lemma coherent_Runit'_Ide:
     assumes "Ide a"
     shows "coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
       using assms Ide_implies_Can coherent_Runit_Ide
             coherent_iff_coherent_Inv [of "Runit a"]
       by simp
 
     lemma red2_Nml_Src:
     assumes "Ide t" and "Nml t"
     shows "\<lbrace>t \<^bold>\<Down> Src t\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
       using assms eval_red2_Nml_Prim\<^sub>0 is_Prim0_Src [of t]
       by (cases "Src t"; simp)
 
     lemma red2_Trg_Nml:
     assumes "Ide t" and "Nml t"
     shows "\<lbrace>Trg t \<^bold>\<Down> t\<rbrace> = \<l>[\<lbrace>t\<rbrace>]"
       using assms is_Prim0_Trg [of t] \<ll>_ide_simp ide_eval_Ide
       by (cases "Trg t"; simp)
 
     lemma coherence_key_fact:
     assumes "Ide a \<and> Nml a" and "Ide b \<and> Nml b" and "Ide c \<and> Nml c"
     and "Src a = Trg b" and "Src b = Trg c"
     shows "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
            (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
     proof -
       have "is_Prim\<^sub>0 b \<Longrightarrow> ?thesis"
       proof -
         assume b: "is_Prim\<^sub>0 b"
         have "\<lbrace>a \<^bold>\<Down> c\<rbrace> \<cdot> (\<r>[\<lbrace>a\<rbrace>] \<star> \<lbrace>c\<rbrace>) = (\<lbrace>a \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<l>[\<lbrace>c\<rbrace>])) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>Trg c\<rbrace>, \<lbrace>c\<rbrace>]"
         proof -
           have "Src b = Trg b"
             using b by (cases b; simp)
           thus ?thesis
             using assms triangle [of "\<lbrace>c\<rbrace>" "\<lbrace>a\<rbrace>"] ide_eval_Ide comp_assoc
             by (simp add: eval_simps')
         qed
         thus ?thesis
           using assms b HcompNml_Nml_Src [of a] HcompNml_Trg_Nml red2_Nml_Src [of a]
                 red2_Trg_Nml
           by (cases b, simp_all)
       qed
       moreover have "\<lbrakk> \<not> is_Prim\<^sub>0 b; is_Prim\<^sub>0 c \<rbrakk> \<Longrightarrow> ?thesis"
       proof -
         assume b: "\<not> is_Prim\<^sub>0 b"
         assume c: "is_Prim\<^sub>0 c"
         have "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> Src b\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> src \<lbrace>b\<rbrace>)"
           using assms b c by (cases c, simp_all add: eval_simps')
         also have "... = \<r>[\<lbrace>a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>] \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> src \<lbrace>b\<rbrace>)"
           using assms red2_Nml_Src [of "a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b"] Nml_HcompNml(1) Src_HcompNml Ide_HcompNml
           by simp
         also have "... = \<lbrace>a \<^bold>\<Down> b\<rbrace> \<cdot> \<r>[\<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>]"
         proof -
           have "\<guillemotleft>\<lbrace>a \<^bold>\<Down> b\<rbrace> : \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace> \<Rightarrow> \<lbrace>a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>\<guillemotright>"
             using assms red2_in_Hom eval_in_hom [of "a \<^bold>\<Down> b"] by simp
           thus ?thesis
             using assms runit_naturality [of "\<lbrace>a \<^bold>\<Down> b\<rbrace>"] arr_dom in_homE src_dom src_hcomp
                   hcomp_simps(1)
             by (elim in_homE, metis)
         qed
         also have "... = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
         proof -
           have "(\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] =
                              (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<r>[\<lbrace>b\<rbrace>])) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, src \<lbrace>b\<rbrace>]"
             using assms c red2_Nml_Src [of b]
             by (cases c, simp_all add: eval_simps')
           thus ?thesis
             using assms runit_hcomp ide_eval_Ide comp_assoc
             by (simp add: eval_simps')
         qed
         finally show ?thesis by blast
       qed
       moreover have "\<lbrakk> \<not> is_Prim\<^sub>0 b; \<not> is_Prim\<^sub>0 c \<rbrakk> \<Longrightarrow> ?thesis"
       proof -
         assume b': "\<not> is_Prim\<^sub>0 b"
         hence b: "Ide b \<and> Nml b \<and> Arr b \<and> \<not> is_Prim\<^sub>0 b \<and>
                   ide \<lbrace>b\<rbrace> \<and> arr \<lbrace>b\<rbrace> \<and> \<^bold>\<lfloor>b\<^bold>\<rfloor> = b \<and> b\<^bold>\<down> = b \<and> Dom b = b \<and> Cod b = b"
           using assms Ide_Nmlize_Ide Ide_in_Hom ide_eval_Ide by simp
         assume c': "\<not> is_Prim\<^sub>0 c"
         hence c: "Ide c \<and> Nml c \<and> Arr c \<and> \<not> is_Prim\<^sub>0 c \<and>
                   ide \<lbrace>c\<rbrace> \<and> arr \<lbrace>c\<rbrace> \<and> \<^bold>\<lfloor>c\<^bold>\<rfloor> = c \<and> c\<^bold>\<down> = c \<and> Dom c = c \<and> Cod c = c"
           using assms Ide_Nmlize_Ide Ide_in_Hom ide_eval_Ide by simp
         have "\<And>a. Ide a \<and> Nml a \<and> Src a = Trg b \<Longrightarrow>
                    \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
                       = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
         proof -
           fix a :: "'c term"
           show "Ide a \<and> Nml a \<and> Src a = Trg b \<Longrightarrow>
                 \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
                    = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             apply (induct a)
             using b c HcompNml_in_Hom
                      apply (simp_all add: HcompNml_Nml_Src HcompNml_Trg_Nml)
           proof -
             fix f
             assume f: "C.ide f \<and> C.arr f \<and> \<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0 = Trg b"
             show "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
                     (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             proof -
               have "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
                       ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                       ((E f \<star> \<lbrace>b\<rbrace>) \<star> \<lbrace>c\<rbrace>)"
               proof -
                 have "((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                       ((E f \<star> \<lbrace>b\<rbrace>) \<star> \<lbrace>c\<rbrace>) =
                       ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                       (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
                   using f b red2_Nml by simp
                 also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                                  (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
                 proof -
                   have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> = E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>"
                     using assms(5) b c is_Hcomp_HcompNml red2_Nml Nml_HcompNml(1)
                           is_Hcomp_def
                     by (metis eval.simps(2) eval.simps(3) red2.simps(4))
                   thus ?thesis by argo
                 qed
                 also have "... = \<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
                   using b c \<alpha>_def by (cases c, simp_all)
                 finally show ?thesis by argo
               qed
               also have "... = ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
               proof -
                 have "src (E f) = trg \<lbrace>b\<rbrace>"
                   using b f preserves_src
                   by (cases "Trg b", auto simp add: eval_simps')
                 thus ?thesis
                   using assms b c f comp_arr_dom comp_assoc
                   by (auto simp add: eval_simps')
               qed
               also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using assms f b c Ide_HcompNml Nml_HcompNml is_Hcomp_HcompNml [of b c] \<alpha>_def
                 by (cases "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c") simp_all
               finally show ?thesis by blast
             qed
             next
             fix x
             assume x: "C.obj x \<and> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg b"
             show "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>Trg b \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
                   (\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             proof -
               have 1: "Trg (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c) = Trg b"
                 using assms b c Trg_HcompNml by blast
               have 2: "\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> = \<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]"
                 using assms b c 1 Nml_HcompNml red2_Trg_Nml [of "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c"] Ide_HcompNml
                 by simp
               have "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>Trg b \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<l>[\<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
                 using b c 1 2 HcompNml_Trg_Nml red2_Trg_Nml Trg_HcompNml by simp
               also have "... = \<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using assms b c lunit_hcomp [of "\<lbrace>b\<rbrace>" "\<lbrace>c\<rbrace>"]
                 by (metis (no_types, lifting) eval_simps'(3) eval_simps(2))
               also have "... = (\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using comp_assoc by simp
               also have "... = (\<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>] \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using assms b c lunit_naturality [of "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] red2_in_Hom
                 by (simp add: eval_simps')
               also have "... = (\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using b c 1 2 HcompNml_Trg_Nml red2_Trg_Nml Trg_HcompNml comp_assoc
                 by simp
               finally show ?thesis
                 by blast
             qed
             next
             fix d e
             assume I: "Nml e \<Longrightarrow> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
                                     = (\<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             assume de: "Ide d \<and> Ide e \<and> Src d = Trg e \<and> Nml (d \<^bold>\<star> e) \<and> Src e = Trg b"
             show "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
                     = (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             proof -
               let ?f = "un_Prim d"
               have "is_Prim d"
                 using de Nml_HcompD
                 by (metis term.disc(12))
               hence "d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f"
                 using de by (cases d; simp)
               hence d: "Ide d \<and> Arr d \<and> Dom d = d \<and> Cod d = d \<and> Nml d \<and>
                         d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f \<and> ide \<lbrace>d\<rbrace> \<and> arr \<lbrace>d\<rbrace>"
                 using de ide_eval_Ide Nml_Nmlize(1) Ide_in_Hom Nml_HcompD [of d e]
                 by simp
               have "Nml e \<and> \<not> is_Prim\<^sub>0 e"
                 using de Nml_HcompD by metis
               hence e: "Ide e \<and> Arr e \<and> Dom e = e \<and> Cod e = e \<and> Nml e \<and>
                         \<not> is_Prim\<^sub>0 e \<and> ide \<lbrace>e\<rbrace> \<and> arr \<lbrace>e\<rbrace>"
                 using de Ide_in_Hom ide_eval_Ide by simp
               have 1: "is_Hcomp (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<and> is_Hcomp (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c) \<and> is_Hcomp (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)"
                 using assms b c e de is_Hcomp_HcompNml [of e b] Nml_HcompNml
                       is_Hcomp_HcompNml [of b c] is_Hcomp_HcompNml [of e "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c"]
                 by auto
               have eb: "Src e = Trg b"
                 using assms b c e de by argo
               have bc: "Src b = Trg c"
                 using assms b c by simp
               have 4: "is_Hcomp ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)"
                 using assms b c e eb de 1 is_Hcomp_HcompNml [of e b]
                       is_Hcomp_HcompNml [of "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b" c] is_Hcomp_HcompNml [of e b]
                       Nml_HcompNml(1) [of e b] Src_HcompNml
                 by auto
               have "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
                       = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
                          \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                         ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
               proof -
                 have "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>
                          = (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
                            \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
                 proof -
                   have "((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<Down> c"
                     using b c d e de 1 HcompNml_Nml Nml_HcompNml HcompNml_assoc
                           HcompNml_Prim
                     by (metis term.distinct_disc(4))
                   also have "... = (d \<^bold>\<Down> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b, c\<^bold>]"
                     using b c d e de 1 Nml_HcompNml Nmlize_Nml
                     by (cases c) simp_all
                   also have "... = (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b, c\<^bold>]"
                     using d 4
                     apply (cases d, simp_all)
                     by (cases "(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c") simp_all
                   finally show ?thesis
                     using b c d e HcompNml_in_Hom red2_in_Hom
                           Nml_HcompNml Ide_HcompNml \<alpha>_def
                     by simp
                 qed
                 moreover have "\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace>
                                  = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]"
                 proof -
                   have "(d \<^bold>\<star> e) \<^bold>\<Down> b = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
                       using b c d e de 1 HcompNml_Prim Nmlize_Nml
                       by (cases b, simp_all)
                   also have "... = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
                     using b c d e de 1 HcompNml_Nml Nml_HcompNml
                     apply (cases d, simp_all)
                     by (cases "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b", simp_all)
                   finally show ?thesis
                     using b d e HcompNml_in_Hom red2_in_Hom \<alpha>_def by simp
                 qed
                 ultimately show ?thesis by argo
               qed
               also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                                ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
               proof -
                 have "(\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>
                         = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
                   using assms b c d e de eb HcompNml_in_Hom red2_in_Hom comp_cod_arr
                         Ide_HcompNml Nml_HcompNml comp_assoc
                         interchange [of "\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]" "\<lbrace>c\<rbrace>" "\<lbrace>c\<rbrace>"]
                   by (auto simp add: eval_simps')
                 moreover have "(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
                                  \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] =
                                (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
                 proof -
                   have "(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
                                    \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] =
                                    ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                    \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
                     using comp_assoc by simp
                   thus ?thesis
                     using assms b c d e de eb HcompNml_in_Hom red2_in_Hom
                           Ide_HcompNml Nml_HcompNml comp_cod_arr
                     by (simp add: eval_simps')
                 qed
                 ultimately show ?thesis by argo
               qed
               also have "... = (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
                 using assms b c d e de HcompNml_in_Hom red2_in_Hom
                       Ide_HcompNml Nml_HcompNml ide_eval_Ide
                       assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<lbrace>c\<rbrace>"]
                       comp_permute [of "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]" "(\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>"
                                        "\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"]
                       comp_assoc
                 by (simp add: eval_simps')
               also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>))) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
                 using comp_assoc by simp
               also have "... = (((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                 (\<lbrace>d\<rbrace> \<star> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>])) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
                 using assms b c d e de eb I HcompNml_in_Hom red2_in_Hom
                       Ide_HcompNml Nml_HcompNml whisker_left [of "\<lbrace>d\<rbrace>"]
                       interchange [of "\<lbrace>d\<rbrace>" "\<lbrace>d\<rbrace>" "\<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>"]
                 by (auto simp add: eval_simps')
               also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                ((\<lbrace>d\<rbrace> \<star> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                                 \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>))"
                 using comp_assoc by simp
               also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>))) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using assms b c d e de pentagon
                 by (simp add: eval_simps')
               also have "... = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
                                ((\<lbrace>d\<rbrace> \<star> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]) \<cdot>
                                \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using comp_assoc by simp
               also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>)) \<cdot>
                                (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>] \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using assms d e de HcompNml_in_Hom red2_in_Hom Ide_HcompNml Nml_HcompNml
                       assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e\<rbrace>" "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] comp_cod_arr [of "\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>"]
                 by (simp add: eval_simps')
               also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot>
                                 \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]) \<cdot>
                                ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using comp_assoc by simp
               also have "... = \<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot>
                                \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
               proof -
                 have "\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>
                          = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
                            \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]"
                 proof -
                   have "(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)
                           = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>\<rfloor>)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
                     using e 1 by (cases "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c") auto
                   also have "... = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
                     using assms Nml_HcompNml Nmlize_Nml by simp
                   also have "... = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
                     using d 1
                     apply (cases "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
                     by (cases d, simp_all)
                   finally show ?thesis
                     using \<alpha>_def by simp
                 qed
                 thus ?thesis by simp
               qed
               also have "... = (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                  using comp_assoc by simp
               finally show ?thesis by auto
             qed
           qed
         qed
         thus ?thesis using assms(1,4) by blast
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma coherent_Assoc_Ide:
     assumes "Ide a" and "Ide b" and "Ide c" and "Src a = Trg b" and "Src b = Trg c"
     shows "coherent \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
     proof -
       have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
                ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_in_Hom Ide_Nmlize_Ide ide_eval_Ide red_in_Hom eval_in_hom(2)
         by force
       have b: "Ide b \<and> Arr b \<and> Dom b = b \<and> Cod b = b \<and>
                ide \<lbrace>b\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>b\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>b\<rbrace> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_in_Hom Ide_Nmlize_Ide ide_eval_Ide red_in_Hom(2)
               eval_in_hom(2) [of "b\<^bold>\<down>"]
         by auto
       have c: "Ide c \<and> Arr c \<and> Dom c = c \<and> Cod c = c \<and>
                ide \<lbrace>c\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>c\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>c\<rbrace> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_in_Hom Ide_Nmlize_Ide red_in_Hom eval_in_hom(2) [of "c\<^bold>\<down>"]
               ide_eval_Ide
         by auto
       have "\<lbrace>Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace>
               = (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace> \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)) \<cdot>
                 \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
         using assms a b c red_in_Hom red2_in_Hom Nml_Nmlize Ide_Nmlize_Ide
               \<alpha>_def eval_red_Hcomp interchange [of "\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>" "\<lbrace>a\<^bold>\<down>\<rbrace>"] comp_cod_arr [of "\<lbrace>a\<^bold>\<down>\<rbrace>"]
         by (simp add: eval_simps')
       also have "... = ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> \<a>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>]) \<cdot>
                        ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
         using assms red_in_Hom Ide_HcompNml assoc_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>" "\<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"] comp_assoc
         by (simp add: eval_simps')
       also have "... = (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
         using assms Nml_Nmlize Ide_Nmlize_Ide coherence_key_fact by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace>"
         using assms a b c red_in_Hom red2_in_Hom Ide_Nmlize_Ide
               Nml_Nmlize eval_red_Hcomp HcompNml_assoc
               interchange [of "\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>" "\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"]
               comp_cod_arr [of "\<lbrace>c\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"]
         apply (simp add: eval_simps')
       proof -
         have "seq \<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>))"
           using assms c red_in_Hom red2_in_Hom Nml_HcompNml Ide_Nmlize_Ide Ide_HcompNml
                 Nml_Nmlize
           by (simp_all add: eval_simps')
         moreover have
             "cod (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)) =
              \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"
           using assms c red_in_Hom red2_in_Hom Nml_HcompNml Ide_Nmlize_Ide Ide_HcompNml
                 Nml_Nmlize HcompNml_assoc
           by (simp add: eval_simps')
         ultimately
         show "(\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>) =
               \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot>
                 \<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
          using comp_cod_arr comp_assoc by simp
        qed
        finally show ?thesis by blast
     qed
 
     lemma coherent_Assoc'_Ide:
     assumes "Ide a" and "Ide b" and "Ide c" and "Src a = Trg b" and "Src b = Trg c"
     shows "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]"
         using assms Ide_implies_Can coherent_Assoc_Ide Inv_Ide coherent_iff_coherent_Inv
               Can.simps(10) Inv.simps(10)
         by presburger
 
     lemma eval_red2_naturality:
     assumes "Nml t" and "Nml u" and "Src t = Trg u"
     shows "\<lbrace>Cod t \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom t \<^bold>\<Down> Dom u\<rbrace>"
     proof -
       have *: "\<And>t u. Nml (t \<^bold>\<star> u) \<Longrightarrow> arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>u\<rbrace>"
-        using Nml_implies_Arr Nml_HcompD by simp
+        using Nml_implies_Arr Nml_HcompD
+        by (metis eval_simps'(1))
       have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis"
         using assms Nml_implies_Arr is_Prim0_Trg \<ll>.naturality [of "\<lbrace>u\<rbrace>"]
         by (cases t) (simp_all add: eval_simps', cases "Trg t", simp_all)
       moreover have "\<not> is_Prim\<^sub>0 t \<and> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
         using assms Nml_implies_Arr eval_red2_Nml_Prim\<^sub>0 runit_naturality [of "\<lbrace>t\<rbrace>"]
         by (cases u) (simp_all add: eval_simps')
       moreover have "\<not> is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
         using assms * Nml_implies_Arr
         apply (induct t, simp_all)
       proof -
         fix f
         assume f: "C.arr f"
         assume "\<not> is_Prim\<^sub>0 u"
         hence u: "\<not> is_Prim\<^sub>0 u \<and>
                   Nml u \<and> Nml (Dom u) \<and> Nml (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
                   arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
           using assms(2) Nml_implies_Arr ide_eval_Ide by simp
         hence 1: "\<not> is_Prim\<^sub>0 (Dom u) \<and> \<not> is_Prim\<^sub>0 (Cod u)"
           using u by (cases u) simp_all
         assume "\<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0 = Trg u"
         hence "\<lbrace>\<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0\<rbrace> = \<lbrace>Trg u\<rbrace>" by simp
         hence fu: "src (E f) = trg \<lbrace>u\<rbrace>"
           using f u preserves_src Nml_implies_Arr
           by (simp add: eval_simps')
         show "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> \<cdot> (E f \<star> \<lbrace>u\<rbrace>) = (E f \<star> \<lbrace>u\<rbrace>) \<cdot> \<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace>"
         proof -
           have "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> = E (C.cod f) \<star> cod \<lbrace>u\<rbrace>"
             using f u 1 Nml_implies_Arr
             by (cases "Cod u", simp_all add: eval_simps')
           moreover have "\<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace> = E (C.dom f) \<star> dom \<lbrace>u\<rbrace>"
             using f u 1 Nml_implies_Arr
             by (cases "Dom u", simp_all add: eval_simps')
           moreover have "\<guillemotleft>E f \<star> \<lbrace>u\<rbrace> : E (C.dom f) \<star> \<lbrace>Dom u\<rbrace> \<Rightarrow> E (C.cod f) \<star> \<lbrace>Cod u\<rbrace>\<guillemotright>"
             using f u fu Nml_implies_Arr
             apply (intro hcomp_in_vhom)
               apply auto
             by (metis C.src_dom eval_simps(4) preserves_src trg_dom u)
           ultimately show ?thesis
             using f u comp_arr_dom comp_cod_arr
             by (simp add: fu)
         qed
         next
         fix v w
         assume I2: "\<lbrakk> \<not> is_Prim\<^sub>0 w; Nml w \<rbrakk> \<Longrightarrow>
                       \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"
         assume "\<not> is_Prim\<^sub>0 u"
         hence u: "\<not> is_Prim\<^sub>0 u \<and> Arr u \<and> Arr (Dom u) \<and> Arr (Cod u) \<and>
                   Nml u \<and> Nml (Dom u) \<and> Nml (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
                   arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
           using assms(2) Nml_implies_Arr ide_eval_Ide by simp
         assume vw: "Nml (v \<^bold>\<star> w)"
         assume wu: "Src w = Trg u"
         let ?f = "un_Prim v"
         have "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f"
           using vw by (metis Nml_HcompD(1) Nml_HcompD(2))
         hence "Arr v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr ?f \<and> Nml v" by (cases v; simp)
         hence v: "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f \<and> Arr v \<and> Arr (Dom v) \<and> Arr (Cod v) \<and> Nml v \<and>
                   Nml (Dom v) \<and> Nml (Cod v) \<and>
                   arr \<lbrace>v\<rbrace> \<and> arr \<lbrace>Dom v\<rbrace> \<and> arr \<lbrace>Cod v\<rbrace> \<and> ide \<lbrace>Dom v\<rbrace> \<and> ide \<lbrace>Cod v\<rbrace>"
           using vw * by (cases v, simp_all)
         have "Nml w \<and> \<not> is_Prim\<^sub>0 w"
           using vw v by (metis Nml.simps(3))
         hence w: "\<not> is_Prim\<^sub>0 w \<and> Arr w \<and> Arr (Dom w) \<and> Arr (Cod w) \<and>
                   Nml w \<and> Nml (Dom w) \<and> Nml (Cod w) \<and>
                   Ide (Dom w) \<and> Ide (Cod w) \<and>
                   arr \<lbrace>w\<rbrace> \<and> arr \<lbrace>Dom w\<rbrace> \<and> arr \<lbrace>Cod w\<rbrace> \<and> ide \<lbrace>Dom w\<rbrace> \<and> ide \<lbrace>Cod w\<rbrace>"
           using vw * Nml_implies_Arr ide_eval_Ide by simp
         have u': "\<not> is_Prim\<^sub>0 (Dom u) \<and> \<not> is_Prim\<^sub>0 (Cod u)"
           using u by (cases u, simp_all)
         have w':  "\<not> is_Prim\<^sub>0 (Dom w) \<and> \<not> is_Prim\<^sub>0 (Cod w)"
           using w by (cases w, simp_all)
         have vw': "Src v = Trg w"
           using vw Nml_HcompD(7) by simp
         have X: "Nml (Dom v \<^bold>\<star> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u))"
           using u u' v w w' wu vw is_Hcomp_HcompNml Nml_HcompNml Nml_Dom
           by (metis Dom.simps(3) Nml.simps(3) term.distinct_disc(3))
         have Y: "Nml (Cod v \<^bold>\<star> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u))"
           using u u' w w' wu vw is_Hcomp_HcompNml Nml_HcompNml Src_Cod Trg_Cod
           by (metis Cod.simps(3) Nml.simps(3) Nml_Cod term.distinct_disc(3) v)
         show "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)
                 = \<lbrace>(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
         proof -
           have "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)
                   = (\<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
                     \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
           proof -
             have "(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u
                     = (Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Cod v \<^bold>\<star> Cod w \<^bold>\<Down> Cod u) \<^bold>\<cdot>
                       \<^bold>\<a>\<^bold>[Cod v, Cod w, Cod u\<^bold>]"
               using u v w by (cases u) simp_all
             hence "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace>
                      = \<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
                        \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
               using u v w \<alpha>_def by simp
             thus ?thesis by presburger
           qed
           also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
                             \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
             using u v w Y red2_Nml by simp
           also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot>
                            ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
             using u v w vw' wu comp_cod_arr red2_in_Hom HcompNml_in_Hom comp_reduce
            by (simp add: eval_simps')
           also have "... = (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>] \<cdot>
                            ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
             using comp_assoc by simp
           also have "... = (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using u v w vw' wu assoc_naturality [of "\<lbrace>v\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>u\<rbrace>"]
             by (simp add: eval_simps')
           also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>)) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using comp_assoc by simp
           also have
             "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using v w u vw' wu I2 red2_in_Hom HcompNml_in_Hom comp_cod_arr
                   interchange [of "\<lbrace>Cod v\<rbrace>" "\<lbrace>v\<rbrace>" "\<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>" "\<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>"]
             by (simp add: eval_simps')
           also have "... = ((\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>)) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using v w u vw' wu red2_in_Hom HcompNml_in_Hom comp_arr_dom
                   interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>Dom v\<rbrace>" "\<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>" "\<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"]
             by (simp add: eval_simps')
           also have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using comp_assoc by simp
           also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using u u' v w vw' wu is_Hcomp_HcompNml HcompNml_Prim [of "w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u" ?f]
             by force
           also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
                           (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
           proof -
             have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                     \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>] =
                   (\<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace>) \<cdot>
                     (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using u v w vw' wu comp_arr_dom Nml_HcompNml HcompNml_in_Hom
               by (simp add: eval_simps')
             also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
                                (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using comp_assoc by simp
             finally show ?thesis by blast
           qed
           also have "... = \<lbrace>(v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
           proof -
             have "(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u
                      = (Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Dom v \<^bold>\<star> (Dom w \<^bold>\<Down> Dom u)) \<^bold>\<cdot>
                        \<^bold>\<a>\<^bold>[Dom v, Dom w, Dom u\<^bold>]"
               using u u' v w vw' wu by (cases u, simp_all)
             hence
               "\<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>
                      = \<lbrace>Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u)\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                        \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using u v w \<alpha>_def by simp
             also have
               "... = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                              \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using X HcompNml_Nml red2_Nml by presburger
             finally have
               "\<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>
                    = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                      \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               by blast
             thus ?thesis
               using assms v w vw' wu HcompNml_assoc by presburger
           qed
           finally show ?thesis
             using vw HcompNml_Nml by simp
         qed
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma coherent_Hcomp:
     assumes "Arr t" and "Arr u" and "Src t = Trg u" and "coherent t" and "coherent u"
     shows "coherent (t \<^bold>\<star> u)"
     proof -
       have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
         using assms Ide_Nmlize_Ide ide_eval_Ide by auto
       have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
                arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
         using assms Ide_Nmlize_Ide ide_eval_Ide by auto
       have "\<lbrace>Cod (t \<^bold>\<star> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)
               = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Cod u\<^bold>\<down>\<rbrace>)) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)"
         using t u eval_red_Hcomp by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Cod u\<^bold>\<down>\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using assms t u Nmlize_in_Hom red_in_Hom
               interchange [of "\<lbrace>Cod t\<^bold>\<down>\<rbrace>" "\<lbrace>t\<rbrace>" "\<lbrace>Cod u\<^bold>\<down>\<rbrace>" "\<lbrace>u\<rbrace>"]
               interchange [of "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>" "\<lbrace>Dom t\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>" "\<lbrace>Dom u\<^bold>\<down>\<rbrace>"]
         by (simp add: eval_simps')
       also have "... = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>)) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using comp_assoc by simp
       also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using assms t u Nml_Nmlize Nmlize_in_Hom
               eval_red2_naturality [of "Nmlize t" "Nmlize u"]
         by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<star> Dom u)\<^bold>\<down>\<rbrace>"
         using t u eval_red_Hcomp by simp
       finally have "\<lbrace>Cod (t \<^bold>\<star> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<star> Dom u)\<^bold>\<down>\<rbrace>"
         by blast
       thus ?thesis using t u by simp
     qed
 
     lemma coherent_Vcomp:
     assumes "Arr t" and "Arr u" and "Dom t = Cod u"
     and "coherent t" and "coherent u"
     shows "coherent (t \<^bold>\<cdot> u)"
     proof -
       have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
         using assms Ide_Nmlize_Ide ide_eval_Ide by auto
       have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
                arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
         using assms Ide_Nmlize_Ide ide_eval_Ide by auto
       have "\<lbrace>Cod (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         using t u by simp
       also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
       proof -
         have "seq \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<lbrace>t\<rbrace>"
           using assms t red_in_Hom
           by (intro seqI, auto simp add: eval_simps')
         moreover have "seq \<lbrace>t\<rbrace> \<lbrace>u\<rbrace>"
           using assms t u by (auto simp add: eval_simps')
         ultimately show ?thesis
           using comp_assoc by auto
       qed
       also have "... = \<lbrace>\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace>"
         using t u assms red_in_Hom Nml_Nmlize comp_assoc
         by (simp add: eval_simps' Nml_implies_Arr eval_VcompNml)
       finally show "coherent (t \<^bold>\<cdot> u)" by blast
     qed
 
     text \<open>
       The main result: ``Every formal arrow is coherent.''
     \<close>
 
     theorem coherence:
     assumes "Arr t"
     shows "coherent t"
     proof -
       have "Arr t \<Longrightarrow> coherent t"
       proof (induct t)
         show "\<And>a. Arr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0" by simp
         show "\<And>\<mu>. Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<Longrightarrow> coherent \<^bold>\<langle>\<mu>\<^bold>\<rangle>" by simp
         fix u v
         show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<star> v)
                   \<Longrightarrow> coherent (u \<^bold>\<star> v)"
           using coherent_Hcomp by simp
         show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<cdot> v)
                   \<Longrightarrow> coherent (u \<^bold>\<cdot> v)"
           using coherent_Vcomp by simp
         next
         fix t
         assume I: "Arr t \<Longrightarrow> coherent t"
         show Lunit: "Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
           using I Ide_Dom coherent_Lunit_Ide Ide_in_Hom
                 coherent_Vcomp [of t "\<^bold>\<l>\<^bold>[Dom t\<^bold>]"] Nmlize_Vcomp_Arr_Dom
                 eval_in_hom \<ll>.is_natural_1 [of "\<lbrace>t\<rbrace>"]
           by force
         show Runit: "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
           using I Ide_Dom coherent_Runit_Ide Ide_in_Hom ide_eval_Ide
                 coherent_Vcomp [of t "\<^bold>\<r>\<^bold>[Dom t\<^bold>]"] Nmlize_Vcomp_Arr_Dom \<rr>_ide_simp
                 eval_in_hom \<rr>.is_natural_1 [of "\<lbrace>t\<rbrace>"]
           by force
         show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         proof -
           assume "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
           hence t: "Arr t" by simp
           have "coherent (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
             using t I Ide_Cod coherent_Lunit'_Ide Ide_in_Hom coherent_Vcomp [of "\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
                   Arr.simps(6) Dom.simps(6) Dom_Cod Ide_implies_Arr
             by presburger
           moreover have "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t\<rbrace>"
             using t \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
             by (simp add: eval_simps(5))
           ultimately show ?thesis
             using t Nmlize_Vcomp_Cod_Arr by simp
         qed
         show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         proof -
           assume "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
           hence t: "Arr t" by simp
           have "coherent (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
             using t I Ide_Cod coherent_Runit'_Ide Ide_in_Hom coherent_Vcomp [of "\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
                   Arr.simps(8) Dom.simps(8) Dom_Cod Ide_implies_Arr
             by presburger
           moreover have "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t\<rbrace>"
             using t \<rr>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
             by (simp add: eval_simps(5))
           ultimately show ?thesis
             using t Nmlize_Vcomp_Cod_Arr by simp
         qed
         next
         fix t u v
         assume I1: "Arr t \<Longrightarrow> coherent t"
         assume I2: "Arr u \<Longrightarrow> coherent u"
         assume I3: "Arr v \<Longrightarrow> coherent v"
         show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
         proof -
           assume tuv: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
           have t: "Arr t" using tuv by simp
           have u: "Arr u" using tuv by simp
           have v: "Arr v" using tuv by simp
           have tu: "Src t = Trg u" using tuv by simp
           have uv: "Src u = Trg v" using tuv by simp
           have "coherent ((t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
           proof -
             have "Arr (t \<^bold>\<star> u \<^bold>\<star> v) \<and> coherent (t \<^bold>\<star> u \<^bold>\<star> v)"
               using t u v tu uv tuv I1 I2 I3 coherent_Hcomp Arr.simps(3) Trg.simps(3)
               by presburger
             moreover have "Arr \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v tu uv Ide_Dom by simp
             moreover have "coherent \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v tu uv Src_Dom Trg_Dom Ide_Dom coherent_Assoc_Ide by metis
             moreover have "Dom (t \<^bold>\<star> u \<^bold>\<star> v) = Cod \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v by simp
             ultimately show ?thesis
               using t u v coherent_Vcomp by blast
           qed
           moreover have "VPar \<^bold>\<a>\<^bold>[t, u, v\<^bold>] ((t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
             using t u v tu uv Ide_Dom by simp
           moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>(t \<^bold>\<star> u \<^bold>\<star>  v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
           proof -
             have "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>
                      = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>)"
             proof -
               have 1: "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Nml \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Nml \<^bold>\<lfloor>v\<^bold>\<rfloor> \<and>
                        Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>"
                 using t u v Nml_Nmlize by blast
               moreover have "Nml (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>)"
                 using 1 t u tu Nmlize_Src Nmlize_Trg Nml_HcompNml(1)
                 by presburger
               moreover have "\<And>t. Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
                 using t Nmlize_Vcomp_Arr_Dom by simp
               moreover have "Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor>"
                 using Nml_Nmlize tuv by blast
               ultimately show ?thesis
                 using t u v tu uv tuv 1 HcompNml_assoc Nml_HcompNml
                       Nml_Nmlize VcompNml_Nml_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
                 by auto
             qed
             thus ?thesis
               using t u v Nmlize_Vcomp_Arr_Dom VcompNml_HcompNml Nml_Nmlize
               by simp
           qed
           moreover have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>(t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
             using t u v tu uv Ide_Dom comp_cod_arr ide_eval_Ide \<alpha>_def
             apply (simp add: eval_simps')
             using assoc_is_natural_1 arr_eval_Arr eval_simps'(2-4) by presburger
           ultimately show "coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]" by argo
         qed
         show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
         proof -
           assume tuv: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
           have t: "Arr t" using tuv by simp
           have u: "Arr u" using tuv by simp
           have v: "Arr v" using tuv by simp
           have tu: "Src t = Trg u" using tuv by simp
           have uv: "Src u = Trg v" using tuv by simp
           have "coherent (((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
           proof -
             have "Arr ((t \<^bold>\<star> u) \<^bold>\<star> v) \<and> coherent ((t \<^bold>\<star> u) \<^bold>\<star> v)"
               using t u v tu uv tuv I1 I2 I3 coherent_Hcomp Arr.simps(3) Src.simps(3)
               by presburger
             moreover have "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v tu uv Ide_Dom by simp
             moreover have "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v tu uv Src_Dom Trg_Dom Ide_Dom coherent_Assoc'_Ide
               by metis
             moreover have "Dom ((t \<^bold>\<star> u) \<^bold>\<star> v) = Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v by simp
             ultimately show ?thesis
               using t u v coherent_Vcomp by metis
           qed
           moreover have "VPar \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] (((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
             using t u v tu uv Ide_Dom by simp
           moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
             using t u v tu uv Nmlize_Vcomp_Arr_Dom VcompNml_HcompNml Nml_Nmlize
                   HcompNml_assoc Nml_HcompNml HcompNml_in_Hom
                   VcompNml_Nml_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
-            by simp
+            using Nmlize.simps(3-4,10) by presburger
           moreover have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
           proof -
             have 1: "VVV.arr (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
               using tuv \<alpha>'.preserves_reflects_arr arr_eval_Arr eval.simps(10)
               by (metis (no_types, lifting))
             have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
             proof -
               have "VVV.arr (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
                 using tuv \<alpha>'.preserves_reflects_arr arr_eval_Arr eval.simps(10)
                 by (metis (no_types, lifting))
               thus ?thesis
                 using t u v \<alpha>'.is_natural_1 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] HoHV_def \<a>'_def
                       VVV.dom_simp
                 by simp
             qed
             also have "... = \<lbrace>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
               by (simp add: eval_simps'(4) t u v \<a>'_def)
             finally show ?thesis by blast
           qed
           ultimately show "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]" by argo
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     corollary eval_eqI:
     assumes "VPar t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
       using assms coherence canonical_factorization by simp
 
     text \<open>
       The following allows us to prove that two 1-cells in a bicategory are isomorphic
       simply by expressing them as the evaluations of terms having the same normalization.
       The benefits are: (1) we do not have to explicitly exhibit the isomorphism,
       which is canonical and is obtained by evaluating the reductions of the terms
       to their normalizations, and (2) the normalizations can be computed automatically
       by the simplifier.
     \<close>
 
     lemma canonically_isomorphicI:
     assumes "f = \<lbrace>t\<rbrace>" and "g = \<lbrace>u\<rbrace>" and "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     shows "f \<cong> g"
     proof -
       have "f \<cong> \<lbrace>t\<rbrace>"
         using assms isomorphic_reflexive ide_eval_Ide by blast
       also have "... \<cong> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
       proof -
         have "\<guillemotleft>\<lbrace>t\<^bold>\<down>\<rbrace> : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>\<guillemotright> \<and> iso \<lbrace>t\<^bold>\<down>\<rbrace>"
           using assms(1,3) Can_red iso_eval_Can red_in_Hom(2) eval_in_hom(2) by fastforce
         thus ?thesis
           using isomorphic_def by blast
       qed
       also have "... \<cong> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>"
         using assms isomorphic_reflexive
         by (simp add: Ide_Nmlize_Ide ide_eval_Ide)
       also have "... \<cong> \<lbrace>u\<rbrace>"
       proof -
         have "\<guillemotleft>\<lbrace>u\<^bold>\<down>\<rbrace> : \<lbrace>u\<rbrace> \<Rightarrow> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>\<guillemotright> \<and> iso \<lbrace>u\<^bold>\<down>\<rbrace>"
           using assms(2,4) Can_red iso_eval_Can red_in_Hom(2) eval_in_hom(2) by fastforce
         thus ?thesis
           using isomorphic_def isomorphic_symmetric by blast
       qed
       also have "... \<cong> g"
         using assms isomorphic_reflexive ide_eval_Ide by blast
       finally show ?thesis by simp
     qed
 
   end
 
 end
diff --git a/thys/Bicategory/Prebicategory.thy b/thys/Bicategory/Prebicategory.thy
--- a/thys/Bicategory/Prebicategory.thy
+++ b/thys/Bicategory/Prebicategory.thy
@@ -1,2960 +1,2959 @@
 (*  Title:       PreBicategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
   text \<open>
     The objective of this section is to construct a formalization of bicategories that is
     compatible with our previous formulation of categories \cite{Category3-AFP}
     and that permits us to carry over unchanged as much of the work done on categories as possible.
     For these reasons, we conceive of a bicategory in what might be regarded as a somewhat
     unusual fashion.  Rather than a traditional development, which would typically define
     a bicategory to be essentially ``a `category' whose homs themselves have the structure
     of categories,'' here we regard a bicategory as ``a (vertical) category that has been
     equipped with a suitable (horizontal) weak composition.''  Stated another way, we think
     of a bicategory as a generalization of a monoidal category in which the tensor product is
     a partial operation, rather than a total one.  Our definition of bicategory can thus
     be summarized as follows: a bicategory is a (vertical) category that has been equipped
     with idempotent endofunctors \<open>src\<close> and \<open>trg\<close> that assign to each arrow its ``source''
     and ``target'' subject to certain commutativity constraints,
     a partial binary operation \<open>\<star>\<close> of horizontal composition that is suitably functorial on
     the ``hom-categories'' determined by the assignment of sources and targets,
     ``associativity'' isomorphisms \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> (g \<star> h)\<guillemotright>\<close> for each horizontally
     composable triple of vertical identities \<open>f\<close>, \<open>g\<close>, \<open>h\<close>, subject to the usual naturality
     and coherence conditions, and for each ``object'' \<open>a\<close> (defined to be an arrow that is
     its own source and target) a ``unit isomorphism'' \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
     As is the case for monoidal categories, the unit isomorphisms and associator isomorphisms
     together enable a canonical definition of left and right ``unit'' isomorphisms
     \<open>\<guillemotleft>\<l>[f] : a \<star> f \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close> when \<open>f\<close> is a vertical identity
     horizontally composable on the left or right by \<open>a\<close>, and it can be shown that these are
     the components of natural transformations.
 
     The definition of bicategory just sketched shares with a more traditional version the
     requirement that assignments of source and target are given as basic data, and these
     assignments determine horizontal composability in the sense that arrows \<open>\<mu>\<close> and \<open>\<nu>\<close>
     are composable if the chosen source of \<open>\<mu>\<close> coincides with the chosen target of \<open>\<nu>\<close>.
     Thus it appears, at least on its face, that composability of arrows depends on an assignment
     of sources and targets.  We are interested in establishing whether this is essential or
     whether bicategories can be formalized in a completely ``object-free'' fashion.
 
     It turns out that we can obtain such an object-free formalization through a rather direct
     generalization of the approach we used in the formalization of categories.
     Specifically, we define a \emph{weak composition} to be a partial binary operation \<open>\<star>\<close>
     on the arrow type of a ``vertical'' category \<open>V\<close>, such that the domain of definition of this
     operation is itself a category (of ``horizontally composable pairs of arrows''),
     the operation is functorial, and it is subject to certain matching conditions which include
     those satisfied by a category.
     From the axioms for a weak composition we can prove the existence of ``hom-categories'',
     which are subcategories of \<open>V\<close> consisting of arrows horizontally composable on the
     left or right by a specified vertical identity.
     A \emph{weak unit} is defined to be a vertical identity \<open>a\<close> such that \<open>a \<star> a \<cong> a\<close>
     and is such that the mappings \<open>a \<star> \<hyphen>\<close> and \<open>\<hyphen> \<star> a\<close> are fully faithful endofunctors
     of the subcategories of \<open>V\<close> consisting of the arrows for which they are defined.
     We define the \emph{sources} of an arrow \<open>\<mu>\<close> to be the weak units that are horizontally
     composable with \<open>\<mu>\<close> on the right, and the \emph{targets} of \<open>\<mu>\<close> to be the weak units
     that are horizontally composable with \<open>\<mu>\<close> on the left.
     An \emph{associative weak composition} is defined to be a weak composition that is equipped
     with ``associator'' isomorphisms \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> (g \<star> h)\<guillemotright>\<close> for horizontally
     composable vertical identities \<open>f\<close>, \<open>g\<close>, \<open>h\<close>, subject to the usual naturality and coherence
     conditions.
     A \emph{prebicategory} is defined to be an associative weak composition for which every
     arrow has a source and a target.  We show that the sets of sources and targets of each
     arrow in a prebicategory is an isomorphism class of weak units, and that horizontal
     composability of arrows \<open>\<mu>\<close> and \<open>\<nu>\<close> is characterized by the set of sources of \<open>\<mu>\<close> being
     equal to the set of targets of \<open>\<nu>\<close>.
 
     We show that prebicategories are essentially ``bicategories without objects''.
     Given a prebicategory, we may choose an arbitrary representative of each
     isomorphism class of weak units and declare these to be ``objects''
     (this is analogous to choosing a particular unit object in a monoidal category).
     For each object we may choose a particular \emph{unit isomorphism} \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
     This choice, together with the associator isomorphisms, enables a canonical definition
     of left and right unit isomorphisms \<open>\<guillemotleft>\<l>[f] : a \<star> f \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close>
     when \<open>f\<close> is a vertical identity horizontally composable on the left or right by \<open>a\<close>,
     and it can be shown that these are the components of natural isomorphisms.
     We may then define ``the source'' of an arrow to be the chosen representative of the
     set of its sources and ``the target'' to be the chosen representative of the set of its
     targets.  We show that the resulting structure is a bicategory, in which horizontal
     composability as given by the weak composition coincides with the ``syntactic'' version
     determined by the chosen sources and targets.
     Conversely, a bicategory determines a prebicategory, essentially by forgetting
     the sources, targets and unit isomorphisms.
     These results make it clear that the assignment of sources and targets to arrows in
     a bicategory is basically a convenience and that horizontal composability of arrows
     is not dependent on a particular choice.
 \<close>
 
 theory Prebicategory
 imports Category3.EquivalenceOfCategories Category3.Subcategory IsomorphismClass
 begin
 
   section "Weak Composition"
 
   text \<open>
     In this section we define a locale \<open>weak_composition\<close>, which formalizes a functorial
     operation of ``horizontal'' composition defined on an underlying ``vertical'' category.
     The definition is expressed without the presumption of the existence of any sort
     of ``objects'' that determine horizontal composability.  Rather, just as we did
     in showing that the @{locale partial_magma} locale supported the definition of ``identity
     arrow'' as a kind of unit for vertical composition which ultimately served as a basis
     for the definition of ``domain'' and ``codomain'' of an arrow, here we show that the
     \<open>weak_composition\<close> locale supports a definition of \emph{weak unit} for horizontal
     composition which can ultimately be used to define the \emph{sources} and \emph{targets}
     of an arrow with respect to horizontal composition.
     In particular, the definition of weak composition involves axioms that relate horizontal
     and vertical composability.  As a consequence of these axioms, for any fixed arrow \<open>\<mu>\<close>,
     the sets of arrows horizontally composable on the left and on the right with \<open>\<mu>\<close>
     form subcategories with respect to vertical composition.  We define the
     sources of \<open>\<mu>\<close> to be the weak units that are composable with \<open>\<mu>\<close> on the right,
     and the targets of \<open>\<mu>\<close> to be the weak units that are composable with \<open>\<mu>\<close>
     on the left.  Weak units are then characterized as arrows that are members
     of the set of their own sources (or, equivalently, of their own targets).
   \<close>
 
   subsection "Definition"
 
   locale weak_composition =
     category V +
     VxV: product_category V V +
     VoV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null\<close> +
     "functor" VoV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
   for V :: "'a comp"         (infixr "\<cdot>" 55)
   and H :: "'a comp"         (infixr "\<star>" 53) +
   assumes left_connected: "seq \<nu> \<nu>' \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu>' \<star> \<mu> \<noteq> null"
   and right_connected: "seq \<mu> \<mu>' \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> \<mu>' \<noteq> null"
   and match_1: "\<lbrakk> \<nu> \<star> \<mu> \<noteq> null; (\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null \<rbrakk> \<Longrightarrow> \<mu> \<star> \<tau> \<noteq> null"
   and match_2: "\<lbrakk> \<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null; \<mu> \<star> \<tau> \<noteq> null \<rbrakk> \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null"
   and match_3: "\<lbrakk> \<mu> \<star> \<tau> \<noteq> null; \<nu> \<star> \<mu> \<noteq> null \<rbrakk> \<Longrightarrow> (\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
   and match_4: "\<lbrakk> \<mu> \<star> \<tau> \<noteq> null; \<nu> \<star> \<mu> \<noteq> null \<rbrakk> \<Longrightarrow> \<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null"
   begin
 
     text \<open>
       We think of the arrows of the vertical category as ``2-cells'' and the vertical identities
       as ``1-cells''.  In the formal development, the predicate @{term arr} (``arrow'')
       will have its normal meaning with respect to the vertical composition, hence @{term "arr \<mu>"}
       will mean, essentially, ``\<open>\<mu>\<close> is a 2-cell''.  This is somewhat unfortunate, as it is
       traditional when discussing bicategories to use the term ``arrow'' to refer to the 1-cells.
       However, we are trying to carry over all the formalism that we have already developed for
       categories and apply it to bicategories with as little change and redundancy as possible.
       It becomes too confusing to try to repurpose the name @{term arr} to mean @{term ide} and
       to introduce a replacement for the name @{term arr}, so we will simply tolerate the
       situation.  In informal text, we will prefer the terms ``2-cell'' and ``1-cell'' over
       (vertical) ``arrow'' and ``identity'' when there is a chance for confusion.
 
       We do, however, make the following adjustments in notation for @{term in_hom} so that
       it is distinguished from the notion @{term in_hhom} (``in horizontal hom'') to be
       introduced subsequently.
     \<close>
 
     no_notation in_hom      ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation in_hom         ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
 
     lemma is_partial_magma:
     shows "partial_magma H"
     proof
       show "\<exists>!n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"
       proof
         show 1: "\<forall>f. null \<star> f = null \<and> f \<star> null = null"
           using is_extensional VoV.inclusion VoV.arr_char by force
         show "\<And>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n \<Longrightarrow> n = null"
           using 1 VoV.arr_char is_extensional not_arr_null by metis
       qed
     qed
 
     interpretation H: partial_magma H
       using is_partial_magma by auto
 
     text \<open>
       Either \<open>match_1\<close> or \<open>match_2\<close> seems essential for the next result, which states
       that the nulls for the horizontal and vertical compositions coincide.
     \<close>
 
     lemma null_agreement [simp]:
     shows "H.null = null"
       by (metis VoV.inclusion VxV.not_arr_null match_1 H.comp_null(1))
 
     lemma composable_implies_arr:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "arr \<mu>" and "arr \<nu>"
       using assms is_extensional VoV.arr_char VoV.inclusion by auto
 
     lemma hcomp_null [simp]:
     shows "null \<star> \<mu> = null" and "\<mu> \<star> null = null"
       using H.comp_null by auto
 
     lemma hcomp_simps\<^sub>W\<^sub>C [simp]:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "arr (\<nu> \<star> \<mu>)" and "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>" and "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
       using assms preserves_arr preserves_dom preserves_cod VoV.arr_char VoV.inclusion
             VoV.dom_simp VoV.cod_simp
       by force+
 
     lemma ide_hcomp\<^sub>W\<^sub>C:
     assumes "ide f" and "ide g" and "g \<star> f \<noteq> null"
     shows "ide (g \<star> f)"
       using assms preserves_ide VoV.ide_char by force
 
     lemma hcomp_in_hom\<^sub>W\<^sub>C [intro]:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
       using assms by auto
 
     text \<open>
       Horizontal composability of arrows is determined by horizontal composability of
       their domains and codomains (defined with respect to vertical composition).
     \<close>
 
     lemma hom_connected:
     shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> dom \<nu> \<star> \<mu> \<noteq> null"
     and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> dom \<mu> \<noteq> null"
     and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> cod \<nu> \<star> \<mu> \<noteq> null"
     and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> cod \<mu> \<noteq> null"
     proof -
       show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> dom \<nu> \<star> \<mu> \<noteq> null"
         using left_connected [of \<nu> "dom \<nu>" \<mu>] composable_implies_arr arr_dom_iff_arr by force
       show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> cod \<nu> \<star> \<mu> \<noteq> null"
         using left_connected [of  "cod \<nu>" \<nu> \<mu>] composable_implies_arr arr_cod_iff_arr by force
       show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> dom \<mu> \<noteq> null"
         using right_connected [of \<mu> "dom \<mu>" \<nu>] composable_implies_arr arr_dom_iff_arr by force
       show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> cod \<mu> \<noteq> null"
         using right_connected [of "cod \<mu>" \<mu> \<nu>] composable_implies_arr arr_cod_iff_arr by force
     qed
 
     lemma isomorphic_implies_equicomposable:
     assumes "f \<cong> g"
     shows "\<tau> \<star> f \<noteq> null \<longleftrightarrow> \<tau> \<star> g \<noteq> null"
     and "f \<star> \<sigma> \<noteq> null \<longleftrightarrow> g \<star> \<sigma> \<noteq> null"
       using assms isomorphic_def hom_connected by auto
 
     lemma interchange:
     assumes "seq \<nu> \<mu>" and "seq \<tau> \<sigma>"
     shows "(\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
     proof -
       have "\<mu> \<star> \<sigma> = null \<Longrightarrow> ?thesis"
         by (metis assms comp_null(2) dom_comp hom_connected(1-2))
       moreover have "\<mu> \<star> \<sigma> \<noteq> null \<Longrightarrow> ?thesis"
       proof -
         assume \<mu>\<sigma>: "\<mu> \<star> \<sigma> \<noteq> null"
         have 1: "VoV.arr (\<mu>, \<sigma>)"
           using \<mu>\<sigma> VoV.arr_char by auto
         have \<nu>\<tau>: "(\<nu>, \<tau>) \<in> VoV.hom (VoV.cod (\<mu>, \<sigma>)) (VoV.cod (\<nu>, \<tau>))"
         proof -
           have "VoV.arr (\<nu>, \<tau>)"
             using assms 1 hom_connected VoV.arr_char
             by (elim seqE, auto, metis)
           thus ?thesis
             using assms \<mu>\<sigma> VoV.dom_char VoV.cod_char by fastforce
         qed
         show ?thesis
         proof -
           have "VoV.seq (\<nu>, \<tau>) (\<mu>, \<sigma>)"
             using assms 1 \<mu>\<sigma> \<nu>\<tau> VoV.seqI by blast
           thus ?thesis
             using assms 1 \<mu>\<sigma> \<nu>\<tau> VoV.comp_char preserves_comp [of "(\<nu>, \<tau>)" "(\<mu>, \<sigma>)"] VoV.seqI
             by fastforce
         qed
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma paste_1:
     shows "\<nu> \<star> \<mu> = (cod \<nu> \<star> \<mu>) \<cdot> (\<nu> \<star> dom \<mu>)"
       using interchange composable_implies_arr comp_arr_dom comp_cod_arr
             hom_connected(2-3)
       by (metis comp_null(2))
 
     lemma paste_2:
     shows "\<nu> \<star> \<mu> = (\<nu> \<star> cod \<mu>) \<cdot> (dom \<nu> \<star> \<mu>)"
       using interchange composable_implies_arr comp_arr_dom comp_cod_arr
             hom_connected(1,4)
       by (metis comp_null(2))
 
     lemma whisker_left:
     assumes "seq \<nu> \<mu>" and "ide f"
     shows "f \<star> (\<nu> \<cdot> \<mu>) = (f \<star> \<nu>) \<cdot> (f \<star> \<mu>)"
       using assms interchange [of f f \<nu> \<mu>] hom_connected by auto
 
     lemma whisker_right:
     assumes "seq \<nu> \<mu>" and "ide f"
     shows "(\<nu> \<cdot> \<mu>) \<star> f = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
       using assms interchange [of \<nu> \<mu> f f] hom_connected by auto
 
     subsection "Hom-Subcategories"
 
     definition left
     where "left \<tau> \<equiv> \<lambda>\<mu>. \<tau> \<star> \<mu> \<noteq> null"
 
     definition right
     where "right \<sigma> \<equiv> \<lambda>\<mu>. \<mu> \<star> \<sigma> \<noteq> null"
 
     lemma right_iff_left:
     shows "right \<sigma> \<tau> \<longleftrightarrow> left \<tau> \<sigma>"
       using right_def left_def by simp
 
     lemma left_respects_isomorphic:
     assumes "f \<cong> g"
     shows "left f = left g"
       using assms isomorphic_implies_equicomposable left_def by auto
 
     lemma right_respects_isomorphic:
     assumes "f \<cong> g"
     shows "right f = right g"
       using assms isomorphic_implies_equicomposable right_def by auto
 
     lemma left_iff_left_inv:
     assumes "iso \<mu>"
     shows "left \<tau> \<mu> \<longleftrightarrow> left \<tau> (inv \<mu>)"
       using assms left_def inv_in_hom hom_connected(2) hom_connected(4) [of \<tau> "inv \<mu>"]
       by auto
         
     lemma right_iff_right_inv:
     assumes "iso \<mu>"
     shows "right \<sigma> \<mu> \<longleftrightarrow> right \<sigma> (inv \<mu>)"
       using assms right_def inv_in_hom hom_connected(1) hom_connected(3) [of "inv \<mu>" \<sigma>]
       by auto
 
     lemma left_hom_is_subcategory:
     assumes "arr \<mu>"
     shows "subcategory V (left \<mu>)"
       using composable_implies_arr hom_connected(2,4)
       apply (unfold left_def, unfold_locales)
          apply auto
       by (metis cod_comp seqI)
 
     lemma right_hom_is_subcategory:
     assumes "arr \<mu>"
     shows "subcategory V (right \<mu>)"
       using composable_implies_arr hom_connected(1,3)
       apply (unfold right_def, unfold_locales)
          apply auto
       by (metis cod_comp seqI)
 
     abbreviation Left
     where "Left a \<equiv> subcategory.comp V (left a)"
 
     abbreviation Right
     where "Right a \<equiv> subcategory.comp V (right a)"
 
     text \<open>
       We define operations of composition on the left or right with a fixed 1-cell,
       and show that such operations are functorial in case that 1-cell is
       horizontally self-composable.
     \<close>
 
     definition H\<^sub>L
     where "H\<^sub>L g \<equiv> \<lambda>\<mu>. g \<star> \<mu>"
 
     definition H\<^sub>R
     where "H\<^sub>R f \<equiv> \<lambda>\<mu>. \<mu> \<star> f"
 
     (* TODO: Why do the following fail when I use @{thm ...} *)
     text \<open>
       Note that \<open>match_3\<close> and \<open>match_4\<close> are required for the next results.
     \<close>
 
     lemma endofunctor_H\<^sub>L:
     assumes "ide g" and "g \<star> g \<noteq> null"
     shows "endofunctor (Left g) (H\<^sub>L g)"
     proof -
       interpret L: subcategory V \<open>left g\<close> using assms left_hom_is_subcategory by simp
       have *: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> H\<^sub>L g \<mu> = g \<star> \<mu>"
         using assms H\<^sub>L_def by simp
       have preserves_arr: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L g \<mu>)"
         using assms * L.arr_char left_def match_4 by force
       show "endofunctor L.comp (H\<^sub>L g)"
         using assms *
         apply unfold_locales
         using H\<^sub>L_def L.arr_char L.null_char left_def
             apply force
         using preserves_arr
            apply blast
           apply (metis L.dom_simp L.not_arr_null L.null_char hcomp_simps\<^sub>W\<^sub>C(2) ide_char
             preserves_arr H\<^sub>L_def)
          apply (metis H\<^sub>L_def L.arrE L.cod_simp hcomp_simps\<^sub>W\<^sub>C(3) ide_char left_def preserves_arr)
         by (metis L.comp_def L.comp_simp L.seq_char hcomp_simps\<^sub>W\<^sub>C(1) whisker_left preserves_arr)
     qed
 
     lemma endofunctor_H\<^sub>R:
     assumes "ide f" and "f \<star> f \<noteq> null"
     shows "endofunctor (Right f) (H\<^sub>R f)"
     proof -
       interpret R: subcategory V \<open>right f\<close> using assms right_hom_is_subcategory by simp
       have *: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> H\<^sub>R f \<mu> = \<mu> \<star> f"
         using assms H\<^sub>R_def by simp
       have preserves_arr: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R f \<mu>)"
         using assms * R.arr_char right_def match_3 by force
       show "endofunctor R.comp (H\<^sub>R f)"
         using assms *
         apply unfold_locales
         using H\<^sub>R_def R.arr_char R.null_char right_def
             apply force
         using preserves_arr
            apply blast
           apply (metis R.dom_simp R.not_arr_null R.null_char hcomp_simps\<^sub>W\<^sub>C(2) ide_char
             preserves_arr H\<^sub>R_def)
          apply (metis H\<^sub>R_def R.arrE R.cod_simp hcomp_simps\<^sub>W\<^sub>C(3) ide_char right_def preserves_arr)
         by (metis R.comp_def R.comp_simp R.seq_char hcomp_simps\<^sub>W\<^sub>C(1) whisker_right preserves_arr)
     qed
 
   end
 
   locale left_hom =
     weak_composition V H +
     S: subcategory V \<open>left \<omega>\<close>
   for V :: "'a comp"        (infixr "\<cdot>" 55)
   and H :: "'a comp"        (infixr "\<star>" 53)
   and \<omega> :: 'a +
   assumes arr_\<omega>: "arr \<omega>"
   begin
 
     no_notation in_hom      ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation in_hom         ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
     notation S.comp         (infixr "\<cdot>\<^sub>S" 55)
     notation S.in_hom       ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
 
     lemma right_hcomp_closed:
     assumes "\<guillemotleft>\<mu> : x \<Rightarrow>\<^sub>S y\<guillemotright>" and "\<guillemotleft>\<nu> : c \<Rightarrow> d\<guillemotright>" and "\<mu> \<star> \<nu> \<noteq> null"
     shows "\<guillemotleft>\<mu> \<star> \<nu> : x \<star> c \<Rightarrow>\<^sub>S y \<star> d\<guillemotright>"
       using assms arr_\<omega> S.arr_char S.dom_simp S.cod_simp left_def match_4
       by (elim S.in_homE, intro S.in_homI) auto
 
     lemma interchange:
     assumes "S.seq \<nu> \<mu>" and "S.seq \<tau> \<sigma>" and "\<mu> \<star> \<sigma> \<noteq> null"
     shows "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
     proof -
       have 1: "\<nu> \<star> \<tau> \<noteq> null"
         using assms hom_connected(1) [of \<nu> \<sigma>] hom_connected(2) [of \<nu> \<tau>] hom_connected(3-4)
               S.dom_simp S.cod_simp
         by force
       have "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)"
         using assms S.comp_char S.seq_char by metis
       also have "... = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
         using assms interchange S.seq_char S.arr_char by simp
       also have "... = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
         using assms 1
         by (metis S.arr_char S.comp_char S.seq_char ext match_4 left_def)
       finally show ?thesis by blast
     qed
 
     lemma inv_char:
     assumes "S.arr \<phi>" and "iso \<phi>"
     shows "S.inverse_arrows \<phi> (inv \<phi>)"
     and "S.inv \<phi> = inv \<phi>"
     proof -
       have 1: "S.arr (inv \<phi>)"
         using assms S.arr_char left_iff_left_inv
         by (intro S.arrI) meson
       show "S.inv \<phi> = inv \<phi>"
         using assms 1 S.inv_char S.iso_char by blast
       thus "S.inverse_arrows \<phi> (inv \<phi>)"
         using assms 1 S.iso_char S.inv_is_inverse by metis
     qed
 
     lemma iso_char:
     assumes "S.arr \<phi>"
     shows "S.iso \<phi> \<longleftrightarrow> iso \<phi>"
       using assms S.iso_char inv_char by auto
 
   end
 
   locale right_hom =
     weak_composition V H +
     S: subcategory V \<open>right \<omega>\<close>
   for V :: "'a comp"        (infixr "\<cdot>" 55)
   and H :: "'a comp"        (infixr "\<star>" 53)
   and \<omega> :: 'a +
   assumes arr_\<omega>: "arr \<omega>"
   begin
 
     no_notation in_hom      ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation in_hom         ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
     notation S.comp         (infixr "\<cdot>\<^sub>S" 55)
     notation S.in_hom       ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
 
     lemma left_hcomp_closed:
     assumes "\<guillemotleft>\<mu> : x \<Rightarrow>\<^sub>S y\<guillemotright>" and "\<guillemotleft>\<nu> : c \<Rightarrow> d\<guillemotright>" and "\<nu> \<star> \<mu> \<noteq> null"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : c \<star> x \<Rightarrow>\<^sub>S d \<star> y\<guillemotright>"
       using assms arr_\<omega> S.arr_char S.dom_simp S.cod_simp right_def match_3
       by (elim S.in_homE, intro S.in_homI) auto
 
     lemma interchange:
     assumes "S.seq \<nu> \<mu>" and "S.seq \<tau> \<sigma>" and "\<mu> \<star> \<sigma> \<noteq> null"
     shows "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
     proof -
       have 1: "\<nu> \<star> \<tau> \<noteq> null"
         using assms hom_connected(1) [of \<nu> \<sigma>] hom_connected(2) [of \<nu> \<tau>] hom_connected(3-4)
               S.dom_simp S.cod_simp
         by fastforce
       have "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)"
         using assms S.comp_char S.seq_char by metis
       also have "... = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
         using assms interchange S.seq_char S.arr_char by simp
       also have "... = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
         using assms 1
         by (metis S.arr_char S.comp_char S.seq_char ext match_3 right_def)
       finally show ?thesis by blast
     qed
 
     lemma inv_char:
     assumes "S.arr \<phi>" and "iso \<phi>"
     shows "S.inverse_arrows \<phi> (inv \<phi>)"
     and "S.inv \<phi> = inv \<phi>"
     proof -
       have 1: "S.arr (inv \<phi>)"
         using assms S.arr_char right_iff_right_inv
         by (intro S.arrI) meson
       show "S.inv \<phi> = inv \<phi>"
         using assms 1 S.inv_char S.iso_char by blast
       thus "S.inverse_arrows \<phi> (inv \<phi>)"
         using assms 1 S.iso_char S.inv_is_inverse by metis
     qed
 
     lemma iso_char:
     assumes "S.arr \<phi>"
     shows "S.iso \<phi> \<longleftrightarrow> iso \<phi>"
       using assms S.iso_char inv_char by auto
 
   end
 
   subsection "Weak Units"
 
   text \<open>
     We now define a \emph{weak unit} to be an arrow \<open>a\<close> such that:
     \begin{enumerate}
     \item  \<open>a \<star> a\<close> is isomorphic to \<open>a\<close>
            (and hence \<open>a\<close> is a horizontally self-composable 1-cell).
     \item  Horizontal composition on the left with \<open>a\<close> is a fully faithful endofunctor of the
            subcategory of arrows that are composable on the left with \<open>a\<close>.
     \item  Horizontal composition on the right with \<open>a\<close> is fully faithful endofunctor of the
            subcategory of arrows that are composable on the right with \<open>a\<close>.
     \end{enumerate}
   \<close>
 
   context weak_composition
   begin
 
     definition weak_unit :: "'a \<Rightarrow> bool"
     where "weak_unit a \<equiv> a \<star> a \<cong> a \<and>
                          fully_faithful_functor (Left a) (Left a) (H\<^sub>L a) \<and>
                          fully_faithful_functor (Right a) (Right a) (H\<^sub>R a)"
 
     lemma weak_unit_self_composable:
     assumes "weak_unit a"
     shows "ide a" and "ide (a \<star> a)" and "a \<star> a \<noteq> null"
     proof -
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
         using assms weak_unit_def isomorphic_def by blast
       have 1: "arr \<phi>" using \<phi> by blast
       show "ide a" using \<phi> ide_cod by blast
       thus "ide (a \<star> a)" using \<phi> ide_dom by force
       thus "a \<star> a \<noteq> null" using not_arr_null ideD(1) by metis
     qed
 
     lemma weak_unit_self_right:
     assumes "weak_unit a"
     shows "right a a"
       using assms weak_unit_self_composable right_def by simp
 
     lemma weak_unit_self_left:
     assumes "weak_unit a"
     shows "left a a"
       using assms weak_unit_self_composable left_def by simp
 
     lemma weak_unit_in_vhom:
     assumes "weak_unit a"
     shows "\<guillemotleft>a : a \<Rightarrow> a\<guillemotright>"
       using assms weak_unit_self_composable left_def by auto
 
     text \<open>
       If \<open>a\<close> is a weak unit, then there exists a ``unit isomorphism'' \<open>\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
       It need not be unique, but we may choose one arbitrarily.
     \<close>
 
     definition some_unit
     where "some_unit a \<equiv> SOME \<iota>. iso \<iota> \<and> \<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
 
     lemma iso_some_unit:
     assumes "weak_unit a"
     shows "iso (some_unit a)"
     and "\<guillemotleft>some_unit a : a \<star> a \<Rightarrow> a\<guillemotright>"
     proof -
       let ?P = "\<lambda>\<iota>. iso \<iota> \<and> \<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
       have "\<exists>\<iota>. ?P \<iota>"
         using assms weak_unit_def by auto
       hence 1: "?P (some_unit a)"
         using someI_ex [of ?P] some_unit_def by simp
       show "iso (some_unit a)" using 1 by blast
       show "\<guillemotleft>some_unit a : a \<star> a \<Rightarrow> a\<guillemotright>" using 1 by blast
     qed
 
     text \<open>
       The \emph{sources} of an arbitrary arrow \<open>\<mu>\<close> are the weak units that are composable with \<open>\<mu>\<close>
       on the right.  Similarly, the \emph{targets} of \<open>\<mu>\<close> are the weak units that are composable
       with \<open>\<mu>\<close> on the left.
     \<close>
 
     definition sources
     where "sources \<mu> \<equiv> {a. weak_unit a \<and> \<mu> \<star> a \<noteq> null}"
 
     lemma sourcesI [intro]:
     assumes "weak_unit a" and "\<mu> \<star> a \<noteq> null"
     shows "a \<in> sources \<mu>"
       using assms sources_def by blast
 
     lemma sourcesD [dest]:
     assumes "a \<in> sources \<mu>"
     shows "ide a" and "weak_unit a" and "\<mu> \<star> a \<noteq> null"
       using assms sources_def weak_unit_self_composable by auto
 
     definition targets
     where "targets \<mu> \<equiv> {b. weak_unit b \<and> b \<star> \<mu> \<noteq> null}"
 
     lemma targetsI [intro]:
     assumes "weak_unit b" and "b \<star> \<mu> \<noteq> null"
     shows "b \<in> targets \<mu>"
       using assms targets_def by blast
 
     lemma targetsD [dest]:
     assumes "b \<in> targets \<mu>"
     shows "ide b" and "weak_unit b" and "b \<star> \<mu> \<noteq> null"
       using assms targets_def weak_unit_self_composable by auto
 
     lemma sources_dom [simp]:
     assumes "arr \<mu>"
     shows "sources (dom \<mu>) = sources \<mu>"
       using assms hom_connected(1) by blast
 
     lemma sources_cod [simp]:
     assumes "arr \<mu>"
     shows "sources (cod \<mu>) = sources \<mu>"
       using assms hom_connected(3) by blast
 
     lemma targets_dom [simp]:
     assumes "arr \<mu>"
     shows "targets (dom \<mu>) = targets \<mu>"
       using assms hom_connected(2) by blast
 
     lemma targets_cod [simp]:
     assumes "arr \<mu>"
     shows "targets (cod \<mu>) = targets \<mu>"
       using assms hom_connected(4) by blast
 
     lemma weak_unit_iff_self_source:
     shows "weak_unit a \<longleftrightarrow> a \<in> sources a"
       using weak_unit_self_composable by auto
 
     lemma weak_unit_iff_self_target:
     shows "weak_unit b \<longleftrightarrow> b \<in> targets b"
       using weak_unit_self_composable by auto
 
     abbreviation (input) in_hhom\<^sub>W\<^sub>C  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>W\<^sub>C _\<guillemotright>")
     where "in_hhom\<^sub>W\<^sub>C \<mu> f g \<equiv> arr \<mu> \<and> f \<in> sources \<mu> \<and> g \<in> targets \<mu>"
 
     lemma sources_hcomp:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "sources (\<nu> \<star> \<mu>) = sources \<mu>"
       using assms match_1 match_3 null_agreement by blast
 
     lemma targets_hcomp:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "targets (\<nu> \<star> \<mu>) = targets \<nu>"
       using assms match_2 match_4 null_agreement by blast
 
     lemma H\<^sub>R_preserved_along_iso:
     assumes "weak_unit a" and "a \<cong> a'"
     shows "endofunctor (Right a) (H\<^sub>R a')"
     proof -
       have a: "ide a \<and> weak_unit a" using assms isomorphic_def by auto
       have a': "ide a'" using assms isomorphic_def by auto
       (* TODO: The following interpretation re-introduces unwanted notation for "in_hom" *)
       interpret R: subcategory V \<open>right a\<close> using a right_hom_is_subcategory by simp
       have *: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> H\<^sub>R a' \<mu> = \<mu> \<star> a'"
         using assms H\<^sub>R_def by simp
       have preserves_arr: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R a' \<mu>)"
         using assms a' * R.arr_char right_def weak_unit_def weak_unit_self_composable
               isomorphic_implies_equicomposable R.ide_char match_3 hcomp_simps\<^sub>W\<^sub>C(1)
               null_agreement
         by metis
       show "endofunctor R.comp (H\<^sub>R a')"
       proof
         show "\<And>\<mu>. \<not> R.arr \<mu> \<Longrightarrow> H\<^sub>R a' \<mu> = R.null"
           using assms R.arr_char R.null_char right_def H\<^sub>R_def null_agreement
                 right_respects_isomorphic
           by metis
         fix \<mu>
         assume "R.arr \<mu>"
         hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> right a \<mu> \<and> right a' \<mu> \<and> \<mu> \<star> a \<noteq> null \<and> \<mu> \<star> a' \<noteq> null"
           using assms R.arr_char right_respects_isomorphic composable_implies_arr null_agreement
                 right_def
           by metis
         show "R.arr (H\<^sub>R a' \<mu>)" using \<mu> preserves_arr by blast
         show "R.dom (H\<^sub>R a' \<mu>) = H\<^sub>R a' (R.dom \<mu>)"
           using a' \<mu> * R.arr_char R.dom_char preserves_arr hom_connected(1) right_def
           by simp
         show "R.cod (H\<^sub>R a' \<mu>) = H\<^sub>R a' (R.cod \<mu>)"
           using a' \<mu> * R.arr_char R.cod_char preserves_arr hom_connected(3) right_def
           by simp
         next
         fix \<mu> \<nu>
         assume \<mu>\<nu>: "R.seq \<nu> \<mu>"
         have \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> right a \<mu> \<and> right a' \<mu> \<and> \<mu> \<star> a \<noteq> null \<and> \<mu> \<star> a' \<noteq> null"
           using assms \<mu>\<nu> R.arr_char right_respects_isomorphic composable_implies_arr
                 null_agreement right_def
           by (elim R.seqE) metis
         have \<nu>: "\<guillemotleft>\<nu> : R.cod \<mu> \<rightarrow> R.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and>
                  right a \<nu> \<and> H \<nu> a \<noteq> null \<and> right a' \<nu> \<and> H \<nu> a' \<noteq> null"
           by (metis "*" R.cod_simp R.comp_def R.inclusion R.not_arr_null R.null_char R.seqE
               \<mu>\<nu> in_homI preserves_arr right_def)
         show "H\<^sub>R a' (R.comp \<nu> \<mu>) = R.comp (H\<^sub>R a' \<nu>) (H\<^sub>R a' \<mu>)"
         proof -
           have 1: "R.arr (H\<^sub>R a' \<nu>)"
             using \<nu> preserves_arr by blast
           have 2: "seq (\<nu> \<star> a') (\<mu> \<star> a')"
             using a' \<mu> \<nu> R.arr_char R.inclusion R.dom_char R.cod_char
                    isomorphic_implies_equicomposable
             by auto
           show ?thesis
             using a' \<mu> \<nu> \<mu>\<nu> 1 2 preserves_arr H\<^sub>R_def R.dom_simp R.cod_simp R.comp_char
                   R.seq_char R.inclusion whisker_right
             by metis
         qed
       qed
     qed
 
     lemma H\<^sub>L_preserved_along_iso:
     assumes "weak_unit a" and "a \<cong> a'"
     shows "endofunctor (Left a) (H\<^sub>L a')"
     proof -
       have a: "ide a \<and> weak_unit a" using assms isomorphic_def by auto
       have a': "ide a'" using assms isomorphic_def by auto
       (* TODO: The following interpretation re-introduces unwanted notation for "in_hom" *)
       interpret L: subcategory V \<open>left a\<close> using a left_hom_is_subcategory by simp
       have *: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> H\<^sub>L a' \<mu> = a' \<star> \<mu>"
         using assms H\<^sub>L_def by simp
       have preserves_arr: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L a' \<mu>)"
         using assms a' * L.arr_char left_def weak_unit_def weak_unit_self_composable
               isomorphic_implies_equicomposable L.ide_char match_4 hcomp_simps\<^sub>W\<^sub>C(1)
               null_agreement
         by metis
       show "endofunctor L.comp (H\<^sub>L a')"
       proof
         show "\<And>\<mu>. \<not> L.arr \<mu> \<Longrightarrow> H\<^sub>L a' \<mu> = L.null"
           using assms L.arr_char L.null_char left_def H\<^sub>L_def null_agreement
                 left_respects_isomorphic
           by metis
         fix \<mu>
         assume "L.arr \<mu>"
         hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> left a \<mu> \<and> left a' \<mu> \<and> a \<star> \<mu> \<noteq> null \<and> a' \<star> \<mu> \<noteq> null"
           using assms L.arr_char left_respects_isomorphic composable_implies_arr null_agreement
                 left_def
           by metis
         show "L.arr (H\<^sub>L a' \<mu>)" using \<mu> preserves_arr by blast
         show "L.dom (H\<^sub>L a' \<mu>) = H\<^sub>L a' (L.dom \<mu>)"
           using a' \<mu> * L.arr_char L.dom_char preserves_arr hom_connected(2) left_def
           by simp
         show "L.cod (H\<^sub>L a' \<mu>) = H\<^sub>L a' (L.cod \<mu>)"
           using a' \<mu> * L.arr_char L.cod_char preserves_arr hom_connected(4) left_def
           by simp
         next
         fix \<mu> \<nu>
         assume \<mu>\<nu>: "L.seq \<nu> \<mu>"
         have "L.arr \<mu>"
           using \<mu>\<nu> by (elim L.seqE, auto)
         hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> left a \<mu> \<and> left a' \<mu> \<and> a \<star> \<mu> \<noteq> null \<and> a' \<star> \<mu> \<noteq> null"
           using assms L.arr_char left_respects_isomorphic composable_implies_arr null_agreement
                 left_def
           by metis
         have \<nu>: "\<guillemotleft>\<nu> : L.cod \<mu> \<Rightarrow> L.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and>
                  left a \<nu> \<and> a \<star> \<nu> \<noteq> null \<and> left a' \<nu> \<and> a' \<star> \<nu> \<noteq> null"
           by (metis (mono_tags, opaque_lifting) L.arrE L.cod_simp L.seq_char \<mu>\<nu> assms(2)
               in_homI seqE left_def left_respects_isomorphic)
         show "H\<^sub>L a' (L.comp \<nu> \<mu>) = L.comp (H\<^sub>L a' \<nu>) (H\<^sub>L a' \<mu>)"
         proof -
           have 1: "L.arr (H\<^sub>L a' \<nu>)"
             using \<nu> preserves_arr by blast
           have 2: "seq (a' \<star> \<nu>) (a' \<star> \<mu>)"
             using a' \<mu> \<nu> L.arr_char L.inclusion L.dom_char L.cod_char
                   isomorphic_implies_equicomposable
             by auto
           show ?thesis
             using a' \<mu> \<nu> \<mu>\<nu> 1 2 preserves_arr H\<^sub>L_def L.dom_simp L.cod_simp L.comp_char
                   L.seq_char L.inclusion whisker_left
             by metis
         qed
       qed
     qed
 
   end
 
   subsection "Regularity"
 
   text \<open>
     We call a weak composition \emph{regular} if \<open>f \<star> a \<cong> f\<close> whenever \<open>a\<close> is a source of
     1-cell \<open>f\<close>, and \<open>b \<star> f \<cong> f\<close> whenever \<open>b\<close> is a target of \<open>f\<close>.  A consequence of regularity
     is that horizontal composability of 2-cells is fully determined by their sets of
     sources and targets.
   \<close>
 
   locale regular_weak_composition =
     weak_composition +
   assumes comp_ide_source: "\<lbrakk> a \<in> sources f; ide f \<rbrakk> \<Longrightarrow> f \<star> a \<cong> f"
   and comp_target_ide: "\<lbrakk> b \<in> targets f; ide f \<rbrakk> \<Longrightarrow> b \<star> f \<cong> f"
   begin
 
     lemma sources_determine_composability:
     assumes "a \<in> sources \<tau>"
     shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
     proof -
       have *: "\<And>\<tau>. ide \<tau> \<and> a \<in> sources \<tau> \<Longrightarrow> \<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
         using assms comp_ide_source isomorphic_implies_equicomposable match_1 match_3
         by (meson sourcesD(3))
       show ?thesis
       proof -
         have "arr \<tau>" using assms composable_implies_arr by auto
         thus ?thesis
           using assms * [of "dom \<tau>"] hom_connected(1) by auto
       qed
     qed
 
     lemma targets_determine_composability:
     assumes "b \<in> targets \<mu>"
     shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
     proof -
       have *: "\<And>\<mu>. ide \<mu> \<and> b \<in> targets \<mu> \<Longrightarrow> \<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
         using assms comp_target_ide isomorphic_implies_equicomposable match_2 match_4
         by (meson targetsD(3))
       show ?thesis
       proof -
         have "arr \<mu>" using assms composable_implies_arr by auto
         thus ?thesis
           using assms * [of "dom \<mu>"] hom_connected(2) by auto
       qed
     qed
 
     lemma composable_if_connected:
     assumes "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
     shows "\<nu> \<star> \<mu> \<noteq> null"
       using assms targets_determine_composability by blast
 
     lemma connected_if_composable:
     assumes "\<nu> \<star> \<mu> \<noteq> null"
     shows "sources \<nu> = targets \<mu>"
       using assms sources_determine_composability targets_determine_composability by blast
 
     lemma iso_hcomp\<^sub>R\<^sub>W\<^sub>C:
     assumes "iso \<mu>" and "iso \<nu>" and "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
     shows "iso (\<nu> \<star> \<mu>)"
     and "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
     proof -
       have \<mu>: "arr \<mu> \<and> \<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright> \<and>
                iso \<mu> \<and> \<guillemotleft>inv \<mu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
         using assms inv_in_hom arr_iff_in_hom iso_is_arr by auto
       have \<nu>: "arr \<nu> \<and> \<guillemotleft>\<nu> : dom \<nu> \<Rightarrow> cod \<nu>\<guillemotright> \<and>
                iso \<nu> \<and> \<guillemotleft>inv \<nu> : cod \<nu> \<Rightarrow> dom \<nu>\<guillemotright>"
         using assms inv_in_hom by blast
       have 1: "sources (inv \<nu>) \<inter> targets (inv \<mu>) \<noteq> {}"
         using assms \<mu> \<nu> sources_dom sources_cod targets_dom targets_cod arr_inv cod_inv
         by metis
       show "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
         using assms 1 \<mu> \<nu> inv_in_hom inv_is_inverse comp_inv_arr
               interchange [of "inv \<nu>" \<nu> "inv \<mu>" \<mu>] composable_if_connected
               ide_hcomp\<^sub>W\<^sub>C sources_dom targets_dom interchange [of \<nu> "inv \<nu>" \<mu> "inv \<mu>"]
               ide_hcomp\<^sub>W\<^sub>C sources_cod targets_cod ide_compE ide_dom comp_arr_inv'
               inverse_arrowsE seqI' inverse_arrowsI
         by metis
       thus "iso (\<nu> \<star> \<mu>)" by auto
     qed
 
     lemma inv_hcomp\<^sub>R\<^sub>W\<^sub>C:
     assumes "iso \<mu>" and "iso \<nu>" and "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
     shows "inv (\<nu> \<star> \<mu>) = inv \<nu> \<star> inv \<mu>"
       using assms iso_hcomp\<^sub>R\<^sub>W\<^sub>C(2) [of \<mu> \<nu>] inverse_arrow_unique [of "H \<nu> \<mu>"] inv_is_inverse
       by auto
 
   end
 
   subsection "Associativity"
 
   text \<open>
     An \emph{associative weak composition} consists of a weak composition that has been
     equipped with an \emph{associator} isomorphism: \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>\<close>
     for each composable triple \<open>(f, g, h)\<close> of 1-cells, subject to naturality and
     coherence conditions.
   \<close>
 
   locale associative_weak_composition =
     weak_composition +
   fixes \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"    ("\<a>[_, _, _]")
   assumes assoc_in_vhom\<^sub>A\<^sub>W\<^sub>C:
            "\<lbrakk> ide f; ide g; ide h; f \<star> g \<noteq> null; g \<star> h \<noteq> null \<rbrakk> \<Longrightarrow>
               \<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
   and assoc_naturality\<^sub>A\<^sub>W\<^sub>C:
            "\<lbrakk> \<tau> \<star> \<mu> \<noteq> null; \<mu> \<star> \<nu> \<noteq> null \<rbrakk> \<Longrightarrow>
               \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
   and iso_assoc\<^sub>A\<^sub>W\<^sub>C: "\<lbrakk> ide f; ide g; ide h; f \<star> g \<noteq> null; g \<star> h \<noteq> null \<rbrakk> \<Longrightarrow> iso \<a>[f, g, h]"
   and pentagon\<^sub>A\<^sub>W\<^sub>C:
            "\<lbrakk> ide f; ide g; ide h; ide k; sources f \<inter> targets g \<noteq> {};
               sources g \<inter> targets h \<noteq> {}; sources h \<inter> targets k \<noteq> {} \<rbrakk> \<Longrightarrow>
               (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) = \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
   begin
 
     lemma assoc_in_hom\<^sub>A\<^sub>W\<^sub>C:
     assumes "ide f" and "ide g" and "ide h"
     and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
     shows "sources \<a>[f, g, h] = sources h" and "targets \<a>[f, g, h] = targets f"
     and "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
     proof -
       show 1: "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
         using assms assoc_in_vhom\<^sub>A\<^sub>W\<^sub>C by simp
       show "sources \<a>[f, g, h] = sources h"
         using assms 1 sources_dom [of "\<a>[f, g, h]"] sources_hcomp match_3
         by (elim in_homE, auto)
       show "targets \<a>[f, g, h] = targets f"
         using assms 1 targets_cod [of "\<a>[f, g, h]"] targets_hcomp match_4
         by (elim in_homE, auto)
     qed
 
     lemma assoc_simps\<^sub>A\<^sub>W\<^sub>C [simp]:
     assumes "ide f" and "ide g" and "ide h"
     and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
     shows "arr \<a>[f, g, h]"
     and "dom \<a>[f, g, h] = (f \<star> g) \<star> h"
     and "cod \<a>[f, g, h] = f \<star> g \<star> h"
     proof -
       have 1: "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
         using assms assoc_in_hom\<^sub>A\<^sub>W\<^sub>C by auto
       show "arr \<a>[f, g, h]" using 1 by auto
       show "dom \<a>[f, g, h] = (f \<star> g) \<star> h" using 1 by auto
       show "cod \<a>[f, g, h] = f \<star> g \<star> h" using 1 by auto
     qed
 
     lemma assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C:
     assumes "ide f" and "ide g" and "ide h"
     and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
     shows "sources (inv \<a>[f, g, h]) = sources h" and "targets (inv \<a>[f, g, h]) = targets f"
     and "\<guillemotleft>inv \<a>[f, g, h] :  f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
     proof -
       show 1: "\<guillemotleft>inv \<a>[f, g, h] :  f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
         using assms assoc_in_hom\<^sub>A\<^sub>W\<^sub>C iso_assoc\<^sub>A\<^sub>W\<^sub>C inv_in_hom by auto
       show "sources (inv \<a>[f, g, h]) = sources h"
         using assms 1 sources_hcomp [of "f \<star> g" h] sources_cod match_3 null_agreement
         by (elim in_homE, metis)
       show "targets (inv \<a>[f, g, h]) = targets f"
         using assms 1 targets_hcomp [of f "g \<star> h"] targets_dom match_4 null_agreement
         by (elim in_homE, metis)
     qed
 
     lemma assoc'_simps\<^sub>A\<^sub>W\<^sub>C [simp]:
     assumes "ide f" and "ide g" and "ide h"
     and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
     shows "arr (inv \<a>[f, g, h])"
     and "dom (inv \<a>[f, g, h]) = f \<star> g \<star> h"
     and "cod (inv \<a>[f, g, h]) = (f \<star> g) \<star> h"
     proof -
       have 1: "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
         using assms assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C by auto
       show "arr (inv \<a>[f, g, h])" using 1 by auto
       show "dom (inv \<a>[f, g, h]) = f \<star> g \<star> h" using 1 by auto
       show "cod (inv \<a>[f, g, h]) = (f \<star> g) \<star> h" using 1 by auto
     qed
 
     lemma assoc'_naturality\<^sub>A\<^sub>W\<^sub>C:
     assumes "\<tau> \<star> \<mu> \<noteq> null" and "\<mu> \<star> \<nu> \<noteq> null"
     shows "inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) = ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> inv \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
     proof -
       have \<tau>\<mu>\<nu>: "arr \<tau> \<and> arr \<mu> \<and> arr \<nu>"
         using assms composable_implies_arr by simp
       have 0: "dom \<tau> \<star> dom \<mu> \<noteq> null \<and> dom \<mu> \<star> dom \<nu> \<noteq> null \<and>
                cod \<tau> \<star> cod \<mu> \<noteq> null \<and> cod \<mu> \<star> cod \<nu> \<noteq> null"
         using assms \<tau>\<mu>\<nu> hom_connected by simp
       have 1: "\<guillemotleft>\<tau> \<star> \<mu> \<star> \<nu> : dom \<tau> \<star> dom \<mu> \<star> dom \<nu> \<Rightarrow> cod \<tau> \<star> cod \<mu> \<star> cod \<nu>\<guillemotright>"
         using assms match_4 by auto
       have 2: "\<guillemotleft>(\<tau> \<star> \<mu>) \<star> \<nu> : (dom \<tau> \<star> dom \<mu>) \<star> dom \<nu> \<Rightarrow> (cod \<tau> \<star> cod \<mu>) \<star> cod \<nu>\<guillemotright>"
         using assms match_3 by auto
       have "(inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>)) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>] = (\<tau> \<star> \<mu>) \<star> \<nu>"
       proof -
         have "(\<tau> \<star> \<mu>) \<star> \<nu> = (inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>]) \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
           using 0 2 \<tau>\<mu>\<nu> assoc_in_hom\<^sub>A\<^sub>W\<^sub>C iso_assoc\<^sub>A\<^sub>W\<^sub>C comp_inv_arr inv_is_inverse comp_cod_arr
           by auto
         thus ?thesis
           using assms \<tau>\<mu>\<nu> 0 2 assoc_naturality\<^sub>A\<^sub>W\<^sub>C comp_assoc by metis
       qed
       thus ?thesis
         using 0 1 2 \<tau>\<mu>\<nu> iso_assoc\<^sub>A\<^sub>W\<^sub>C assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C inv_in_hom invert_side_of_triangle(2)
         by auto
       qed
 
   end
 
   subsection "Unitors"
 
   text \<open>
     For an associative weak composition with a chosen unit isomorphism \<open>\<iota> : a \<star> a \<Rightarrow> a\<close>,
     where \<open>a\<close> is a weak unit, horizontal composition on the right by \<open>a\<close> is a fully faithful
     endofunctor \<open>R\<close> of the subcategory of arrows composable on the right with \<open>a\<close>, and is
     consequently an endo-equivalence of that subcategory.  This equivalence, together with the
     associator isomorphisms and unit isomorphism \<open>\<iota>\<close>, canonically associate, with each
     identity arrow \<open>f\<close> composable on the right with \<open>a\<close>, a \emph{right unit} isomorphism
     \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close>.  These isomorphisms are the components of a natural isomorphism
     from \<open>R\<close> to the identity functor.
   \<close>
 
   locale right_hom_with_unit =
     associative_weak_composition V H \<a> +
     right_hom V H a
   for V :: "'a comp"                  (infixr "\<cdot>" 55)
   and H :: "'a comp"                  (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<a>[_, _, _]")
   and \<iota> :: 'a
   and a :: 'a +
   assumes weak_unit_a: "weak_unit a"
   and \<iota>_in_hom: "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
   and iso_\<iota>: "iso \<iota>"
   begin
 
     abbreviation R
     where "R \<equiv> H\<^sub>R a"
 
     interpretation R: endofunctor S.comp R
       using weak_unit_a weak_unit_self_composable endofunctor_H\<^sub>R by simp
     interpretation R: fully_faithful_functor S.comp S.comp R
       using weak_unit_a weak_unit_def by simp
 
     lemma fully_faithful_functor_R:
     shows "fully_faithful_functor S.comp S.comp R"
       ..
 
     definition runit  ("\<r>[_]")
     where "runit f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
 
     lemma iso_unit:
     shows "S.iso \<iota>" and "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow>\<^sub>S a\<guillemotright>"
     proof -
       show "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow>\<^sub>S a\<guillemotright>"
         using weak_unit_a S.ide_char S.arr_char right_def weak_unit_self_composable
               S.ideD(1) R.preserves_arr H\<^sub>R_def S.in_hom_char S.arr_char right_def
               \<iota>_in_hom S.ideD(1) hom_connected(3) in_homE
         by metis
       thus "S.iso \<iota>"
         using iso_\<iota> iso_char by blast
     qed
 
     lemma characteristic_iso:
     assumes "S.ide f"
     shows "\<guillemotleft>\<a>[f, a, a] : (f \<star> a) \<star> a \<Rightarrow>\<^sub>S f \<star> a \<star> a\<guillemotright>"
     and "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright>"
     and "\<guillemotleft>(f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a] : R (R f) \<Rightarrow>\<^sub>S R f\<guillemotright>"
     and "S.iso ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
     proof -
       have f: "S.ide f \<and> ide f"
         using assms S.ide_char by simp
       have a: "weak_unit a \<and> ide a \<and> S.ide a"
         using weak_unit_a S.ide_char weak_unit_def S.arr_char right_def
               weak_unit_self_composable
         by metis
       have fa: "f \<star> a \<noteq> null \<and> (f \<star> a) \<star> a \<noteq> null \<and> ((f \<star> a) \<star> a) \<star> a \<noteq> null"
         using assms S.ideD(1) R.preserves_arr H\<^sub>R_def S.not_arr_null S.null_char
         by metis
       have aa: "a \<star> a \<noteq> null"
         using a S.ideD(1) R.preserves_arr H\<^sub>R_def S.not_arr_null weak_unit_self_composable
         by auto
       have f_ia: "f \<star> \<iota> \<noteq> null"
         using assms S.ide_char right_def S.arr_char hom_connected(4) \<iota>_in_hom by auto
       show assoc_in_hom: "\<guillemotleft>\<a>[f, a, a] : (f \<star> a) \<star> a \<Rightarrow>\<^sub>S f \<star> a \<star> a\<guillemotright>"
         using a f fa hom_connected(1) [of "\<a>[f, a, a]" a] S.arr_char right_def
               match_3 match_4 S.in_hom_char weak_unit_self_composable
         by auto
       show 1: "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright>"
         using a f fa iso_unit left_hcomp_closed
         by (simp add: f_ia ide_in_hom)
       have unit_part: "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright> \<and> S.iso (f \<star> \<iota>)"
       proof -
         have "S.iso (f \<star> \<iota>)"
           using a f fa f_ia 1 VoV.arr_char VxV.inv_simp
                inv_in_hom hom_connected(2) [of f "inv \<iota>"] VoV.arr_char VoV.iso_char
                 preserves_iso iso_char iso_\<iota> S.dom_simp S.cod_simp
           by auto
         thus ?thesis using 1 by blast
       qed
       show "S.iso ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
         using assms a f fa aa hom_connected(1) [of "\<a>[f, a, a]" a] right_def
               iso_assoc\<^sub>A\<^sub>W\<^sub>C iso_char S.arr_char unit_part assoc_in_hom isos_compose
               S.isos_compose S.seqI' by auto
       show "\<guillemotleft>(f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a] : R (R f) \<Rightarrow>\<^sub>S R f\<guillemotright>"
         unfolding H\<^sub>R_def using unit_part assoc_in_hom by blast
     qed
 
     lemma runit_char:
     assumes "S.ide f"
     shows "\<guillemotleft>\<r>[f] : R f \<Rightarrow>\<^sub>S f\<guillemotright>" and "R \<r>[f] = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
     proof -
       let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
       show "\<exists>!\<mu>. ?P \<mu>"
       proof -
         have "\<exists>\<mu>. ?P \<mu>"
           using assms S.ide_char S.arr_char R.preserves_ide characteristic_iso(3) R.is_full
           by auto
         moreover have "\<forall>\<mu> \<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
           using R.is_faithful S.in_homE by metis
         ultimately show ?thesis by blast
       qed
       hence "?P (THE \<mu>. ?P \<mu>)"
         using theI' [of ?P] by fastforce
       hence 1: "?P \<r>[f]"
         unfolding runit_def by blast
       show "\<guillemotleft>\<r>[f] : R f \<Rightarrow>\<^sub>S f\<guillemotright>" using 1 by fast
       show "R \<r>[f] = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]" using 1 by fast
     qed
 
     lemma iso_runit:
     assumes "S.ide f"
     shows "S.iso \<r>[f]"
       using assms characteristic_iso(4) runit_char R.reflects_iso by metis
 
     lemma runit_eqI:
     assumes "\<guillemotleft>f : a \<Rightarrow>\<^sub>S b\<guillemotright>" and "\<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright>"
     and "R \<mu> = ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
     shows "\<mu> = \<r>[f]"
       using assms S.ide_cod runit_char [of f] by blast
 
     lemma runit_naturality:
     assumes "S.arr \<mu>"
     shows "\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu> = \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>]"
     proof -
       have 1: "\<guillemotleft>\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu> : R (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
         using assms runit_char(1) S.ide_cod by blast
       have 2: "S.par (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
         using assms 1 S.ide_dom runit_char(1)
         by (metis S.comp_in_homI' S.in_homE)
       moreover have "R (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) = R (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
       proof -
         have 3: "\<guillemotleft>\<mu> \<star> a \<star> a : S.dom \<mu> \<star> a \<star> a \<Rightarrow>\<^sub>S S.cod \<mu> \<star> a \<star> a\<guillemotright>"
           using assms weak_unit_a R.preserves_hom H\<^sub>R_def S.arr_iff_in_hom S.arr_char
           by (metis match_4 weak_unit_in_vhom weak_unit_self_right S.in_hom_char
               left_hcomp_closed S.not_arr_null S.null_char)
         have 4: "R (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) = R \<r>[S.cod \<mu>] \<cdot>\<^sub>S R (R \<mu>)"
           using assms 1 R.as_nat_trans.preserves_comp_2 by blast
         also have 5: "... = ((S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.cod \<mu>, a, a]) \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
           using assms R.preserves_arr runit_char S.ide_cod H\<^sub>R_def by auto
         also have 6: "... = (S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
           using assms S.comp_assoc by simp
         also have "... = (S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
         proof -
           have "(\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a] = \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
           proof -
             have "(\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a] = (\<mu> \<star> a \<star> a) \<cdot> \<a>[S.dom \<mu>, a, a]"
               using assms 3 S.ide_dom characteristic_iso(1) S.in_hom_char
                     S.comp_char S.dom_simp
               by fastforce
             also have "... = \<a>[S.cod \<mu>, a, a] \<cdot> ((\<mu> \<star> a) \<star> a)"
               using assms weak_unit_a assoc_naturality\<^sub>A\<^sub>W\<^sub>C [of \<mu> a a] S.dom_simp S.cod_simp
                     weak_unit_self_composable S.arr_char right_def
               by simp
             also have "... = \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
               using S.in_hom_char S.comp_char
               by (metis 2 4 5 6 R.preserves_arr S.seq_char)
             finally show ?thesis by blast
           qed
          thus ?thesis by argo
         qed
         also have "... = ((S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a)) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
           using S.comp_assoc by auto
         also have "... = ((\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>)) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
         proof -
           have "\<mu> \<star> a \<star> a \<noteq> null"
             using 3 S.not_arr_null by auto
           moreover have "S.dom \<mu> \<star> \<iota> \<noteq> null"
             using assms S.not_arr_null
             by (metis S.dom_char \<iota>_in_hom calculation hom_connected(1-2) in_homE)
           ultimately have "(S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a) = (\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>)"
             using assms weak_unit_a iso_unit S.comp_arr_dom S.comp_cod_arr
                   interchange [of "S.cod \<mu>" \<mu> \<iota> "a \<star> a"] interchange [of \<mu> "S.dom \<mu>" a \<iota>]
             by auto
           thus ?thesis by argo
         qed
         also have "... = (\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
           using S.comp_assoc by auto
         also have "... = R \<mu> \<cdot>\<^sub>S R \<r>[S.dom \<mu>]"
           using assms runit_char(2) S.ide_dom H\<^sub>R_def by auto
         also have "... = R (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
           using assms S.arr_iff_in_hom [of \<mu>] runit_char(1) S.ide_dom by fastforce
         finally show ?thesis by blast
       qed
       ultimately show "\<r>[S.cod \<mu>] \<cdot>\<^sub>S (R \<mu>) = \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>]"
         using R.is_faithful by blast
     qed
 
     abbreviation \<rr>
     where "\<rr> \<mu> \<equiv> if S.arr \<mu> then \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>] else null"
 
     interpretation \<rr>: natural_transformation S.comp S.comp R S.map \<rr>
     proof -
       interpret \<rr>: transformation_by_components S.comp S.comp R S.map runit
         using runit_char(1) runit_naturality by unfold_locales simp_all
       have "\<rr>.map = \<rr>"
         using \<rr>.is_extensional \<rr>.map_def \<rr>.naturality \<rr>.map_simp_ide S.ide_dom S.ide_cod
               S.map_def
         by auto
       thus "natural_transformation S.comp S.comp R S.map \<rr>"
         using \<rr>.natural_transformation_axioms by auto
     qed
 
     lemma natural_transformation_\<rr>:
     shows "natural_transformation S.comp S.comp R S.map \<rr>" ..
 
     interpretation \<rr>: natural_isomorphism S.comp S.comp R S.map \<rr>
       using S.ide_is_iso iso_runit runit_char(1) S.isos_compose
       by unfold_locales force
 
     lemma natural_isomorphism_\<rr>:
     shows "natural_isomorphism S.comp S.comp R S.map \<rr>" ..
 
     interpretation R: equivalence_functor S.comp S.comp R
       using natural_isomorphism_\<rr> R.isomorphic_to_identity_is_equivalence by blast
 
     lemma equivalence_functor_R:
     shows "equivalence_functor S.comp S.comp R"
       ..
 
     lemma runit_commutes_with_R:
     assumes "S.ide f"
     shows "\<r>[R f] = R \<r>[f]"
       using assms runit_char(1) R.preserves_hom [of "\<r>[f]" "R f" f]
             runit_naturality iso_runit S.iso_is_section
             S.section_is_mono S.monoE
       by (metis S.in_homE S.seqI')
 
   end
 
   text \<open>
     Symmetric results hold for the subcategory of all arrows composable on the left with
     a specified weak unit \<open>b\<close>.  This yields the \emph{left unitors}.
   \<close>
 
   locale left_hom_with_unit =
     associative_weak_composition V H \<a> +
     left_hom V H b
   for V :: "'a comp"                  (infixr "\<cdot>" 55)
   and H :: "'a comp"                  (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<a>[_, _, _]")
   and \<iota> :: 'a
   and b :: 'a +
   assumes weak_unit_b: "weak_unit b"
   and \<iota>_in_hom: "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow> b\<guillemotright>"
   and iso_\<iota>: "iso \<iota>"
   begin
 
     abbreviation L
     where "L \<equiv> H\<^sub>L b"
 
     interpretation L: endofunctor S.comp L
       using weak_unit_b weak_unit_self_composable endofunctor_H\<^sub>L by simp
     interpretation L: fully_faithful_functor S.comp S.comp L
       using weak_unit_b weak_unit_def by simp
 
     lemma fully_faithful_functor_L:
     shows "fully_faithful_functor S.comp S.comp L"
       ..
 
     definition lunit  ("\<l>[_]")
     where "lunit f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S (inv \<a>[b, b, f])"
 
     lemma iso_unit:
     shows "S.iso \<iota>" and "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow>\<^sub>S b\<guillemotright>"
     proof -
       show "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow>\<^sub>S b\<guillemotright>"
         using weak_unit_b S.ide_char S.arr_char left_def weak_unit_self_composable
               S.ideD(1) L.preserves_arr H\<^sub>L_def S.in_hom_char S.arr_char left_def
               \<iota>_in_hom S.ideD(1) hom_connected(4) in_homE
         by metis
       thus "S.iso \<iota>"
         using iso_\<iota> iso_char by blast
     qed
 
     lemma characteristic_iso:
     assumes "S.ide f"
     shows "\<guillemotleft>inv \<a>[b, b, f] :  b \<star> b \<star> f \<Rightarrow>\<^sub>S (b \<star> b) \<star> f\<guillemotright>"
     and "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright>"
     and "\<guillemotleft>(\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f] : L (L f) \<Rightarrow>\<^sub>S L f\<guillemotright>"
     and "S.iso ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
     proof -
       have f: "S.ide f \<and> ide f"
         using assms S.ide_char by simp
       have b: "weak_unit b \<and> ide b \<and> S.ide b"
         using weak_unit_b S.ide_char weak_unit_def S.arr_char left_def
               weak_unit_self_composable
         by metis
       have bf: "b \<star> f \<noteq> null \<and> b \<star> b \<star> b \<star> f \<noteq> null"
         using assms S.ideD(1) L.preserves_arr H\<^sub>L_def S.not_arr_null S.null_char
         by metis
       have bb: "b \<star> b \<noteq> null"
         using b S.ideD(1) L.preserves_arr H\<^sub>L_def S.not_arr_null weak_unit_self_composable
         by auto
       have ib_f: "\<iota> \<star> f \<noteq> null"
         using assms S.ide_char left_def S.arr_char hom_connected(3) \<iota>_in_hom
         by auto
       show assoc_in_hom: "\<guillemotleft>inv \<a>[b, b, f] : b \<star> b \<star> f \<Rightarrow>\<^sub>S (b \<star> b) \<star> f\<guillemotright>"
         using b f bf bb hom_connected(2) [of b "inv \<a>[b, b, f]"] left_def
         by (metis S.arrI S.cod_closed S.in_hom_char assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C(3) assoc'_simps\<^sub>A\<^sub>W\<^sub>C(2-3))
       show 1: "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright>"
         using b f bf right_hcomp_closed
         by (simp add: ib_f ide_in_hom iso_unit(2))
       have unit_part: "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright> \<and> S.iso (\<iota> \<star> f)"
       proof -
         have "S.iso (\<iota> \<star> f)"
           using b f bf ib_f 1 VoV.arr_char VxV.inv_simp
                inv_in_hom hom_connected(1) [of "inv \<iota>" f] VoV.arr_char VoV.iso_char
                 preserves_iso iso_char iso_\<iota> S.dom_simp S.cod_simp
           by auto
         thus ?thesis using 1 by blast
       qed
       show "S.iso ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
         using assms b f bf bb hom_connected(2) [of b "inv \<a>[b, b, f]"] left_def
               iso_assoc\<^sub>A\<^sub>W\<^sub>C iso_char S.arr_char unit_part assoc_in_hom isos_compose
               S.isos_compose S.seqI' by auto
       show "\<guillemotleft>(\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f] : L (L f) \<Rightarrow>\<^sub>S L f\<guillemotright>"
         unfolding H\<^sub>L_def using unit_part assoc_in_hom by blast
     qed
 
     lemma lunit_char:
     assumes "S.ide f"
     shows "\<guillemotleft>\<l>[f] : L f \<Rightarrow>\<^sub>S f\<guillemotright>" and "L \<l>[f] = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
     proof -
       let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
       show "\<exists>!\<mu>. ?P \<mu>"
       proof -
         have "\<exists>\<mu>. ?P \<mu>"
         proof -
           have 1: "S.ide f"
             using assms S.ide_char S.arr_char by simp
           moreover have "S.ide (L f)"
             using 1 L.preserves_ide by simp
           ultimately show ?thesis
             using assms characteristic_iso(3) L.is_full by blast
         qed
         moreover have "\<forall>\<mu> \<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
           using L.is_faithful S.in_homE by metis
         ultimately show ?thesis by blast
       qed
       hence "?P (THE \<mu>. ?P \<mu>)"
         using theI' [of ?P] by fastforce
       hence 1: "?P \<l>[f]"
         unfolding lunit_def by blast
       show "\<guillemotleft>\<l>[f] : L f \<Rightarrow>\<^sub>S f\<guillemotright>" using 1 by fast
       show "L \<l>[f] = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]" using 1 by fast
     qed
 
     lemma iso_lunit:
     assumes "S.ide f"
     shows "S.iso \<l>[f]"
       using assms characteristic_iso(4) lunit_char L.reflects_iso by metis
 
     lemma lunit_eqI:
     assumes "\<guillemotleft>f : a \<Rightarrow>\<^sub>S b\<guillemotright>" and "\<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright>"
     and "L \<mu> = ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
     shows "\<mu> = \<l>[f]"
       using assms S.ide_cod lunit_char [of f] by blast
 
     lemma lunit_naturality:
     assumes "S.arr \<mu>"
     shows "\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> = \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>]"
     proof -
       have 1: "\<guillemotleft>\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> : L (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
         using assms lunit_char(1) [of "S.cod \<mu>"] S.ide_cod by blast
       have "S.par (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
         using assms 1 S.ide_dom lunit_char(1)
         by (metis S.comp_in_homI' S.in_homE)
       moreover have "L (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) = L (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
       proof -
         have 2: "\<guillemotleft>b \<star> b \<star> \<mu> : b \<star> b \<star> S.dom \<mu> \<Rightarrow>\<^sub>S b \<star> b \<star> S.cod \<mu>\<guillemotright>"
           using assms weak_unit_b L.preserves_hom H\<^sub>L_def S.arr_iff_in_hom [of \<mu>] S.arr_char
           by simp
         have 3: "\<guillemotleft>(b \<star> b) \<star> \<mu> : (b \<star> b) \<star> S.dom \<mu> \<Rightarrow>\<^sub>S (b \<star> b) \<star> S.cod \<mu>\<guillemotright>"
           using assms weak_unit_b L.preserves_hom H\<^sub>L_def S.arr_iff_in_hom S.arr_char
           by (metis match_3 weak_unit_in_vhom weak_unit_self_left S.in_hom_char
               S.not_arr_null S.null_char right_hcomp_closed)
 
         have "L (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) = L \<l>[S.cod \<mu>] \<cdot>\<^sub>S L (L \<mu>)"
           using assms 1 L.as_nat_trans.preserves_comp_2 by blast
         also have "... = ((\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.cod \<mu>]) \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
           using assms L.preserves_arr lunit_char S.ide_cod H\<^sub>L_def by auto
         also have "... = (\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
           using S.comp_assoc by auto
         also have "... = (\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
         proof -
           have "inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>) = ((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
           proof -
             have "((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>] = ((b \<star> b) \<star> \<mu>) \<cdot> inv \<a>[b, b, S.dom \<mu>]"
               using assms 3 S.in_hom_char S.comp_char [of "(b \<star> b) \<star> \<mu>" "inv \<a>[b, b, S.dom \<mu>]"]
               by (metis S.ide_dom characteristic_iso(1) ext)
             also have "... = inv \<a>[b, b, S.cod \<mu>] \<cdot> (b \<star> b \<star> \<mu>)"
               using assms weak_unit_b assoc'_naturality\<^sub>A\<^sub>W\<^sub>C [of b b \<mu>] S.dom_simp S.cod_simp
                     weak_unit_self_composable S.arr_char left_def
               by simp
             also have "... = inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
               using assms 2 S.in_hom_char S.comp_char
               by (metis S.comp_simp S.ide_cod S.seqI' characteristic_iso(1))
             finally show ?thesis by argo
           qed
          thus ?thesis by argo
         qed
         also have "... = ((\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>)) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
           using S.comp_assoc by auto
         also have "... = ((b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>)) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
         proof -
           have "(b \<star> b) \<star> \<mu> \<noteq> null"
             using 3 S.not_arr_null by (elim S.in_homE, auto)
           moreover have "\<iota> \<star> S.dom \<mu> \<noteq> null"
             using assms S.not_arr_null
             by (metis S.dom_char \<iota>_in_hom calculation hom_connected(1-2) in_homE)
           ultimately have "(\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>) = (b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>)"
             using assms weak_unit_b iso_unit S.comp_arr_dom S.comp_cod_arr
                   interchange [of \<iota> "b \<star> b" "S.cod \<mu>" \<mu> ] interchange [of b \<iota> \<mu> "S.dom \<mu>"]
             by auto
           thus ?thesis by argo
         qed
         also have "... = (b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
           using S.comp_assoc by auto
         also have "... = L \<mu> \<cdot>\<^sub>S L \<l>[S.dom \<mu>]"
           using assms lunit_char(2) S.ide_dom H\<^sub>L_def by auto
         also have "... = L (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
           using assms S.arr_iff_in_hom [of \<mu>] lunit_char(1) S.ide_dom S.seqI
           by fastforce
         finally show ?thesis by blast
       qed
       ultimately show "\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> = \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>]"
         using L.is_faithful by blast
     qed
 
     abbreviation \<ll>
     where "\<ll> \<mu> \<equiv> if S.arr \<mu> then \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>] else null"
 
     interpretation \<ll>: natural_transformation S.comp S.comp L S.map \<ll>
     proof -
       interpret \<ll>: transformation_by_components S.comp S.comp L S.map lunit
         using lunit_char(1) lunit_naturality by (unfold_locales, simp_all)
       have "\<ll>.map = \<ll>"
         using \<ll>.is_extensional \<ll>.map_def \<ll>.naturality \<ll>.map_simp_ide S.ide_dom S.ide_cod
               S.map_def
         by auto
       thus "natural_transformation S.comp S.comp L S.map \<ll>"
         using \<ll>.natural_transformation_axioms by auto
     qed
 
     lemma natural_transformation_\<ll>:
     shows "natural_transformation S.comp S.comp L S.map \<ll>" ..
 
     interpretation \<ll>: natural_isomorphism S.comp S.comp L S.map \<ll>
       using S.ide_is_iso iso_lunit lunit_char(1) S.isos_compose
       by (unfold_locales, force)
 
     lemma natural_isomorphism_\<ll>:
     shows "natural_isomorphism S.comp S.comp L S.map \<ll>" ..
 
     interpretation L: equivalence_functor S.comp S.comp L
       using natural_isomorphism_\<ll> L.isomorphic_to_identity_is_equivalence by blast
 
     lemma equivalence_functor_L:
     shows "equivalence_functor S.comp S.comp L"
       ..
 
     lemma lunit_commutes_with_L:
     assumes "S.ide f"
     shows "\<l>[L f] = L \<l>[f]"
       using assms lunit_char(1) L.preserves_hom [of "\<l>[f]" "L f" f]
             lunit_naturality iso_lunit S.iso_is_section
             S.section_is_mono S.monoE
       by (metis S.in_homE S.seqI')
 
   end
 
   subsection "Prebicategories"
 
   text \<open>
     A \emph{prebicategory} is an associative weak composition satisfying the additional assumption
     that every arrow has a source and a target.
   \<close>
 
   locale prebicategory =
     associative_weak_composition +
   assumes arr_has_source: "arr \<mu> \<Longrightarrow> sources \<mu> \<noteq> {}"
   and arr_has_target: "arr \<mu> \<Longrightarrow> targets \<mu> \<noteq> {}"
   begin
 
     lemma arr_iff_has_src:
     shows "arr \<mu> \<longleftrightarrow> sources \<mu> \<noteq> {}"
       using arr_has_source composable_implies_arr by auto
 
     lemma arr_iff_has_trg:
     shows "arr \<mu> \<longleftrightarrow> targets \<mu> \<noteq> {}"
       using arr_has_target composable_implies_arr by auto
 
   end
 
   text \<open>
     The horizontal composition of a prebicategory is regular.
   \<close>
 
   sublocale prebicategory \<subseteq> regular_weak_composition V H
   proof
     show "\<And>a f. a \<in> sources f \<Longrightarrow> ide f \<Longrightarrow> f \<star> a \<cong> f"
     proof -
       fix a f
       assume a: "a \<in> sources f" and f: "ide f"
       interpret Right_a: subcategory V \<open>right a\<close>
         using a right_hom_is_subcategory weak_unit_self_composable by force
       interpret Right_a: right_hom_with_unit V H \<a> \<open>some_unit a\<close> a
         using a iso_some_unit by (unfold_locales, auto)
       show "f \<star> a \<cong> f"
       proof -
         have "Right_a.ide f"
           using a f Right_a.ide_char Right_a.arr_char right_def by auto
         hence "Right_a.iso (Right_a.runit f) \<and> (Right_a.runit f) \<in> Right_a.hom (f \<star> a) f"
           using Right_a.iso_runit Right_a.runit_char(1) H\<^sub>R_def by simp
         hence "iso (Right_a.runit f) \<and> (Right_a.runit f) \<in> hom (f \<star> a) f"
           using Right_a.iso_char Right_a.hom_char by auto
         thus ?thesis using f isomorphic_def by auto
       qed
     qed
     show "\<And>b f. b \<in> targets f \<Longrightarrow> ide f \<Longrightarrow> b \<star> f \<cong> f"
     proof -
       fix b f
       assume b: "b \<in> targets f" and f: "ide f"
       interpret Left_b: subcategory V \<open>left b\<close>
         using b left_hom_is_subcategory weak_unit_self_composable by force
       interpret Left_b: left_hom_with_unit V H \<a> \<open>some_unit b\<close> b
         using b iso_some_unit by (unfold_locales, auto)
       show "b \<star> f \<cong> f"
       proof -
         have "Left_b.ide f"
           using b f Left_b.ide_char Left_b.arr_char left_def by auto
         hence "Left_b.iso (Left_b.lunit f) \<and> (Left_b.lunit f) \<in> Left_b.hom (b \<star> f) f"
           using b f Left_b.iso_lunit Left_b.lunit_char(1) H\<^sub>L_def by simp
         hence "iso (Left_b.lunit f) \<and> (Left_b.lunit f) \<in> hom (b \<star> f) f"
           using Left_b.iso_char Left_b.hom_char by auto
         thus ?thesis using isomorphic_def by auto
       qed
     qed
   qed
 
   text \<open>
     The regularity allows us to show that, in a prebicategory, all sources of
     a given arrow are isomorphic, and similarly for targets.
   \<close>
 
   context prebicategory
   begin
 
     lemma sources_are_isomorphic:
     assumes "a \<in> sources \<mu>" and "a' \<in> sources \<mu>"
     shows "a \<cong> a'"
     proof -
       have \<mu>: "arr \<mu>" using assms composable_implies_arr by auto
       have "\<And>f. \<lbrakk> ide f; a \<in> sources f; a' \<in> sources f \<rbrakk> \<Longrightarrow> a \<cong> a'"
         using \<mu> assms(1) comp_ide_source comp_target_ide [of a a']
               weak_unit_self_composable(1) [of a] weak_unit_self_composable(1) [of a']
               isomorphic_transitive isomorphic_symmetric
               sources_determine_composability sourcesD(2-3)
         by (metis (full_types) connected_if_composable)
       moreover have "ide (dom \<mu>) \<and> a \<in> sources (dom \<mu>) \<and> a' \<in> sources (dom \<mu>)"
         using assms \<mu> sources_dom by auto
       ultimately show ?thesis by auto
     qed
       
     lemma targets_are_isomorphic:
     assumes "b \<in> targets \<mu>" and "b' \<in> targets \<mu>"
     shows "b \<cong> b'"
     proof -
       have \<mu>: "arr \<mu>" using assms composable_implies_arr by auto
       have "\<And>f. \<lbrakk> ide f; b \<in> targets f; b' \<in> targets f \<rbrakk> \<Longrightarrow> b \<cong> b'"
         by (metis connected_if_composable sources_are_isomorphic targetsD(3))
       moreover have "ide (dom \<mu>) \<and> b \<in> targets (dom \<mu>) \<and> b' \<in> targets (dom \<mu>)"
         using assms \<mu> targets_dom [of \<mu>] by auto
       ultimately show ?thesis by auto
     qed
 
     text \<open>
       In fact, we now show that the sets of sources and targets of a 2-cell are
       isomorphism-closed, and hence are isomorphism classes.
       We first show that the notion ``weak unit'' is preserved under isomorphism.
     \<close>
 
     interpretation H: partial_magma H
       using is_partial_magma by auto
 
     lemma isomorphism_respects_weak_units:
     assumes "weak_unit a" and "a \<cong> a'"
     shows "weak_unit a'"
     proof -
       obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<Rightarrow> a'\<guillemotright>"
         using assms by auto
       interpret Left_a: subcategory V \<open>left a\<close>
         using assms left_hom_is_subcategory by fastforce
       interpret Left_a: left_hom_with_unit V H \<a> \<open>some_unit a\<close> a
         using assms iso_some_unit weak_unit_self_composable
         apply unfold_locales by auto
       interpret Right_a: subcategory V "right a"
         using assms right_hom_is_subcategory by fastforce
       interpret Right_a: right_hom_with_unit V H \<a> \<open>some_unit a\<close> a
         using assms iso_some_unit weak_unit_self_composable
         apply unfold_locales by auto
       have a': "ide a' \<and> a \<star> a' \<noteq> null \<and> a' \<star> a \<noteq> null \<and> a' \<star> a' \<noteq> null \<and>
                 \<phi> \<star> a' \<noteq> null \<and> Left_a.ide a'"
         by (metis (no_types, lifting) Left_a.left_hom_axioms Right_a.weak_unit_a \<phi> assms(2)
             ide_cod hom_connected(1) in_homE isomorphic_implies_equicomposable(1)
             left_def left_hom_def subcategory.ideI isomorphic_implies_equicomposable(2)
             weak_unit_self_composable(3))
       have iso: "a' \<star> a' \<cong> a'"
       proof -
         have 1: "Right a' = Right a"
           using assms right_respects_isomorphic by simp
         interpret Right_a': subcategory V \<open>right a'\<close>
           using assms right_hom_is_subcategory by fastforce
         (* TODO: The previous interpretation brings in unwanted notation for in_hom. *)
         interpret Ra': endofunctor \<open>Right a'\<close> \<open>H\<^sub>R a'\<close>
           using assms a' endofunctor_H\<^sub>R by auto
         let ?\<psi> = "Left_a.lunit a' \<cdot> inv (\<phi> \<star> a')"
         have "iso ?\<psi> \<and> \<guillemotleft>?\<psi> : a' \<star> a' \<Rightarrow> a'\<guillemotright>"
         proof -
           have "iso (Left_a.lunit a') \<and> \<guillemotleft>Left_a.lunit a' : a \<star> a' \<Rightarrow> a'\<guillemotright>"
             using a' Left_a.lunit_char(1) Left_a.iso_lunit Left_a.iso_char
                   Left_a.in_hom_char H\<^sub>L_def
             by auto
           moreover have "iso (\<phi> \<star> a') \<and> \<guillemotleft>\<phi> \<star> a' : a \<star> a' \<Rightarrow> a' \<star> a'\<guillemotright>"
             using a' \<phi> 1 Right_a'.arr_char Right_a'.in_hom_char Right_a.iso_char
                   right_def Ra'.preserves_iso Ra'.preserves_hom Right_a'.iso_char
                   Ra'.preserves_dom Ra'.preserves_cod Right_a'.arr_iff_in_hom H\<^sub>R_def
             by metis
           ultimately show ?thesis
             using isos_compose by blast
         qed
         thus ?thesis using isomorphic_def by auto
       qed
       text \<open>
         We show that horizontal composition on the left and right by @{term a'}
         is naturally isomorphic to the identity functor.  This follows from the fact
         that if @{term a} is isomorphic to @{term a'}, then horizontal composition with @{term a}
         is naturally isomorphic to horizontal composition with @{term a'}, hence the latter is
         naturally isomorphic to the identity if the former is.
         This is conceptually simple, but there are tedious composability details to handle.
       \<close>  
       have 1: "Left a' = Left a \<and> Right a' = Right a"
         using assms left_respects_isomorphic right_respects_isomorphic by simp
 
       interpret L: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
         using assms weak_unit_def by simp
       interpret L': endofunctor \<open>Left a\<close> \<open>H\<^sub>L a'\<close>
         using a' 1 endofunctor_H\<^sub>L [of a'] by auto
       interpret \<Phi>: natural_isomorphism \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close> \<open>H\<^sub>L a'\<close> \<open>H\<^sub>L \<phi>\<close>
       proof
         fix \<mu>
         show "\<not> Left_a.arr \<mu> \<Longrightarrow> H\<^sub>L \<phi> \<mu> = Left_a.null"
           using left_def \<phi> H\<^sub>L_def hom_connected(1) Left_a.null_char null_agreement
                 Left_a.arr_char
           by auto
         assume "Left_a.arr \<mu>"
         hence \<mu>: "Left_a.arr \<mu> \<and> arr \<mu> \<and> a \<star> \<mu> \<noteq> null"
           using Left_a.arr_char left_def composable_implies_arr by simp
         have 2: "\<phi> \<star> \<mu> \<noteq> null"
           using assms \<phi> \<mu> Left_a.arr_char left_def hom_connected by auto
         show "Left_a.dom (H\<^sub>L \<phi> \<mu>) = H\<^sub>L a (Left_a.dom \<mu>)"
           using assms 2 \<phi> \<mu> Left_a.arr_char left_def hom_connected(2) [of a \<phi>]
                 weak_unit_self_composable match_4 Left_a.dom_char H\<^sub>L_def by auto
         show "Left_a.cod (H\<^sub>L \<phi> \<mu>) = H\<^sub>L a' (Left_a.cod \<mu>)"
           using assms 2 \<phi> \<mu> Left_a.arr_char left_def hom_connected(2) [of a \<phi>]
                 weak_unit_self_composable match_4 Left_a.cod_char H\<^sub>L_def
           by auto
         show "Left_a.comp (H\<^sub>L a' \<mu>) (H\<^sub>L \<phi> (Left_a.dom \<mu>)) = H\<^sub>L \<phi> \<mu>"
         proof -
           have "Left_a.comp (H\<^sub>L a' \<mu>) (H\<^sub>L \<phi> (Left_a.dom \<mu>)) =
                 Left_a.comp (a' \<star> \<mu>) (\<phi> \<star> dom \<mu>)"
             using assms 1 2 \<phi> \<mu> Left_a.dom_char left_def H\<^sub>L_def by simp
           also have "... = (a' \<star> \<mu>) \<cdot> (\<phi> \<star> dom \<mu>)"
           proof -
             have "Left_a.seq (a' \<star> \<mu>) (\<phi> \<star> dom \<mu>)"
             proof (intro Left_a.seqI)
               show 3: "Left_a.arr (\<phi> \<star> dom \<mu>)"
                 using assms 2 \<phi> \<mu> Left_a.arr_char left_def
                 by (metis H\<^sub>L_def L'.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1) in_homE right_connected
                     paste_1)
               show 4: "Left_a.arr (a' \<star> \<mu>)"
                 using \<mu> H\<^sub>L_def L'.preserves_arr by auto
               show "Left_a.dom (a' \<star> \<mu>) = Left_a.cod (\<phi> \<star> dom \<mu>)"
                 using a' \<phi> \<mu> 2 3 4 Left_a.dom_char Left_a.cod_char
                 by (metis Left_a.seqE Left_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_1)
             qed
             thus ?thesis using Left_a.comp_char Left_a.arr_char left_def by auto
           qed
           also have "... = a' \<cdot> \<phi> \<star> \<mu> \<cdot> dom \<mu>"
             using a' \<phi> \<mu> interchange hom_connected by auto
           also have "... = \<phi> \<star> \<mu>"
             using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
           finally show ?thesis using H\<^sub>L_def by simp
         qed
         show "Left_a.comp (H\<^sub>L \<phi> (Left_a.cod \<mu>)) (Left_a.L \<mu>) = H\<^sub>L \<phi> \<mu>"
         proof -
           have "Left_a.comp (H\<^sub>L \<phi> (Left_a.cod \<mu>)) (Left_a.L \<mu>) = Left_a.comp (\<phi> \<star> cod \<mu>) (a \<star> \<mu>)"
             using assms 1 2 \<phi> \<mu> Left_a.cod_char left_def H\<^sub>L_def by simp
           also have "... = (\<phi> \<star> cod \<mu>) \<cdot> (a \<star> \<mu>)"
           proof -
             have "Left_a.seq (\<phi> \<star> cod \<mu>) (a \<star> \<mu>)"
             proof (intro Left_a.seqI)
               show 3: "Left_a.arr (\<phi> \<star> cod \<mu>)"
                 using \<phi> \<mu> 2 Left_a.arr_char left_def
                 by (metis (no_types, lifting) H\<^sub>L_def L.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1)
                     in_homE right_connected paste_2)
               show 4: "Left_a.arr (a \<star> \<mu>)"
                 using assms \<mu> Left_a.arr_char left_def
                 using H\<^sub>L_def L.preserves_arr by auto
               show "Left_a.dom (\<phi> \<star> cod \<mu>) = Left_a.cod (a \<star> \<mu>)"
                 using assms \<phi> \<mu> 2 3 4 Left_a.dom_char Left_a.cod_char
                 by (metis Left_a.seqE Left_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_2)
             qed
             thus ?thesis using Left_a.comp_char Left_a.arr_char left_def by auto
           qed
           also have "... = \<phi> \<cdot> a \<star> cod \<mu> \<cdot> \<mu>"
             using \<phi> \<mu> interchange hom_connected by auto
           also have "... = \<phi> \<star> \<mu>"
             using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
           finally show ?thesis using H\<^sub>L_def by simp
         qed
         next
         fix \<mu>
         assume \<mu>: "Left_a.ide \<mu>"
         have 1: "\<phi> \<star> \<mu> \<noteq> null"
           using assms \<phi> \<mu> Left_a.ide_char Left_a.arr_char left_def hom_connected by auto
         show "Left_a.iso (H\<^sub>L \<phi> \<mu>)"
         proof -
           have "iso (\<phi> \<star> \<mu>)"
           proof -
             have "a \<in> sources \<phi> \<inter> targets \<mu>"
               using assms \<phi> \<mu> 1 hom_connected weak_unit_self_composable
                     Left_a.ide_char Left_a.arr_char left_def connected_if_composable
               by auto
             thus ?thesis
               using \<phi> \<mu> Left_a.ide_char ide_is_iso iso_hcomp\<^sub>R\<^sub>W\<^sub>C(1) by blast
           qed
           moreover have "left a (\<phi> \<star> \<mu>)"
             using assms 1 \<phi> weak_unit_self_composable hom_connected(2) [of a \<phi>]
                   left_def match_4 null_agreement
             by auto
           ultimately show ?thesis
             using Left_a.iso_char Left_a.arr_char left_iff_left_inv Left_a.inv_char H\<^sub>L_def
             by metis
         qed
       qed
       interpret L': equivalence_functor \<open>Left a'\<close> \<open>Left a'\<close> \<open>H\<^sub>L a'\<close>
       proof -
         have "naturally_isomorphic (Left a') (Left a') (H\<^sub>L a') (identity_functor.map (Left a'))"
         proof -
           have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a')
                                      (identity_functor.map (Left a))"
             by (meson Left_a.natural_isomorphism_\<ll> \<Phi>.natural_isomorphism_axioms
                 naturally_isomorphic_def naturally_isomorphic_symmetric
                 naturally_isomorphic_transitive)
           thus ?thesis
             using 1 by auto
         qed
         thus "equivalence_functor (Left a') (Left a') (H\<^sub>L a')"
           using 1 L'.isomorphic_to_identity_is_equivalence naturally_isomorphic_def
           by fastforce
       qed
 
       text \<open>
         Now we do the same for \<open>R'\<close>.
       \<close>
       interpret R: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
         using assms weak_unit_def by simp
       interpret R': endofunctor \<open>Right a\<close> \<open>H\<^sub>R a'\<close>
         using a' 1 endofunctor_H\<^sub>R [of a'] by auto
       interpret \<Psi>: natural_isomorphism \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close> \<open>H\<^sub>R a'\<close> \<open>H\<^sub>R \<phi>\<close>
       proof
         fix \<mu>
         show "\<not> Right_a.arr \<mu> \<Longrightarrow> H\<^sub>R \<phi> \<mu> = Right_a.null"
           using right_def \<phi> H\<^sub>R_def hom_connected Right_a.null_char Right_a.arr_char
           by auto
         assume "Right_a.arr \<mu>"
         hence \<mu>: "Right_a.arr \<mu> \<and> arr \<mu> \<and> \<mu> \<star> a \<noteq> null"
           using Right_a.arr_char right_def composable_implies_arr by simp
         have 2: "\<mu> \<star> \<phi> \<noteq> null"
           using assms \<phi> \<mu> Right_a.arr_char right_def hom_connected by auto
         show "Right_a.dom (H\<^sub>R \<phi> \<mu>) = H\<^sub>R a (Right_a.dom \<mu>)"
-          using assms 2 \<phi> \<mu> Right_a.arr_char right_def hom_connected(1) [of \<phi> a]
-                weak_unit_self_composable match_3 Right_a.dom_char H\<^sub>R_def
-          by auto
+          by (metis "2" H\<^sub>R_def R'.is_extensional Right_a.dom_simp Right_a.null_char
+              \<open>Right_a.arr \<mu>\<close> \<phi> a' hcomp_simps\<^sub>W\<^sub>C(2) in_homE match_3)
         show "Right_a.cod (H\<^sub>R \<phi> \<mu>) = H\<^sub>R a' (Right_a.cod \<mu>)"
           using assms 2 a' \<phi> \<mu> Right_a.arr_char right_def hom_connected(3) [of \<phi> a]
                 weak_unit_self_composable match_3 Right_a.cod_char H\<^sub>R_def
           by auto
         show "Right_a.comp (H\<^sub>R a' \<mu>) (H\<^sub>R \<phi> (Right_a.dom \<mu>)) = H\<^sub>R \<phi> \<mu>"
         proof -
           have "Right_a.comp (H\<^sub>R a' \<mu>) (H\<^sub>R \<phi> (Right_a.dom \<mu>)) =
                 Right_a.comp (\<mu> \<star> a') (dom \<mu> \<star> \<phi>)"
             using assms 1 2 \<phi> \<mu> Right_a.dom_char right_def H\<^sub>R_def by simp
           also have "... = (\<mu> \<star> a') \<cdot> (dom \<mu> \<star> \<phi>)"
           proof -
             have "Right_a.seq (\<mu> \<star> a') (dom \<mu> \<star> \<phi>)"
             proof (intro Right_a.seqI)
               show 3: "Right_a.arr (dom \<mu> \<star> \<phi>)"
                 using assms 2 \<phi> \<mu> Right_a.arr_char right_def
                 by (metis H\<^sub>R_def R'.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1) in_homE left_connected
                           paste_2)
               show 4: "Right_a.arr (\<mu> \<star> a')"
                 using \<mu> H\<^sub>R_def R'.preserves_arr by auto
               show "Right_a.dom (\<mu> \<star> a') = Right_a.cod (dom \<mu> \<star> \<phi>)"
                 using a' \<phi> \<mu> 2 3 4 Right_a.dom_char Right_a.cod_char
                 by (metis Right_a.seqE Right_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_2)
             qed
             thus ?thesis using Right_a.comp_char Right_a.arr_char right_def by auto
           qed
           also have "... = \<mu> \<cdot> dom \<mu> \<star> a' \<cdot> \<phi>"
             using a' \<phi> \<mu> interchange hom_connected by auto
           also have "... = \<mu> \<star> \<phi>"
             using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
           finally show ?thesis using H\<^sub>R_def by simp
         qed
         show "Right_a.comp (H\<^sub>R \<phi> (Right_a.cod \<mu>)) (Right_a.R \<mu>) = H\<^sub>R \<phi> \<mu>"
         proof -
           have "Right_a.comp (H\<^sub>R \<phi> (Right_a.cod \<mu>)) (Right_a.R \<mu>)
                   = Right_a.comp (cod \<mu> \<star> \<phi>) (\<mu> \<star> a)"
             using assms 1 2 \<phi> \<mu> Right_a.cod_char right_def H\<^sub>R_def by simp
           also have "... = (cod \<mu> \<star> \<phi>) \<cdot> (\<mu> \<star> a)"
           proof -
             have "Right_a.seq (cod \<mu> \<star> \<phi>) (\<mu> \<star> a)"
             proof (intro Right_a.seqI)
               show 3: "Right_a.arr (cod \<mu> \<star> \<phi>)"
                 using \<phi> \<mu> 2 Right_a.arr_char right_def
                 by (metis (no_types, lifting) H\<^sub>R_def R.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1)
                     in_homE left_connected paste_1)
               show 4: "Right_a.arr (\<mu> \<star> a)"
                 using assms \<mu> Right_a.arr_char right_def
                 using H\<^sub>R_def R.preserves_arr by auto
               show "Right_a.dom (cod \<mu> \<star> \<phi>) = Right_a.cod (\<mu> \<star> a)"
                 using assms \<phi> \<mu> 2 3 4 Right_a.dom_char Right_a.cod_char
                 by (metis Right_a.seqE Right_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_1)
             qed
             thus ?thesis using Right_a.comp_char Right_a.arr_char right_def by auto
           qed
           also have "... = cod \<mu> \<cdot> \<mu> \<star> \<phi> \<cdot> a"
             using \<phi> \<mu> interchange hom_connected by auto
           also have "... = \<mu> \<star> \<phi>"
             using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
           finally show ?thesis using H\<^sub>R_def by simp
         qed
         next
         fix \<mu>
         assume \<mu>: "Right_a.ide \<mu>"
         have 1: "\<mu> \<star> \<phi> \<noteq> null"
           using assms \<phi> \<mu> Right_a.ide_char Right_a.arr_char right_def hom_connected by auto
         show "Right_a.iso (H\<^sub>R \<phi> \<mu>)"
         proof -
           have "iso (\<mu> \<star> \<phi>)"
           proof -
             have "a \<in> targets \<phi> \<inter> sources \<mu>"
               using assms \<phi> \<mu> 1 hom_connected weak_unit_self_composable
                     Right_a.ide_char Right_a.arr_char right_def connected_if_composable
               by (metis (full_types) IntI targetsI)
             thus ?thesis
               using \<phi> \<mu> Right_a.ide_char ide_is_iso iso_hcomp\<^sub>R\<^sub>W\<^sub>C(1) by blast
           qed
           moreover have "right a (\<mu> \<star> \<phi>)"
             using assms 1 \<phi> weak_unit_self_composable hom_connected(1) [of \<phi> a]
                   right_def match_3 null_agreement
             by auto
           ultimately show ?thesis
             using Right_a.iso_char Right_a.arr_char right_iff_right_inv
                   Right_a.inv_char H\<^sub>R_def
             by metis
         qed
       qed
       interpret R': equivalence_functor \<open>Right a'\<close> \<open>Right a'\<close> \<open>H\<^sub>R a'\<close>
       proof -
         have "naturally_isomorphic (Right a') (Right a') (H\<^sub>R a')
                                    (identity_functor.map (Right a'))"
         proof -
           have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a') Right_a.map"
             by (meson Right_a.natural_isomorphism_\<rr> \<Psi>.natural_isomorphism_axioms
                 naturally_isomorphic_def naturally_isomorphic_symmetric
                 naturally_isomorphic_transitive)
           thus ?thesis
             using 1 by auto
         qed
         thus "equivalence_functor (Right a') (Right a') (H\<^sub>R a')"
           using 1 R'.isomorphic_to_identity_is_equivalence naturally_isomorphic_def
           by fastforce
       qed
       show "weak_unit a'"
         using weak_unit_def iso L'.fully_faithful_functor_axioms R'.fully_faithful_functor_axioms
         by blast
     qed
 
     lemma sources_iso_closed:
     assumes "a \<in> sources \<mu>" and "a \<cong> a'"
     shows "a' \<in> sources \<mu>"
       using assms isomorphism_respects_weak_units isomorphic_implies_equicomposable
       by blast
 
     lemma targets_iso_closed:
     assumes "a \<in> targets \<mu>" and "a \<cong> a'"
     shows "a' \<in> targets \<mu>"
       using assms isomorphism_respects_weak_units isomorphic_implies_equicomposable
       by blast
 
     lemma sources_eqI:
     assumes "sources \<mu> \<inter> sources \<nu> \<noteq> {}"
     shows "sources \<mu> = sources \<nu>"
       using assms sources_iso_closed sources_are_isomorphic by blast
 
     lemma targets_eqI:
     assumes "targets \<mu> \<inter> targets \<nu> \<noteq> {}"
     shows "targets \<mu> = targets \<nu>"
       using assms targets_iso_closed targets_are_isomorphic by blast
 
     text \<open>
       The sets of sources and targets of a weak unit are isomorphism classes.
     \<close>
 
     lemma sources_char:
     assumes "weak_unit a"
     shows "sources a = {x. x \<cong> a}"
       using assms sources_iso_closed weak_unit_iff_self_source sources_are_isomorphic
             isomorphic_symmetric
       by blast
 
     lemma targets_char:
     assumes "weak_unit a"
     shows "targets a = {x. x \<cong> a}"
       using assms targets_iso_closed weak_unit_iff_self_target targets_are_isomorphic
             isomorphic_symmetric
       by blast
 
   end
 
   section "Horizontal Homs"
 
   text \<open>
     Here we define a locale that axiomatizes a (vertical) category \<open>V\<close> that has been
     punctuated into ``horizontal homs'' by the choice of idempotent endofunctors \<open>src\<close> and \<open>trg\<close>
     that assign a specific ``source'' and ``target'' 1-cell to each of its arrows.
     The functors \<open>src\<close> and \<open>trg\<close> are also subject to further conditions that constrain how
     they commute with each other.
   \<close>
 
   locale horizontal_homs =
     category V +
     src: endofunctor V src +
     trg: endofunctor V trg
   for V :: "'a comp"      (infixr "\<cdot>" 55)
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a" +
   assumes ide_src [simp]: "arr \<mu> \<Longrightarrow> ide (src \<mu>)"
   and ide_trg [simp]: "arr \<mu> \<Longrightarrow> ide (trg \<mu>)"
   and src_src [simp]: "arr \<mu> \<Longrightarrow> src (src \<mu>) = src \<mu>"
   and trg_trg [simp]: "arr \<mu> \<Longrightarrow> trg (trg \<mu>) = trg \<mu>"
   and trg_src [simp]: "arr \<mu> \<Longrightarrow> trg (src \<mu>) = src \<mu>"
   and src_trg [simp]: "arr \<mu> \<Longrightarrow> src (trg \<mu>) = trg \<mu>"
   begin
 
     no_notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation in_hom           ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
 
     text \<open>
       We define an \emph{object} to be an arrow that is its own source
       (or equivalently, its own target).
     \<close>
 
     definition obj
     where "obj a \<equiv> arr a \<and> src a = a"
 
     lemma obj_def':
     shows "obj a \<longleftrightarrow> arr a \<and> trg a = a"
       using trg_src src_trg obj_def by metis
 
     lemma objI_src:
     assumes "arr a" and "src a = a"
     shows "obj a"
       using assms obj_def by simp
 
     lemma objI_trg:
     assumes "arr a" and "trg a = a"
     shows "obj a"
       using assms obj_def' by simp
 
     lemma objE [elim]:
     assumes "obj a" and "\<lbrakk> ide a; src a = a; trg a = a \<rbrakk> \<Longrightarrow> T"
     shows T
       using assms obj_def obj_def' ide_src ide_trg by metis
 
     (*
      * I believe I have sorted out the looping issues that were making these less than
      * useful, but do not make them default simps because it slows things down too much
      * and they are not used all that often.
      *)
     lemma obj_simps (* [simp] *):
     assumes "obj a"
     shows "arr a" and "src a = a" and "trg a = a" and "dom a = a" and "cod a = a"
       using assms by auto
 
     lemma obj_src [intro, simp]:
     assumes "arr \<mu>"
     shows "obj (src \<mu>)"
       using assms objI_src by auto
 
     lemma obj_trg [intro, simp]:
     assumes "arr \<mu>"
     shows "obj (trg \<mu>)"
       using assms objI_trg by auto
 
     definition in_hhom  ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     where "in_hhom \<mu> a b \<equiv> arr \<mu> \<and> src \<mu> = a \<and> trg \<mu> = b"
 
     abbreviation hhom
     where "hhom a b \<equiv> {\<mu>. \<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>}"
 
     abbreviation (input) hseq\<^sub>H\<^sub>H
     where "hseq\<^sub>H\<^sub>H \<equiv> \<lambda>\<mu> \<nu>. arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
 
     lemma in_hhomI [intro, simp]:
     assumes "arr \<mu>" and "src \<mu> = a" and "trg \<mu> = b"
     shows "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>"
       using assms in_hhom_def by auto
 
     lemma in_hhomE [elim]:
     assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>"
     and "\<lbrakk> arr \<mu>; obj a; obj b; src \<mu> = a; trg \<mu> = b \<rbrakk> \<Longrightarrow> T"
     shows "T"
       using assms in_hhom_def by auto
 
     (*
      * TODO: I tried removing the second assertion here, thinking that it should already
      * be covered by the category locale, but in fact it breaks some proofs in
      * SpanBicategory that ought to be trivial.  So it seems that the presence of
      * this introduction rule adds something, and I should consider whether this rule
      * should be added to the category locale.
      *)
     lemma ide_in_hom [intro]:
     assumes "ide f"
     shows "\<guillemotleft>f : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>f : f \<Rightarrow> f\<guillemotright>"
       using assms by auto
 
     lemma src_dom [simp]:
     shows "src (dom \<mu>) = src \<mu>"
       by (metis arr_dom_iff_arr obj_simps(4) obj_src src.is_extensional src.preserves_dom)
 
     lemma src_cod [simp]:
     shows "src (cod \<mu>) = src \<mu>"
       by (metis arr_cod_iff_arr obj_simps(5) obj_src src.is_extensional src.preserves_cod)
 
     lemma trg_dom [simp]:
     shows "trg (dom \<mu>) = trg \<mu>"
       by (metis arr_dom_iff_arr ide_char ide_trg trg.is_extensional trg.preserves_dom)
 
     lemma trg_cod [simp]:
     shows "trg (cod \<mu>) = trg \<mu>"
       by (metis arr_cod_iff_arr ide_char ide_trg trg.is_extensional trg.preserves_cod)
 
     (*
      * TODO: In theory, the following simps should already be available from the fact
      * that src and trg are endofunctors.  But they seem not to get used.
      *)
     lemma dom_src [simp]:
     shows "dom (src \<mu>) = src \<mu>"
       by (metis dom_null ideD(2) ide_src src.is_extensional)
 
     lemma cod_src [simp]:
     shows "cod (src \<mu>) = src \<mu>"
       by (metis cod_null ideD(3) ide_src src.is_extensional)
 
     lemma dom_trg [simp]:
     shows "dom (trg \<mu>) = trg \<mu>"
       by (metis dom_null ideD(2) ide_trg trg.is_extensional)
 
     lemma cod_trg [simp]:
     shows "cod (trg \<mu>) = trg \<mu>"
       by (metis cod_null ideD(3) ide_trg trg.is_extensional)
 
     lemma vcomp_in_hhom [intro, simp]:
     assumes "seq \<nu> \<mu>" and "src \<nu> = a" and "trg \<nu> = b"
     shows "\<guillemotleft>\<nu> \<cdot> \<mu> : a \<rightarrow> b\<guillemotright>"
       using assms src_cod [of "\<nu> \<cdot> \<mu>"] trg_cod [of "\<nu> \<cdot> \<mu>"] by auto
 
     lemma src_vcomp [simp]:
     assumes "seq \<nu> \<mu>"
     shows "src (\<nu> \<cdot> \<mu>) = src \<nu>"
       using assms src_cod [of "\<nu> \<cdot> \<mu>"] by auto
 
     lemma trg_vcomp [simp]:
     assumes "seq \<nu> \<mu>"
     shows "trg (\<nu> \<cdot> \<mu>) = trg \<nu>"
       using assms trg_cod [of "\<nu> \<cdot> \<mu>"] by auto
 
     lemma vseq_implies_hpar:
     assumes "seq \<nu> \<mu>"
     shows "src \<nu> = src \<mu>" and "trg \<nu> = trg \<mu>"
       using assms src_dom [of "\<nu> \<cdot> \<mu>"] trg_dom [of "\<nu> \<cdot> \<mu>"] src_cod [of "\<nu> \<cdot> \<mu>"]
             trg_cod [of "\<nu> \<cdot> \<mu>"]
       by auto
 
     lemma vconn_implies_hpar:
     assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>"
     shows "src \<mu> = src f" and "trg \<mu> = trg f" and "src g = src f" and "trg g = trg f"
       using assms by auto
 
     lemma src_inv [simp]:
     assumes "iso \<mu>"
     shows "src (inv \<mu>) = src \<mu>"
       using assms inv_in_hom iso_is_arr src_dom src_cod iso_inv_iso dom_inv by metis
 
     lemma trg_inv [simp]:
     assumes "iso \<mu>"
     shows "trg (inv \<mu>) = trg \<mu>"
       using assms inv_in_hom iso_is_arr trg_dom trg_cod iso_inv_iso cod_inv by metis
 
     lemma inv_in_hhom [intro, simp]:
     assumes "iso \<mu>" and "src \<mu> = a" and "trg \<mu> = b"
     shows "\<guillemotleft>inv \<mu> : a \<rightarrow> b\<guillemotright>"
       using assms iso_is_arr by simp
 
     lemma hhom_is_subcategory:
     shows "subcategory V (\<lambda>\<mu>. \<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>)"
       using src_dom trg_dom src_cod trg_cod by (unfold_locales, auto)
 
     lemma isomorphic_objects_are_equal:
     assumes "obj a" and "obj b" and "a \<cong> b"
     shows "a = b"
       using assms isomorphic_def
       by (metis dom_inv in_homE objE src_dom src_inv)
 
 
     text \<open>
       Having the functors \<open>src\<close> and \<open>trg\<close> allows us to form categories VV and VVV
       of formally horizontally composable pairs and triples of arrows.
     \<close>
 
     sublocale VxV: product_category V V ..
     sublocale VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
       by (unfold_locales, auto)
 
     lemma subcategory_VV:
     shows "subcategory VxV.comp (\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>))"
       ..
 
     sublocale VxVxV: product_category V VxV.comp ..
     sublocale VVV: subcategory VxVxV.comp
                             \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
                                    src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
       using VV.arr_char
       by (unfold_locales, auto)
 
     lemma subcategory_VVV:
     shows "subcategory VxVxV.comp
              (\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
                     src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>)))"
       ..
 
   end
 
   subsection "Prebicategories with Homs"
 
   text \<open>
     A \emph{weak composition with homs} consists of a weak composition that is
     equipped with horizontal homs in such a way that the chosen source and
     target of each 2-cell \<open>\<mu>\<close> in fact lie in the set of sources and targets,
     respectively, of \<open>\<mu>\<close>, such that horizontal composition respects the
     chosen sources and targets, and such that if 2-cells \<open>\<mu>\<close> and \<open>\<nu>\<close> are
     horizontally composable, then the chosen target of \<open>\<mu>\<close> coincides with
     the chosen source of \<open>\<nu>\<close>.
   \<close>
 
   locale weak_composition_with_homs =
     weak_composition +
     horizontal_homs +
   assumes src_in_sources: "arr \<mu> \<Longrightarrow> src \<mu> \<in> sources \<mu>"
   and trg_in_targets: "arr \<mu> \<Longrightarrow> trg \<mu> \<in> targets \<mu>"
   and src_hcomp': "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src (\<nu> \<star> \<mu>) = src \<mu>"
   and trg_hcomp': "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> trg (\<nu> \<star> \<mu>) = trg \<nu>"
   and seq_if_composable: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
 
   locale prebicategory_with_homs =
     prebicategory +
     weak_composition_with_homs
   begin
 
     lemma composable_char\<^sub>P\<^sub>B\<^sub>H:
     shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
       using trg_in_targets src_in_sources composable_if_connected sourcesD(3)
             targets_determine_composability seq_if_composable composable_implies_arr
       by metis
 
     lemma hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H:
     assumes "\<guillemotleft>\<mu> : a \<rightarrow>\<^sub>W\<^sub>C b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
     and "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
     proof -
       show "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
         using assms sources_determine_composability sources_hcomp targets_hcomp by auto
       thus "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
         using assms by auto
     qed
 
     text \<open>
       In a prebicategory with homs, if \<open>a\<close> is an object (i.e. \<open>src a = a\<close> and \<open>trg a = a\<close>),
       then \<open>a\<close> is a weak unit.  The converse need not hold: there can be weak units that the
       \<open>src\<close> and \<open>trg\<close> mappings send to other 1-cells in the same isomorphism class.
     \<close>
 
     lemma obj_is_weak_unit:
     assumes "obj a"
     shows "weak_unit a"
     proof -
       have "a \<in> sources a"
         using assms objE src_in_sources ideD(1) by metis
       thus ?thesis by auto
     qed
 
   end
 
   subsection "Choosing Homs"
 
   text \<open>
     Every prebicategory extends to a prebicategory with homs, by choosing an arbitrary
     representative of each isomorphism class of weak units to serve as an object.
     ``The source'' of a 2-cell is defined to be the chosen representative of the set of
      all its sources (which is an isomorphism class), and similarly for ``the target''.
   \<close>
 
   context prebicategory
   begin
 
     definition rep
     where "rep f \<equiv> SOME f'. f' \<in> { f'. f \<cong> f' }"
 
     definition some_src
     where "some_src \<mu> \<equiv> if arr \<mu> then rep (SOME a. a \<in> sources \<mu>) else null"
 
     definition some_trg
     where "some_trg \<mu> \<equiv> if arr \<mu> then rep (SOME b. b \<in> targets \<mu>) else null"
 
     lemma isomorphic_ide_rep:
     assumes "ide f"
     shows "f \<cong> rep f"
     proof -
       have "\<exists>f'. f' \<in> { f'. f \<cong> f' }"
         using assms isomorphic_reflexive by blast
       thus ?thesis using rep_def someI_ex by simp
     qed
 
     lemma rep_rep:
     assumes "ide f"
     shows "rep (rep f) = rep f"
     proof -
       have "rep f \<in> { f'. f \<cong> f' }"
         using assms isomorphic_ide_rep by simp
       have "{ f'. f \<cong> f' } = { f'. rep f \<cong> f' }"
       proof -
         have "\<And>f'. f \<cong> f' \<longleftrightarrow> rep f \<cong> f'"
         proof
           fix f'
           assume f': "f \<cong> f'"
           show "rep f \<cong> f'"
           proof -
             obtain \<phi> where \<phi>: "\<phi> \<in> hom f f' \<and> iso \<phi>"
               using f' by auto
             obtain \<psi> where \<psi>: "\<psi> \<in> hom f (rep f) \<and> iso \<psi>"
               using assms isomorphic_ide_rep by blast
             have "inv \<psi> \<in> hom (rep f) f \<and> iso (inv \<psi>)"
               using \<psi> by simp
             hence "iso (V \<phi> (inv \<psi>)) \<and> V \<phi> (inv \<psi>) \<in> hom (rep f) f'"
               using \<phi> isos_compose by auto
             thus ?thesis using isomorphic_def by auto
           qed
           next
           fix f'
           assume f': "rep f \<cong> f'"
           show "f \<cong> f'"
             using assms f' isomorphic_ide_rep isos_compose isomorphic_def
             by (meson isomorphic_transitive)
         qed
         thus ?thesis by auto
       qed
       hence "rep (rep f) = (SOME f'. f' \<in> { f'. f \<cong> f' })"
         using assms rep_def by fastforce
       also have "... = rep f"
         using assms rep_def by simp
       finally show ?thesis by simp
     qed
 
     lemma some_src_in_sources:
     assumes "arr \<mu>"
     shows "some_src \<mu> \<in> sources \<mu>"
     proof -
       have 1: "(SOME a. a \<in> sources \<mu>) \<in> sources \<mu>"
         using assms arr_iff_has_src someI_ex [of "\<lambda>a. a \<in> sources \<mu>"] by blast
       moreover have "ide (SOME a. a \<in> sources \<mu>)"
         using 1 weak_unit_self_composable by auto
       ultimately show ?thesis
         using assms 1 some_src_def sources_iso_closed isomorphic_ide_rep by metis
     qed
 
     lemma some_trg_in_targets:
     assumes "arr \<mu>"
     shows "some_trg \<mu> \<in> targets \<mu>"
     proof -
       have 1: "(SOME a. a \<in> targets \<mu>) \<in> targets \<mu>"
         using assms arr_iff_has_trg someI_ex [of "\<lambda>a. a \<in> targets \<mu>"] by blast
       moreover have "ide (SOME a. a \<in> targets \<mu>)"
         using 1 weak_unit_self_composable by auto
       ultimately show ?thesis
         using assms 1 some_trg_def targets_iso_closed isomorphic_ide_rep by metis
     qed
 
     lemma some_src_dom:
     assumes "arr \<mu>"
     shows "some_src (dom \<mu>) = some_src \<mu>"
       using assms some_src_def sources_dom by simp
 
     lemma some_src_cod:
     assumes "arr \<mu>"
     shows "some_src (cod \<mu>) = some_src \<mu>"
       using assms some_src_def sources_cod by simp
 
     lemma some_trg_dom:
     assumes "arr \<mu>"
     shows "some_trg (dom \<mu>) = some_trg \<mu>"
       using assms some_trg_def targets_dom by simp
 
     lemma some_trg_cod:
     assumes "arr \<mu>"
     shows "some_trg (cod \<mu>) = some_trg \<mu>"
       using assms some_trg_def targets_cod by simp
 
     lemma ide_some_src:
     assumes "arr \<mu>"
     shows "ide (some_src \<mu>)"
       using assms some_src_in_sources weak_unit_self_composable by blast
 
     lemma ide_some_trg:
     assumes "arr \<mu>"
     shows "ide (some_trg \<mu>)"
       using assms some_trg_in_targets weak_unit_self_composable by blast
 
     lemma some_src_composable:
     assumes "arr \<tau>"
     shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> some_src \<tau> \<star> \<mu> \<noteq> null"
       using assms some_src_in_sources sources_determine_composability by blast
 
     lemma some_trg_composable:
     assumes "arr \<sigma>"
     shows "\<mu> \<star> \<sigma> \<noteq> null \<longleftrightarrow> \<mu> \<star> some_trg \<sigma> \<noteq> null"
       using assms some_trg_in_targets targets_determine_composability by blast
 
     lemma sources_some_src:
     assumes "arr \<mu>"
     shows "sources (some_src \<mu>) = sources \<mu>"
       using assms sources_determine_composability some_src_in_sources by blast
 
     lemma targets_some_trg:
     assumes "arr \<mu>"
     shows "targets (some_trg \<mu>) = targets \<mu>"
       using assms targets_determine_composability some_trg_in_targets by blast
 
     lemma src_some_src:
     assumes "arr \<mu>"
     shows "some_src (some_src \<mu>) = some_src \<mu>"
       using assms some_src_def ide_some_src sources_some_src by force
 
     lemma trg_some_trg:
     assumes "arr \<mu>"
     shows "some_trg (some_trg \<mu>) = some_trg \<mu>"
       using assms some_trg_def ide_some_trg targets_some_trg by force
 
     lemma sources_char':
     assumes "arr \<mu>"
     shows "a \<in> sources \<mu> \<longleftrightarrow> some_src \<mu> \<cong> a"
       using assms some_src_in_sources sources_iso_closed sources_are_isomorphic by meson
 
     lemma targets_char':
     assumes "arr \<mu>"
     shows "a \<in> targets \<mu> \<longleftrightarrow> some_trg \<mu> \<cong> a"
       using assms some_trg_in_targets targets_iso_closed targets_are_isomorphic by meson
 
     text \<open>
       An arbitrary choice of sources and targets in a prebicategory results in a notion of
       formal composability that coincides with the actual horizontal composability
       of the prebicategory.
     \<close>
 
     lemma composable_char\<^sub>P\<^sub>B:
     shows "\<tau> \<star> \<sigma> \<noteq> null \<longleftrightarrow> arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
     proof
         assume \<sigma>\<tau>: "\<tau> \<star> \<sigma> \<noteq> null"
         show "arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
           using \<sigma>\<tau> composable_implies_arr connected_if_composable some_src_def some_trg_def
           by force
         next
         assume \<sigma>\<tau>: "arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
         show "\<tau> \<star> \<sigma> \<noteq> null"
           using \<sigma>\<tau> some_src_in_sources some_trg_composable by force
     qed
 
     text \<open>
       A 1-cell is its own source if and only if it is its own target.
     \<close>
 
     lemma self_src_iff_self_trg:
     assumes "ide a"
     shows "a = some_src a \<longleftrightarrow> a = some_trg a"
     proof
       assume a: "a = some_src a"
       have "weak_unit a \<and> a \<star> a \<noteq> null"
         using assms a some_src_in_sources [of a] by force
       thus "a = some_trg a" using a composable_char\<^sub>P\<^sub>B by simp
       next
       assume a: "a = some_trg a"
       have "weak_unit a \<and> a \<star> a \<noteq> null"
         using assms a some_trg_in_targets [of a] by force
       thus "a = some_src a" using a composable_char\<^sub>P\<^sub>B by simp
     qed
 
     lemma some_trg_some_src:
     assumes "arr \<mu>"
     shows "some_trg (some_src \<mu>) = some_src \<mu>"
       using assms ide_some_src some_src_def some_trg_def some_src_in_sources sources_char
             targets_char sources_some_src
       by force
 
     lemma src_some_trg:
     assumes "arr \<mu>"
     shows "some_src (some_trg \<mu>) = some_trg \<mu>"
       using assms ide_some_trg some_src_def some_trg_def some_trg_in_targets sources_char
             targets_char targets_some_trg
       by force
 
     lemma some_src_eqI:
     assumes "a \<in> sources \<mu>" and "some_src a = a"
     shows "some_src \<mu> = a"
       using assms sources_char' some_src_def some_src_in_sources sources_are_isomorphic
             isomorphic_symmetric isomorphic_transitive
       by (metis composable_char\<^sub>P\<^sub>B sourcesD(3))
 
     lemma some_trg_eqI:
     assumes "b \<in> targets \<mu>" and "some_trg b = b"
     shows "some_trg \<mu> = b"
       using assms targets_char' some_trg_def some_trg_in_targets targets_are_isomorphic
             isomorphic_symmetric isomorphic_transitive
       by (metis composable_char\<^sub>P\<^sub>B targetsD(3))
 
     lemma some_src_comp:
     assumes "\<tau> \<star> \<sigma> \<noteq> null"
     shows "some_src (\<tau> \<star> \<sigma>) = some_src \<sigma>"
     proof (intro some_src_eqI [of "some_src \<sigma>" "\<tau> \<star> \<sigma>"])
       show "some_src (some_src \<sigma>) = some_src \<sigma>"
         using assms src_some_src composable_implies_arr by simp
       show "some_src \<sigma> \<in> sources (H \<tau> \<sigma>)"
         using assms some_src_in_sources composable_char\<^sub>P\<^sub>B
         by (simp add: sources_hcomp)
     qed
 
     lemma some_trg_comp:
     assumes "\<tau> \<star> \<sigma> \<noteq> null"
     shows "some_trg (\<tau> \<star> \<sigma>) = some_trg \<tau>"
     proof (intro some_trg_eqI [of "some_trg \<tau>" "\<tau> \<star> \<sigma>"])
       show "some_trg (some_trg \<tau>) = some_trg \<tau>"
         using assms trg_some_trg composable_implies_arr by simp
       show "some_trg \<tau> \<in> targets (H \<tau> \<sigma>)"
         using assms some_trg_in_targets composable_char\<^sub>P\<^sub>B
         by (simp add: targets_hcomp)
     qed
 
     text \<open>
       The mappings that take an arrow to its chosen source or target are endofunctors
       of the vertical category, which commute with each other in the manner required
       for horizontal homs.
     \<close>
 
     interpretation S: endofunctor V some_src
       using some_src_def ide_some_src some_src_dom some_src_cod
       apply unfold_locales
           apply auto[4]
     proof -
       fix \<nu> \<mu>
       assume \<mu>\<nu>: "seq \<nu> \<mu>"
       show "some_src (\<nu> \<cdot> \<mu>) = some_src \<nu> \<cdot> some_src \<mu>"
         using \<mu>\<nu> some_src_dom [of "\<nu> \<cdot> \<mu>"] some_src_dom some_src_cod [of "\<nu> \<cdot> \<mu>"]
               some_src_cod ide_some_src
         by auto
     qed
 
     interpretation T: endofunctor V some_trg
       using some_trg_def ide_some_trg some_trg_dom some_trg_cod
       apply unfold_locales
           apply auto[4]
     proof -
       fix \<nu> \<mu>
       assume \<mu>\<nu>: "seq \<nu> \<mu>"
       show "some_trg (\<nu> \<cdot> \<mu>) = some_trg \<nu> \<cdot> some_trg \<mu>"
         using \<mu>\<nu> some_trg_dom [of "\<nu> \<cdot> \<mu>"] some_trg_dom some_trg_cod [of "\<nu> \<cdot> \<mu>"]
               some_trg_cod ide_some_trg
         by auto
     qed
 
     interpretation weak_composition_with_homs V H some_src some_trg
       apply unfold_locales
       using some_src_in_sources some_trg_in_targets
             src_some_src trg_some_trg src_some_trg some_trg_some_src
             some_src_comp some_trg_comp composable_char\<^sub>P\<^sub>B ide_some_src ide_some_trg
       by simp_all
 
     proposition extends_to_weak_composition_with_homs:
     shows "weak_composition_with_homs V H some_src some_trg"
       ..
 
     proposition extends_to_prebicategory_with_homs:
     shows "prebicategory_with_homs V H \<a> some_src some_trg"
       ..
 
   end
 
   subsection "Choosing Units"
 
   text \<open>
     A \emph{prebicategory with units} is a prebicategory equipped with a choice,
     for each weak unit \<open>a\<close>, of a ``unit isomorphism'' \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
   \<close>
 
   locale prebicategory_with_units =
     prebicategory V H \<a> +
     weak_composition V H
   for V :: "'a comp"                  (infixr "\<cdot>" 55)
   and H :: "'a comp"                  (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                  ("\<i>[_]") +
   assumes unit_in_vhom\<^sub>P\<^sub>B\<^sub>U: "weak_unit a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
   and iso_unit\<^sub>P\<^sub>B\<^sub>U: "weak_unit a \<Longrightarrow> iso \<i>[a]"
   begin
 
     lemma unit_in_hom\<^sub>P\<^sub>B\<^sub>U:
     assumes "weak_unit a"
     shows "\<guillemotleft>\<i>[a] : a \<rightarrow>\<^sub>W\<^sub>C a\<guillemotright>" and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
     proof -
       show 1: "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
         using assms unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by auto
       show "\<guillemotleft>\<i>[a] : a \<rightarrow>\<^sub>W\<^sub>C a\<guillemotright>"
         using assms 1 weak_unit_iff_self_source weak_unit_iff_self_target
               sources_cod [of "\<i>[a]"] targets_cod [of "\<i>[a]"]
         by (elim in_homE, auto)
     qed
 
     lemma unit_simps [simp]:
     assumes "weak_unit a"
     shows "arr \<i>[a]" and "dom \<i>[a] = a \<star> a" and "cod \<i>[a] = a"
       using assms unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by auto
 
   end
 
   text \<open>
     Every prebicategory extends to a prebicategory with units, simply by choosing the
     unit isomorphisms arbitrarily.
   \<close>
 
   context prebicategory
   begin
 
     proposition extends_to_prebicategory_with_units:
     shows "prebicategory_with_units V H \<a> some_unit"
       using iso_some_unit by (unfold_locales, auto)
 
   end
 
   subsection "Horizontal Composition"
 
   text \<open>
     The following locale axiomatizes a (vertical) category \<open>V\<close> with horizontal homs,
     which in addition has been equipped with a functorial operation \<open>H\<close> of
     horizontal composition from \<open>VV\<close> to \<open>V\<close>, assumed to preserve source and target.
   \<close>
 
   locale horizontal_composition =
     horizontal_homs V src trg +
     H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
   for V :: "'a comp"          (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"   (infixr "\<star>" 53)
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a" +
   assumes src_hcomp: "arr (\<mu> \<star> \<nu>) \<Longrightarrow> src (\<mu> \<star> \<nu>) = src \<nu>"
   and trg_hcomp: "arr (\<mu> \<star> \<nu>) \<Longrightarrow> trg (\<mu> \<star> \<nu>) = trg \<mu>"
   begin
     (* TODO: Why does this get re-introduced? *)
     no_notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     text \<open>
       \<open>H\<close> is a partial magma, which shares its null with \<open>V\<close>.
     \<close>
 
     lemma is_partial_magma:
     shows "partial_magma H" and "partial_magma.null H = null"
     proof -
       have 1: "\<forall>f. null \<star> f = null \<and> f \<star> null = null"
         using H.is_extensional VV.arr_char not_arr_null by auto
       interpret H: partial_magma H
         using 1 VV.arr_char H.is_extensional not_arr_null
         by unfold_locales metis
       show "partial_magma H" ..
       show "H.null = null"
         using 1 H.null_def the1_equality [of "\<lambda>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"]
         by metis
     qed
 
     text \<open>
       \textbf{Note:} The following is ``almost'' \<open>H.seq\<close>, but for that we would need
       \<open>H.arr = V.arr\<close>.
       This would be unreasonable to expect, in general, as the definition of \<open>H.arr\<close> is based
       on ``strict'' units rather than weak units.
       Later we will show that we do have \<open>H.arr = V.arr\<close> if the vertical category is discrete.
     \<close>
 
     abbreviation hseq
     where "hseq \<nu> \<mu> \<equiv> arr (\<nu> \<star> \<mu>)"
 
     lemma hseq_char:
     shows "hseq \<nu> \<mu> \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
     proof -
       have "hseq \<nu> \<mu> \<longleftrightarrow> VV.arr (\<nu>, \<mu>)"
         using H.is_extensional H.preserves_arr by force
       also have "... \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
         using VV.arr_char by force
       finally show ?thesis by blast
     qed
 
     lemma hseq_char':
     shows "hseq \<nu> \<mu> \<longleftrightarrow> \<nu> \<star> \<mu> \<noteq> null"
       using VV.arr_char H.preserves_arr H.is_extensional hseq_char [of \<nu> \<mu>] by auto
 
     lemma hseqI' [intro, simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "hseq \<nu> \<mu>"
       using assms hseq_char by simp
 
     lemma hseqI:
     assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow> c\<guillemotright>"
     shows "hseq \<nu> \<mu>"
       using assms hseq_char by auto
 
     lemma hseqE [elim]:
     assumes "hseq \<nu> \<mu>"
     and "arr \<mu> \<Longrightarrow> arr \<nu> \<Longrightarrow> src \<nu> = trg \<mu> \<Longrightarrow> T"
     shows "T"
       using assms hseq_char by simp
 
     lemma hcomp_simps [simp]:
     assumes "hseq \<nu> \<mu>"
     shows "src (\<nu> \<star> \<mu>) = src \<mu>" and "trg (\<nu> \<star> \<mu>) = trg \<nu>"
     and "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>" and "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
       using assms VV.arr_char src_hcomp apply blast
       using assms VV.arr_char trg_hcomp apply blast
       using assms VV.arr_char H.preserves_dom VV.dom_simp apply force
       using assms VV.arr_char H.preserves_cod VV.cod_simp by force
 
     lemma ide_hcomp [intro, simp]:
     assumes "ide \<nu>" and "ide \<mu>" and "src \<nu> = trg \<mu>"
     shows "ide (\<nu> \<star> \<mu>)"
       using assms VV.ide_char VV.arr_char H.preserves_ide [of "(\<nu>, \<mu>)"] by auto
 
     lemma hcomp_in_hhom [intro]:
     assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow> c\<guillemotright>"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
       using assms hseq_char by fastforce
 
     lemma hcomp_in_hhom' (* [simp] *):
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = a" and "trg \<nu> = c" and "src \<nu> = trg \<mu>"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
       using assms hseq_char by fastforce
 
     lemma hcomp_in_hhomE [elim]:
     assumes "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
     and "\<lbrakk> arr \<mu>; arr \<nu>; src \<nu> = trg \<mu>; src \<mu> = a; trg \<nu> = c \<rbrakk> \<Longrightarrow> T"
     shows T
       using assms in_hhom_def by fastforce
 
     lemma hcomp_in_vhom [intro]:
     assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>" and "\<guillemotleft>\<nu> : h \<Rightarrow> k\<guillemotright>" and "src h = trg f"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : h \<star> f \<Rightarrow> k \<star> g\<guillemotright>"
       using assms by fastforce
 
     lemma hcomp_in_vhom' (* [simp] *):
     assumes "hseq \<nu> \<mu>"
     and "dom \<mu> = f" and "dom \<nu> = h" and "cod \<mu> = g" and "cod \<nu> = k"
     assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>" and "\<guillemotleft>\<nu> : h \<Rightarrow> k\<guillemotright>" and "src h = trg f"
     shows "\<guillemotleft>\<nu> \<star> \<mu> : h \<star> f \<Rightarrow> k \<star> g\<guillemotright>"
       using assms by fastforce
 
     lemma hcomp_in_vhomE [elim]:
     assumes "\<guillemotleft>\<nu> \<star> \<mu> : f \<Rightarrow> g\<guillemotright>"
     and "\<lbrakk> arr \<mu>; arr \<nu>; src \<nu> = trg \<mu>; src \<mu> = src f; src \<mu> = src g;
            trg \<nu> = trg f; trg \<nu> = trg g \<rbrakk> \<Longrightarrow> T"
     shows T
       using assms in_hom_def
       by (metis in_homE hseqE src_cod src_dom src_hcomp trg_cod trg_dom trg_hcomp)
 
     text \<open>
       A horizontal composition yields a weak composition by simply forgetting
       the \<open>src\<close> and \<open>trg\<close> functors.
     \<close>
 
     lemma match_1:
     assumes "\<nu> \<star> \<mu> \<noteq> null" and "(\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
     shows "\<mu> \<star> \<tau> \<noteq> null"
       using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
 
     lemma match_2:
     assumes "\<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null" and "\<mu> \<star> \<tau> \<noteq> null"
     shows "\<nu> \<star> \<mu> \<noteq> null"
       using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
 
     lemma match_3:
     assumes "\<mu> \<star> \<tau> \<noteq> null" and "\<nu> \<star> \<mu> \<noteq> null"
     shows "(\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
       using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
 
     lemma match_4:
     assumes "\<mu> \<star> \<tau> \<noteq> null" and "\<nu> \<star> \<mu> \<noteq> null"
     shows "\<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null"
       using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
 
     lemma left_connected:
     assumes "seq \<nu> \<nu>'"
     shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu>' \<star> \<mu> \<noteq> null"
       using assms H.is_extensional not_arr_null VV.arr_char hseq_char'
       by (metis hseq_char seqE vseq_implies_hpar(1))
 
     lemma right_connected:
     assumes "seq \<mu> \<mu>'"
     shows "H \<nu> \<mu> \<noteq> null \<longleftrightarrow> H \<nu> \<mu>' \<noteq> null"
       using assms H.is_extensional not_arr_null VV.arr_char hseq_char'
       by (metis hseq_char seqE vseq_implies_hpar(2))
 
     proposition is_weak_composition:
     shows "weak_composition V H"
     proof -
       have 1: "(\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null)
                  = (\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>))"
         using hseq_char' by auto
       interpret VoV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null\<close>
         using 1 VV.subcategory_axioms by simp
       interpret H: "functor" VoV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
         using H.functor_axioms 1 by simp
       show ?thesis
         using match_1 match_2 match_3 match_4 left_connected right_connected
         by (unfold_locales, metis)
     qed
 
     interpretation weak_composition V H
       using is_weak_composition by auto
 
      text \<open>
       It can be shown that \<open>arr ((\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)) \<Longrightarrow> (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)\<close>.
       However, we do not have \<open>arr ((\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)) \<Longrightarrow> (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)\<close>,
       because it does not follow from \<open>arr ((\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>))\<close> that \<open>dom \<nu> = cod \<mu>\<close>
       and \<open>dom \<tau> = cod \<sigma>\<close>, only that \<open>dom \<nu> \<star> dom \<tau> = cod \<mu> \<star> cod \<sigma>\<close>.
       So we don't get interchange unconditionally.
     \<close>
 
     lemma interchange:
     assumes "seq \<nu> \<mu>" and "seq \<tau> \<sigma>"
     shows "(\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
       using assms interchange by simp
 
     lemma whisker_right:
     assumes "ide f" and "seq \<nu> \<mu>"
     shows "(\<nu> \<cdot> \<mu>) \<star> f = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
       using assms whisker_right by simp
 
     lemma whisker_left:
     assumes "ide f" and "seq \<nu> \<mu>"
     shows "f \<star> (\<nu> \<cdot> \<mu>) = (f \<star> \<nu>) \<cdot> (f \<star> \<mu>)"
       using assms whisker_left by simp
 
     lemma inverse_arrows_hcomp:
     assumes "iso \<mu>" and "iso \<nu>" and "src \<nu> = trg \<mu>"
     shows "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
     proof -
       show "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
       proof
         show "ide ((inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>))"
         proof -
           have "(inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
             using assms interchange iso_is_arr comp_inv_arr'
             by (metis arr_dom)
           thus ?thesis
             using assms iso_is_arr by simp
         qed
         show "ide ((\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>))"
         proof -
           have "(\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>) = cod \<nu> \<star> cod \<mu>"
             using assms interchange iso_is_arr comp_arr_inv'
             by (metis arr_cod)
           thus ?thesis
             using assms iso_is_arr by simp
         qed
       qed
     qed
 
     lemma iso_hcomp [intro, simp]:
     assumes "iso \<mu>" and "iso \<nu>" and "src \<nu> = trg \<mu>"
     shows "iso (\<nu> \<star> \<mu>)"
       using assms inverse_arrows_hcomp by auto
 
     (*
      * TODO: Maybe a good idea to change hcomp_in_vhom hypotheses to match this
      * and iso_hcomp.
      *)
     lemma hcomp_iso_in_hom [intro]:
     assumes "iso_in_hom \<mu> f g" and "iso_in_hom \<nu> h k" and "src \<nu> = trg \<mu>"
     shows "iso_in_hom (\<nu> \<star> \<mu>) (h \<star> f) (k \<star> g)"
       unfolding iso_in_hom_def
       using assms hcomp_in_vhom iso_hcomp iso_in_hom_def vconn_implies_hpar(1-2) by auto
 
     lemma isomorphic_implies_ide:
     assumes "f \<cong> g"
     shows "ide f" and "ide g"
       using assms isomorphic_def by auto
 
     lemma hcomp_ide_isomorphic:
     assumes "ide f" and "g \<cong> h" and "src f = trg g"
     shows "f \<star> g \<cong> f \<star> h"
     proof -
       obtain \<mu> where \<mu>: "iso \<mu> \<and> \<guillemotleft>\<mu> : g \<Rightarrow> h\<guillemotright>"
         using assms isomorphic_def by auto
       have "iso (f \<star> \<mu>) \<and> \<guillemotleft>f \<star> \<mu> : f \<star> g \<Rightarrow> f \<star> h\<guillemotright>"
         using assms \<mu> iso_hcomp by auto
       thus ?thesis
         using isomorphic_def by auto
     qed
 
     lemma hcomp_isomorphic_ide:
     assumes "f \<cong> g" and "ide h" and "src f = trg h"
     shows "f \<star> h \<cong> g \<star> h"
     proof -
       obtain \<mu> where \<mu>: "iso \<mu> \<and> \<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>"
         using assms isomorphic_def by auto
       have "iso (\<mu> \<star> h) \<and> \<guillemotleft>\<mu> \<star> h : f \<star> h \<Rightarrow> g \<star> h\<guillemotright>"
         using assms \<mu> iso_hcomp by auto
       thus ?thesis
         using isomorphic_def by auto
     qed
 
     lemma isomorphic_implies_hpar:
     assumes "f \<cong> f'"
     shows "ide f" and "ide f'" and "src f = src f'" and "trg f = trg f'"
       using assms isomorphic_def by auto
 
     lemma inv_hcomp [simp]:
     assumes "iso \<nu>" and "iso \<mu>" and "src \<nu> = trg \<mu>"
     shows "inv (\<nu> \<star> \<mu>) = inv \<nu> \<star> inv \<mu>"
       using assms inverse_arrow_unique [of "\<nu> \<star> \<mu>"] inv_is_inverse inverse_arrows_hcomp
       by auto
 
     text \<open>
       The following define the two ways of using horizontal composition to compose three arrows.
     \<close>
 
     definition HoHV
     where "HoHV \<mu> \<equiv> if VVV.arr \<mu> then (fst \<mu> \<star> fst (snd \<mu>)) \<star> snd (snd \<mu>) else null"
 
     definition HoVH
     where "HoVH \<mu> \<equiv> if VVV.arr \<mu> then fst \<mu> \<star> fst (snd \<mu>) \<star> snd (snd \<mu>) else null"
 
     lemma functor_HoHV:
     shows "functor VVV.comp V HoHV"
       apply unfold_locales
       using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char HoHV_def
           apply auto[4]
     proof -
       fix f g
       assume fg: "VVV.seq g f"
       show "HoHV (VVV.comp g f) = HoHV g \<cdot> HoHV f"
       proof -
         have "VxVxV.comp g f =
               (fst g \<cdot> fst f, fst (snd g) \<cdot> fst (snd f), snd (snd g) \<cdot> snd (snd f))"
           using fg VVV.seq_char VVV.arr_char VV.arr_char VxVxV.comp_char VxV.comp_char
           by (metis (no_types, lifting) VxV.seqE VxVxV.seqE)
         hence "HoHV (VVV.comp g f) =
               (fst g \<cdot> fst f \<star> fst (snd g) \<cdot> fst (snd f)) \<star> snd (snd g) \<cdot> snd (snd f)"
           using HoHV_def VVV.comp_simp fg by auto
         also have "... = ((fst g \<star> fst (snd g)) \<star> snd (snd g)) \<cdot>
                            ((fst f \<star> fst (snd f)) \<star> snd (snd f))"
           using fg VVV.seq_char VVV.arr_char VV.arr_char interchange
           by (metis (no_types, lifting) VxV.seqE VxVxV.seqE hseqI' src_vcomp trg_vcomp)
         also have "... = HoHV g \<cdot> HoHV f"
           using HoHV_def fg by auto
         finally show ?thesis by simp
       qed
     qed
 
     sublocale HoHV: "functor" VVV.comp V HoHV
       using functor_HoHV by simp
 
     lemma functor_HoVH:
     shows "functor VVV.comp V HoVH"
       apply unfold_locales
       using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char
             HoHV_def HoVH_def
           apply auto[4]
     proof -
       fix f g
       assume fg: "VVV.seq g f"
       show "HoVH (VVV.comp g f) = HoVH g \<cdot> HoVH f"
       proof -
         have "VxVxV.comp g f =
               (fst g \<cdot> fst f, fst (snd g) \<cdot> fst (snd f), snd (snd g) \<cdot> snd (snd f))"
           using fg VVV.seq_char VVV.arr_char VV.arr_char VxVxV.comp_char VxV.comp_char
           by (metis (no_types, lifting) VxV.seqE VxVxV.seqE)
         hence "HoVH (VVV.comp g f) =
               fst g \<cdot> fst f \<star> fst (snd g) \<cdot> fst (snd f) \<star> snd (snd g) \<cdot> snd (snd f)"
           using HoVH_def VVV.comp_simp fg by auto
         also have "... = (fst g \<star> fst (snd g) \<star> snd (snd g)) \<cdot>
                            (fst f \<star> fst (snd f) \<star> snd (snd f))"
           using fg VVV.seq_char VVV.arr_char VV.arr_char interchange
           by (metis (no_types, lifting) VxV.seqE VxVxV.seqE hseqI' src_vcomp trg_vcomp)
         also have "... = HoVH g \<cdot> HoVH f"
           using fg VVV.seq_char VVV.arr_char HoVH_def VVV.comp_char VV.arr_char
           by (metis (no_types, lifting))
         finally show ?thesis by simp
       qed
     qed
 
     sublocale HoVH: "functor" VVV.comp V HoVH
       using functor_HoVH by simp
 
     text \<open>
       The following define horizontal composition of an arrow on the left by its target
       and on the right by its source.
     \<close>
 
     abbreviation L
     where "L \<equiv> \<lambda>\<mu>. if arr \<mu> then trg \<mu> \<star> \<mu> else null"
 
     abbreviation R
     where "R \<equiv> \<lambda>\<mu>. if arr \<mu> then \<mu> \<star> src \<mu> else null"
 
     sublocale L: endofunctor V L
       using vseq_implies_hpar(2) whisker_left
       by (unfold_locales, auto)
 
     lemma endofunctor_L:
     shows "endofunctor V L"
       ..
 
     sublocale R: endofunctor V R
       using vseq_implies_hpar(1) whisker_right
       by (unfold_locales, auto)
 
     lemma endofunctor_R:
     shows "endofunctor V R"
       ..
 
   end
 
 end
diff --git a/thys/Bicategory/Pseudofunctor.thy b/thys/Bicategory/Pseudofunctor.thy
--- a/thys/Bicategory/Pseudofunctor.thy
+++ b/thys/Bicategory/Pseudofunctor.thy
@@ -1,2960 +1,2959 @@
 (*  Title:       Pseudofunctor
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Pseudofunctors"
 
 theory Pseudofunctor
 imports MonoidalCategory.MonoidalFunctor Bicategory Subbicategory InternalEquivalence Coherence
 begin
 
   text \<open>
     The traditional definition of a pseudofunctor \<open>F : C \<rightarrow> D\<close> between bicategories \<open>C\<close> and \<open>D\<close>
     is in terms of two maps: an ``object map'' \<open>F\<^sub>o\<close> that takes objects of \<open>C\<close> to objects of \<open>D\<close>
     and an ``arrow map'' \<open>F\<^sub>a\<close> that assigns to each pair of objects \<open>a\<close> and \<open>b\<close> of \<open>C\<close>
     a functor \<open>F\<^sub>a a b\<close> from the hom-category \<open>hom\<^sub>C a b\<close> to the hom-category \<open>hom\<^sub>D (F\<^sub>o a) (F\<^sub>o b)\<close>.
     In addition, there is assigned to each object \<open>a\<close> of \<open>C\<close> an invertible 2-cell
     \<open>\<guillemotleft>\<Psi> a : F\<^sub>o a \<Rightarrow>\<^sub>D (F\<^sub>a a a) a\<guillemotright>\<close>, and to each pair \<open>(f, g)\<close> of composable 1-cells of C there
     is assigned an invertible 2-cell \<open>\<guillemotleft>\<Phi> (f, g) : F g \<star> F f \<Rightarrow> F (g \<star> f)\<guillemotright>\<close>, all subject to
     naturality and coherence conditions.
 
     In keeping with the ``object-free'' style in which we have been working, we do not wish
     to adopt a definition of pseudofunctor that distinguishes between objects and other
     arrows.  Instead, we would like to understand a pseudofunctor as an ordinary functor between
     (vertical) categories that weakly preserves horizontal composition in a suitable sense.
     So, we take as a starting point that a pseudofunctor \<open>F : C \<rightarrow> D\<close> is a functor from
     \<open>C\<close> to \<open>D\<close>, when these are regarded as ordinary categories with respect to vertical
     composition.  Next, \<open>F\<close> should preserve source and target, but only ``weakly''
     (up to isomorphism, rather than ``on the nose'').
     Weak preservation of horizontal composition is expressed by specifying, for each horizontally
     composable pair of vertical identities \<open>(f, g)\<close> of \<open>C\<close>, a ``compositor''
     \<open>\<guillemotleft>\<Phi> (f, g) : F g \<star> F f \<Rightarrow> F (g \<star> f)\<guillemotright>\<close> in \<open>D\<close>, such that the \<open>\<Phi> (f, g)\<close> are the components
     of a natural isomorphism.
     Associators must also be weakly preserved by F; this is expressed by a coherence
     condition that relates an associator \<open>\<a>\<^sub>C[f, g, h]\<close> in \<open>C\<close>, its image \<open>F \<a>\<^sub>C[f, g, h]\<close>,
     the associator \<open>\<a>\<^sub>D[F f, F g, F h]\<close> in \<open>D\<close> and compositors involving \<open>f\<close>, \<open>g\<close>, and \<open>h\<close>.
     As regards the weak preservation of unitors, just as for monoidal functors,
     which are in fact pseudofunctors between one-object bicategories, it is only necessary
     to assume that \<open>F \<i>\<^sub>C[a]\<close> and \<open>\<i>\<^sub>D[F a]\<close> are isomorphic in \<open>D\<close> for each object \<open>a\<close> of \<open>C\<close>,
     for there is then a canonical way to obtain, for each \<open>a\<close>, an isomorphism
     \<open>\<guillemotleft>\<Psi> a : src (F a) \<rightarrow> F a\<guillemotright>\<close> that satisfies the usual coherence conditions relating the
     unitors and the associators.  Note that the map \<open>a \<mapsto> src (F a)\<close> amounts to the traditional
     ``object map'' \<open>F\<^sub>o\<close>, so that this becomes a derived notion, rather than a primitive one.
   \<close>
 
   subsection "Weak Arrows of Homs"
 
   text \<open>
     We begin with a locale that defines a functor between ``horizontal homs'' that preserves
     source and target up to isomorphism.
   \<close>
 
   locale weak_arrow_of_homs =
     C: horizontal_homs C src\<^sub>C trg\<^sub>C +
     D: horizontal_homs D src\<^sub>D trg\<^sub>D +
     "functor" C D F
   for C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd" +
   assumes weakly_preserves_src: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D.isomorphic (F (src\<^sub>C \<mu>)) (src\<^sub>D (F \<mu>))"
   and weakly_preserves_trg: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D.isomorphic (F (trg\<^sub>C \<mu>)) (trg\<^sub>D (F \<mu>))"
   begin
 
     lemma isomorphic_src:
     assumes "C.obj a"
     shows "D.isomorphic (src\<^sub>D (F a)) (F a)"
       using assms weakly_preserves_src [of a] D.isomorphic_symmetric by auto
 
     lemma isomorphic_trg:
     assumes "C.obj a"
     shows "D.isomorphic (trg\<^sub>D (F a)) (F a)"
       using assms weakly_preserves_trg [of a] D.isomorphic_symmetric by auto
 
     abbreviation (input) hseq\<^sub>C
     where "hseq\<^sub>C \<mu> \<nu> \<equiv> C.arr \<mu> \<and> C.arr \<nu> \<and> src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
 
     abbreviation (input) hseq\<^sub>D
     where "hseq\<^sub>D \<mu> \<nu> \<equiv> D.arr \<mu> \<and> D.arr \<nu> \<and> src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
 
     lemma preserves_hseq:
     assumes "hseq\<^sub>C \<mu> \<nu>"
     shows "hseq\<^sub>D (F \<mu>) (F \<nu>)"
       by (metis D.isomorphic_def D.src_src D.src_trg D.vconn_implies_hpar(3)
           assms preserves_reflects_arr weakly_preserves_src weakly_preserves_trg)
 
     text \<open>
       Though \<open>F\<close> does not preserve objects ``on the nose'', we can recover from it the
       usual ``object map'', which does.
       It is slightly confusing at first to get used to the idea that applying the
       object map of a weak arrow of homs to an object does not give the same thing
       as applying the underlying functor, but rather only something isomorphic to it.
 
       The following defines the object map associated with \<open>F\<close>.
     \<close>
 
     definition map\<^sub>0
     where "map\<^sub>0 a \<equiv> src\<^sub>D (F a)"
 
     lemma map\<^sub>0_simps [simp]:
     assumes "C.obj a"
     shows "D.obj (map\<^sub>0 a)"
     and "src\<^sub>D (map\<^sub>0 a) = map\<^sub>0 a" and "trg\<^sub>D (map\<^sub>0 a) = map\<^sub>0 a"
     and "D.dom (map\<^sub>0 a) = map\<^sub>0 a" and "D.cod (map\<^sub>0 a) = map\<^sub>0 a"
       using assms map\<^sub>0_def by auto
 
     lemma preserves_src [simp]:
     assumes "C.arr \<mu>"
     shows "src\<^sub>D (F \<mu>) = map\<^sub>0 (src\<^sub>C \<mu>)"
       using assms
       by (metis C.src.preserves_arr C.src_src C.trg_src map\<^sub>0_def preserves_hseq)
 
     lemma preserves_trg [simp]:
     assumes "C.arr \<mu>"
     shows "trg\<^sub>D (F \<mu>) = map\<^sub>0 (trg\<^sub>C \<mu>)"
       using assms map\<^sub>0_def preserves_hseq C.src_trg C.trg.preserves_arr by presburger
 
     lemma preserves_hhom [intro]:
     assumes "C.arr \<mu>"
     shows "D.in_hhom (F \<mu>) (map\<^sub>0 (src\<^sub>C \<mu>)) (map\<^sub>0 (trg\<^sub>C \<mu>))"
       using assms by simp
 
     text \<open>
       We define here the lifting of \<open>F\<close> to a functor \<open>FF: CC \<rightarrow> DD\<close>.
       We need this to define the domains and codomains of the compositors.
     \<close>
 
     definition FF
     where "FF \<equiv> \<lambda>\<mu>\<nu>. if C.VV.arr \<mu>\<nu> then (F (fst \<mu>\<nu>), F (snd \<mu>\<nu>)) else D.VV.null"
 
     sublocale FF: "functor" C.VV.comp D.VV.comp FF
     proof -
       have 1: "\<And>\<mu>\<nu>. C.VV.arr \<mu>\<nu> \<Longrightarrow> D.VV.arr (FF \<mu>\<nu>)"
         unfolding FF_def using C.VV.arr_char D.VV.arr_char preserves_hseq by simp
       show "functor C.VV.comp D.VV.comp FF"
       proof
         fix \<mu>\<nu>
         show "\<not> C.VV.arr \<mu>\<nu> \<Longrightarrow> FF \<mu>\<nu> = D.VV.null"
           using FF_def by simp
         show "C.VV.arr \<mu>\<nu> \<Longrightarrow> D.VV.arr (FF \<mu>\<nu>)"
           using 1 by simp
         assume \<mu>\<nu>: "C.VV.arr \<mu>\<nu>"
         show "D.VV.dom (FF \<mu>\<nu>) = FF (C.VV.dom \<mu>\<nu>)"
           using \<mu>\<nu> 1 FF_def C.VV.arr_char D.VV.arr_char C.VV.dom_simp D.VV.dom_simp
           by simp
         show "D.VV.cod (FF \<mu>\<nu>) = FF (C.VV.cod \<mu>\<nu>)"
           using \<mu>\<nu> 1 FF_def C.VV.arr_char D.VV.arr_char C.VV.cod_simp D.VV.cod_simp
           by simp
         next
         fix \<mu>\<nu> \<tau>\<pi>
         assume 2: "C.VV.seq \<mu>\<nu> \<tau>\<pi>"
         show "FF (C.VV.comp \<mu>\<nu> \<tau>\<pi>) = D.VV.comp (FF \<mu>\<nu>) (FF \<tau>\<pi>)"
         proof -
           have "FF (C.VV.comp \<mu>\<nu> \<tau>\<pi>) = (F (fst \<mu>\<nu>) \<cdot>\<^sub>D F (fst \<tau>\<pi>), F (snd \<mu>\<nu>) \<cdot>\<^sub>D F (snd \<tau>\<pi>))"
             using 1 2 FF_def C.VV.comp_char C.VxV.comp_char C.VV.arr_char
             by (metis (no_types, lifting) C.VV.seq_char C.VxV.seqE fst_conv
                 as_nat_trans.preserves_comp_2 snd_conv)
           also have "... = D.VV.comp (FF \<mu>\<nu>) (FF \<tau>\<pi>)"
             using 1 2 FF_def D.VV.comp_char D.VxV.comp_char C.VV.arr_char D.VV.arr_char
                   C.VV.seq_char C.VxV.seqE preserves_seq
-            by (simp, meson)
+            by simp meson
           finally show ?thesis by simp
         qed
       qed
     qed
 
     lemma functor_FF:
     shows "functor C.VV.comp D.VV.comp FF"
       ..
 
   end
 
   subsection "Definition of Pseudofunctors"
 
   text \<open>
     I don't much like the term "pseudofunctor", which is suggestive of something that
     is ``not really'' a functor.  In the development here we can see that a pseudofunctor
     is really a \emph{bona fide} functor with respect to vertical composition,
     which happens to have in addition a weak preservation property with respect to
     horizontal composition.
     This weak preservation of horizontal composition is captured by extra structure,
     the ``compositors'', which are the components of a natural transformation.
     So ``pseudofunctor'' is really a misnomer; it's an actual functor that has been equipped
     with additional structure relating to horizontal composition.  I would use the term
     ``bifunctor'' for such a thing, but it seems to not be generally accepted and also tends
     to conflict with the usage of that term to refer to an ordinary functor of two
     arguments; which I have called a ``binary functor''.  Sadly, there seem to be no other
     plausible choices of terminology, other than simply ``functor''
     (recommended on n-Lab @{url \<open>https://ncatlab.org/nlab/show/pseudofunctor\<close>}),
     but that is not workable here because we need a name that does not clash with that
     used for an ordinary functor between categories.
   \<close>
 
   locale pseudofunctor =
     C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
     D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
     weak_arrow_of_homs V\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D src\<^sub>D trg\<^sub>D F +
     FoH\<^sub>C: composite_functor C.VV.comp V\<^sub>C V\<^sub>D \<open>\<lambda>\<mu>\<nu>. H\<^sub>C (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> F +
     H\<^sub>DoFF: composite_functor C.VV.comp D.VV.comp V\<^sub>D
              FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>D (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> +
     \<Phi>: natural_isomorphism C.VV.comp V\<^sub>D H\<^sub>DoFF.map FoH\<^sub>C.map \<Phi>
   for V\<^sub>C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd"
   and \<Phi> :: "'c * 'c \<Rightarrow> 'd" +
   assumes assoc_coherence:
             "\<lbrakk> C.ide f; C.ide g; C.ide h; src\<^sub>C f = trg\<^sub>C g; src\<^sub>C g = trg\<^sub>C h \<rbrakk> \<Longrightarrow>
                F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
                \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
   begin
 
     no_notation C.in_hom                  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     no_notation D.in_hom                  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
     notation C.in_hhom                    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation C.in_hom                     ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hhom                    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
     notation D.in_hom                     ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>D _\<guillemotright>")
 
     notation C.lunit                      ("\<l>\<^sub>C[_]")
     notation C.runit                      ("\<r>\<^sub>C[_]")
     notation C.lunit'                     ("\<l>\<^sub>C\<^sup>-\<^sup>1[_]")
     notation C.runit'                     ("\<r>\<^sub>C\<^sup>-\<^sup>1[_]")
     notation C.\<a>'                         ("\<a>\<^sub>C\<^sup>-\<^sup>1[_, _, _]")
     notation D.lunit                      ("\<l>\<^sub>D[_]")
     notation D.runit                      ("\<r>\<^sub>D[_]")
     notation D.lunit'                     ("\<l>\<^sub>D\<^sup>-\<^sup>1[_]")
     notation D.runit'                     ("\<r>\<^sub>D\<^sup>-\<^sup>1[_]")
     notation D.\<a>'                         ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]")
 
     lemma weakly_preserves_objects:
     assumes "C.obj a"
     shows "D.isomorphic (map\<^sub>0 a) (F a)"
       using assms weakly_preserves_src [of a] D.isomorphic_symmetric by auto
 
     lemma cmp_in_hom [intro]:
     assumes "C.ide a" and "C.ide b" and "src\<^sub>C a = trg\<^sub>C b"
     shows "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
     and "\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>"
     proof -
       show "\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>"
         using assms C.VV.arr_char C.VV.dom_char C.VV.cod_char FF_def by auto
       thus "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
         using assms D.vconn_implies_hpar by auto
     qed
 
     lemma cmp_simps [simp]:
     assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
     shows "D.arr (\<Phi> (f, g))"
     and "src\<^sub>D (\<Phi> (f, g)) = src\<^sub>D (F g)" and "trg\<^sub>D (\<Phi> (f, g)) = trg\<^sub>D (F f)"
     and "D.dom (\<Phi> (f, g)) = F f \<star>\<^sub>D F g" and "D.cod (\<Phi> (f, g)) = F (f \<star>\<^sub>C g)"
       using assms cmp_in_hom by simp_all blast+
 
     lemma cmp_in_hom':
     assumes "C.arr \<mu>" and "C.arr \<nu>" and "src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
     shows "\<guillemotleft>\<Phi> (\<mu>, \<nu>) : map\<^sub>0 (src\<^sub>C \<nu>) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C \<mu>)\<guillemotright>"
     and "\<guillemotleft>\<Phi> (\<mu>, \<nu>) : F (C.dom \<mu>) \<star>\<^sub>D F (C.dom \<nu>) \<Rightarrow>\<^sub>D F (C.cod \<mu> \<star>\<^sub>C C.cod \<nu>)\<guillemotright>"
     proof -
       show "\<guillemotleft>\<Phi> (\<mu>, \<nu>) : F (C.dom \<mu>) \<star>\<^sub>D F (C.dom \<nu>) \<Rightarrow>\<^sub>D F (C.cod \<mu> \<star>\<^sub>C C.cod \<nu>)\<guillemotright>"
         using assms C.VV.arr_char C.VV.dom_char C.VV.cod_char FF_def by auto
       thus "\<guillemotleft>\<Phi> (\<mu>, \<nu>) : map\<^sub>0 (src\<^sub>C \<nu>) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C \<mu>)\<guillemotright>"
         using assms D.vconn_implies_hpar by auto
     qed
 
     lemma cmp_simps':
     assumes "C.arr \<mu>" and "C.arr \<nu>" and "src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
     shows "D.arr (\<Phi> (\<mu>, \<nu>))"
     and "src\<^sub>D (\<Phi> (\<mu>, \<nu>)) = map\<^sub>0 (src\<^sub>C \<nu>)" and "trg\<^sub>D (\<Phi> (\<mu>, \<nu>)) = map\<^sub>0 (trg\<^sub>C \<mu>)"
     and "D.dom (\<Phi> (\<mu>, \<nu>)) = F (C.dom \<mu>) \<star>\<^sub>D F (C.dom \<nu>)"
     and "D.cod (\<Phi> (\<mu>, \<nu>)) = F (C.cod \<mu> \<star>\<^sub>C C.cod \<nu>)"
-      using assms cmp_in_hom' by simp_all blast+
+      using assms cmp_in_hom' by blast+
 
     lemma cmp_components_are_iso [simp]:
     assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
     shows "D.iso (\<Phi> (f, g))"
       using assms C.VV.ide_char C.VV.arr_char by simp
 
     lemma weakly_preserves_hcomp:
     assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
     shows "D.isomorphic (F f \<star>\<^sub>D F g) (F (f \<star>\<^sub>C g))"
       using assms D.isomorphic_def by auto
 
   end
 
   context pseudofunctor
   begin
 
     text \<open>
       The following defines the image of the unit isomorphism \<open>\<i>\<^sub>C[a]\<close> under \<open>F\<close>.
       We will use \<open>(F a, \<i>[a])\<close> as an ``alternate unit'', to substitute for
       \<open>(src\<^sub>D (F a), \<i>\<^sub>D[src\<^sub>D (F a)])\<close>.
     \<close>
 
     abbreviation (input) \<i>  ("\<i>[_]")
     where "\<i>[a] \<equiv> F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a)"
 
     lemma \<i>_in_hom [intro]:
     assumes "C.obj a"
     shows "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a\<guillemotright>"
     and "\<guillemotleft>\<i>[a] : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F a\<guillemotright>"
     proof (unfold map\<^sub>0_def)
       show "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F a\<guillemotright>"
         using assms preserves_hom cmp_in_hom
         by (intro D.comp_in_homI, auto)
       show "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : src\<^sub>D (F a) \<rightarrow>\<^sub>D src\<^sub>D (F a)\<guillemotright>"
         using assms C.VV.arr_char C.VV.dom_simp C.VV.cod_simp
         by (intro D.vcomp_in_hhom D.seqI, auto)
     qed
 
     lemma \<i>_simps [simp]:
     assumes "C.obj a"
     shows "D.arr (\<i> a)"
     and "src\<^sub>D \<i>[a] = map\<^sub>0 a" and "trg\<^sub>D \<i>[a] = map\<^sub>0 a"
     and "D.dom \<i>[a] = F a \<star>\<^sub>D F a" and "D.cod \<i>[a] = F a"
       using assms \<i>_in_hom by auto
 
     lemma iso_\<i>:
     assumes "C.obj a"
     shows "D.iso \<i>[a]"
       using assms C.iso_unit C.obj_self_composable(1) C.seq_if_composable
       by (meson C.objE D.isos_compose \<i>_simps(1) cmp_components_are_iso preserves_iso)
 
     text \<open>
       If \<open>a\<close> is an object of \<open>C\<close> and we have an isomorphism \<open>\<guillemotleft>\<Phi> (a, a) : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C a)\<guillemotright>\<close>,
       then there is a canonical way to define a compatible isomorphism \<open>\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>\<close>.
       Specifically, we take \<open>\<Psi> a\<close> to be the unique isomorphism \<open>\<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>\<close> such that
       \<open>\<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)\<close>.
     \<close>
 
     definition unit
     where "unit a \<equiv> THE \<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and>
                          \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
 
     lemma unit_char:
     assumes "C.obj a"
     shows "\<guillemotleft>unit a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" and "D.iso (unit a)"
     and "unit a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (unit a \<star>\<^sub>D unit a)"
     and "\<exists>!\<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
     proof -
       let ?P = "\<lambda>\<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
       show "\<exists>!\<psi>. ?P \<psi>"
       proof -
         have "D.obj (map\<^sub>0 a)"
           using assms by simp
         moreover have "D.isomorphic (map\<^sub>0 a) (F a)"
           unfolding map\<^sub>0_def
           using assms isomorphic_src by simp
         ultimately show ?thesis
           using assms D.unit_unique_upto_unique_iso \<Phi>.preserves_hom \<i>_in_hom iso_\<i> by simp
       qed
       hence 1: "?P (unit a)"
         using assms unit_def the1I2 [of ?P ?P] by simp
       show "\<guillemotleft>unit a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" using 1 by simp
       show "D.iso (unit a)" using 1 by simp
       show "unit a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (unit a \<star>\<^sub>D unit a)"
         using 1 by simp
     qed
 
     lemma unit_simps [simp]:
     assumes "C.obj a"
     shows "D.arr (unit a)"
     and "src\<^sub>D (unit a) = map\<^sub>0 a" and "trg\<^sub>D (unit a) = map\<^sub>0 a"
     and "D.dom (unit a) = map\<^sub>0 a" and "D.cod (unit a) = F a"
       using assms unit_char(1)
           apply auto
        apply (metis D.vconn_implies_hpar(1) map\<^sub>0_simps(2))
       by (metis D.vconn_implies_hpar(2) map\<^sub>0_simps(3))
 
     lemma unit_in_hom [intro]:
     assumes "C.obj a"
     shows "\<guillemotleft>unit a : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a\<guillemotright>"
     and "\<guillemotleft>unit a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>"
       using assms by auto
 
     lemma unit_eqI:
     assumes "C.obj a" and "\<guillemotleft>\<mu>: map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" and "D.iso \<mu>"
     and "\<mu> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i> a \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<mu>)"
     shows "\<mu> = unit a"
       using assms unit_def unit_char
             the1_equality [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<mu> \<and>
                                    \<mu> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<mu>)" \<mu>]
       by simp
 
     text \<open>
       The following defines the unique isomorphism satisfying the characteristic conditions
       for the left unitor \<open>\<l>\<^sub>D[trg\<^sub>D (F f)]\<close>, but using the ``alternate unit'' \<open>\<i>[trg\<^sub>C f]\<close>
       instead of \<open>\<i>\<^sub>D[trg\<^sub>D (F f)]\<close>, which is used to define \<open>\<l>\<^sub>D[trg\<^sub>D (F f)]\<close>.
     \<close>
 
     definition lF
     where "lF f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
                          F (trg\<^sub>C f) \<star>\<^sub>D \<mu> =(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
 
     lemma lF_char:
     assumes "C.ide f"
     shows "\<guillemotleft>lF f : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright>"
     and "F (trg\<^sub>C f) \<star>\<^sub>D lF f = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
     and "\<exists>!\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
                    F (trg\<^sub>C f) \<star>\<^sub>D \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
     proof -
       let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
                      F (trg\<^sub>C f) \<star>\<^sub>D \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
       show "\<exists>!\<mu>. ?P \<mu>"
       proof -
         interpret Df: prebicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D
           using D.is_prebicategory by simp
         interpret S: subcategory \<open>(\<cdot>\<^sub>D)\<close> \<open>Df.left (F (trg\<^sub>C f))\<close>
           using assms Df.left_hom_is_subcategory by simp
         interpret Df: left_hom \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<open>F (trg\<^sub>C f)\<close>
           using assms D.weak_unit_char
           by unfold_locales simp
         interpret Df: left_hom_with_unit \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<open>\<i>[trg\<^sub>C f]\<close> \<open>F (trg\<^sub>C f)\<close>
           using assms \<i>_in_hom iso_\<i>  D.weak_unit_char(1) assms weakly_preserves_trg
           by unfold_locales auto
         have "\<exists>!\<mu>. \<guillemotleft>\<mu> : Df.L (F f) \<Rightarrow>\<^sub>S F f\<guillemotright> \<and>
                    Df.L \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>S \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
         proof -
           have "Df.left (F (trg\<^sub>C f)) (F f)"
             using assms weakly_preserves_src D.isomorphic_def D.hseq_char D.hseq_char'
                   Df.left_def
             by fastforce
           thus ?thesis
             using assms Df.lunit_char(3) S.ide_char S.arr_char by simp
         qed
         moreover have "Df.L (F f) = F (trg\<^sub>C f) \<star>\<^sub>D F f"
           using assms by (simp add: Df.H\<^sub>L_def)
         moreover have "\<And>\<mu>. Df.L \<mu> = F (trg\<^sub>C f) \<star>\<^sub>D \<mu>"
           using Df.H\<^sub>L_def by simp
         moreover have "(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>S \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f] =
                        (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
           by (metis (no_types, lifting) D.arrI D.ext D.hseqI' D.hseq_char' D.seqE
               D.seq_if_composable D.vconn_implies_hpar(1) D.vconn_implies_hpar(2-3)
               D.vconn_implies_hpar(4) Df.\<iota>_in_hom Df.arr_\<omega> S.comp_char S.in_hom_char
               calculation(1,3))
         moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<longleftrightarrow>
                             \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>S F f\<guillemotright>"
           using assms S.in_hom_char S.arr_char
           by (metis D.in_homE Df.hom_connected(2) Df.left_def calculation(1-2))
         ultimately show ?thesis by simp
       qed
       hence 1: "?P (lF f)"
         using lF_def the1I2 [of ?P ?P] by simp
       show "\<guillemotleft>lF f : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright>"
         using 1 by simp
       show "F (trg\<^sub>C f) \<star>\<^sub>D lF f = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
         using 1 by simp
     qed
 
     lemma lF_simps [simp]:
     assumes "C.ide f"
     shows "D.arr (lF f)"
     and "src\<^sub>D (lF f) = map\<^sub>0 (src\<^sub>C f)" and "trg\<^sub>D (lF f) = map\<^sub>0 (trg\<^sub>C f)"
     and "D.dom (lF f) = F (trg\<^sub>C f) \<star>\<^sub>D F f" and "D.cod (lF f) = F f"
       using assms lF_char(1)
           apply auto[5]
       unfolding map\<^sub>0_def
       using assms
        apply (metis C.ideD(1) D.vconn_implies_hpar(1,3) map\<^sub>0_def preserves_src)
       by (metis C.ideD(1) C.src_trg C.trg.preserves_arr D.in_homE D.trg_cod
           preserves_src preserves_trg)
 
     text \<open>
       \sloppypar
       The next two lemmas generalize the eponymous results from
       @{theory MonoidalCategory.MonoidalFunctor}.  See the proofs of those results for diagrams.
     \<close>
 
     lemma lunit_coherence1:
     assumes "C.ide f"
     shows "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (unit (trg\<^sub>C f) \<star>\<^sub>D F f) = lF f"
     proof -
       let ?b = "trg\<^sub>C f"
       have 1: "trg\<^sub>D (F f) = map\<^sub>0 ?b"
         using assms by simp
       have "lF f \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D F f) = \<l>\<^sub>D[F f]"
       proof -
         have "D.par (lF f \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D F f)) \<l>\<^sub>D[F f]"
           using assms 1 D.lunit_in_hom unit_char(1-2) lF_char(1) D.ideD(1) by auto
         moreover have "map\<^sub>0 ?b \<star>\<^sub>D (lF f \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D F f)) = map\<^sub>0 ?b \<star>\<^sub>D \<l>\<^sub>D[F f]"
         proof -
           have "map\<^sub>0 ?b \<star>\<^sub>D (lF f \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D F f)) =
                 (map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (map\<^sub>0 ?b \<star>\<^sub>D unit ?b \<star>\<^sub>D F f)"
             using assms D.objE [of "map\<^sub>0 (trg\<^sub>C f)"]
                   D.whisker_left [of "map\<^sub>0 ?b" "lF f" "unit ?b \<star>\<^sub>D F f"]
             by auto
           also have "... = (map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D
                              (D.inv (unit ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D unit ?b \<star>\<^sub>D F f)"
           proof -
             have "(D.inv (unit ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D unit ?b \<star>\<^sub>D F f) =
                   D.inv (unit ?b) \<cdot>\<^sub>D unit ?b \<star>\<^sub>D F ?b \<cdot>\<^sub>D unit ?b \<star>\<^sub>D F f \<cdot>\<^sub>D F f"
               using assms unit_char(1-2)
                     D.interchange [of "F ?b" "unit ?b" "F f" "F f"]
                     D.interchange [of "D.inv (unit ?b)" "unit ?b" "F ?b \<star>\<^sub>D F f" "unit ?b \<star>\<^sub>D F f"]
               by simp
             also have "... = map\<^sub>0 ?b \<star>\<^sub>D unit ?b \<star>\<^sub>D F f"
               using assms unit_char(1-2) [of ?b] D.comp_arr_dom D.comp_cod_arr D.comp_inv_arr
               by (simp add: D.inv_is_inverse)
             finally show ?thesis by simp
           qed
           also have "... =
                      (D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (unit ?b \<star>\<^sub>D unit ?b \<star>\<^sub>D F f)"
           proof -
             have "(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (D.inv (unit ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) =
                   (D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
             proof -
               have "(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (D.inv (unit ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) =
                     D.inv (unit ?b) \<star>\<^sub>D lF f"
                 using assms unit_char(1-2) lF_char(1) D.comp_arr_dom D.comp_cod_arr
                       D.interchange [of "map\<^sub>0 ?b" "D.inv (unit ?b)" "lF f" "F ?b \<star>\<^sub>D F f"]
                 by simp
               also have "... = D.inv (unit ?b) \<cdot>\<^sub>D F ?b \<star>\<^sub>D F f \<cdot>\<^sub>D lF f"
                 using assms unit_char(1-2) lF_char(1) D.comp_arr_dom D.comp_cod_arr
                       D.inv_in_hom
                 by auto
               also have "... = (D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
                 using assms unit_char(1-2) lF_char(1) D.inv_in_hom
                       D.interchange [of "D.inv (unit ?b)" "F ?b" "F f" "lF f"]
                 by simp
               finally show ?thesis by simp
             qed
             thus ?thesis
               using assms unit_char(1-2) D.inv_in_hom D.comp_assoc by metis
           qed
           also have "... = (D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f] \<cdot>\<^sub>D
                            (unit ?b \<star>\<^sub>D unit ?b \<star>\<^sub>D F f)"
             using assms unit_char(1-2) lF_char(2) D.comp_assoc by auto
           also have "... = ((D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D
                            ((unit ?b \<star>\<^sub>D unit ?b) \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[map\<^sub>0 ?b, map\<^sub>0 ?b, F f]"
             using assms unit_char(1-2) D.assoc'_naturality [of "unit ?b" "unit ?b" "F f"] D.comp_assoc
             by (simp add: \<open>trg\<^sub>D (F f) = map\<^sub>0 (trg\<^sub>C f)\<close>)
           also have "... = (\<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[map\<^sub>0 ?b, map\<^sub>0 ?b, F f]"
           proof -
             have "((D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((unit ?b \<star>\<^sub>D unit ?b) \<star>\<^sub>D F f)) =
                   \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
             proof -
               have "((D.inv (unit ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((unit ?b \<star>\<^sub>D unit ?b) \<star>\<^sub>D F f)) =
                     D.inv (unit ?b) \<cdot>\<^sub>D unit ?b \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
                 using assms 1 D.unit_in_hom D.whisker_right [of "F f"] unit_char(2-3)
                       D.invert_side_of_triangle(1)
                 by (metis C.ideD(1) C.obj_trg D.seqI' map\<^sub>0_simps(1) unit_in_hom(2) preserves_ide)
               also have "... = \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
               proof -
                 have "(D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D unit (trg\<^sub>C f)) \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 ?b] = \<i>\<^sub>D[map\<^sub>0 ?b]"
                   by (simp add: D.comp_cod_arr D.comp_inv_arr D.inv_is_inverse unit_char(2)
                       assms)
                 thus ?thesis
                   by (simp add: D.comp_assoc)
               qed
               finally show ?thesis by blast
             qed
             thus ?thesis by simp
           qed
           also have "... = map\<^sub>0 ?b \<star>\<^sub>D \<l>\<^sub>D[F f]"
             using assms D.lunit_char [of "F f"] \<open>trg\<^sub>D (F f) = map\<^sub>0 ?b\<close> by simp
           finally show ?thesis by blast
         qed
         ultimately show ?thesis
           using assms D.L.is_faithful
           by (metis D.trg_cod D.trg_vcomp D.vseq_implies_hpar(2) lF_simps(3))
       qed
       thus ?thesis
         using assms 1 unit_char(1-2) C.ideD(1) C.obj_trg D.inverse_arrows_hcomp(1)
               D.invert_side_of_triangle(2) D.lunit_simps(1) unit_simps(2) preserves_ide
               D.iso_hcomp as_nat_iso.components_are_iso
         by metis
     qed
 
     lemma lunit_coherence2:
     assumes "C.ide f"
     shows "lF f = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)"
     proof -
       let ?b = "trg\<^sub>C f"
       have "D.par (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f)) (lF f)"
         using assms cmp_simps'(1) cmp_simps(4-5) by force
       moreover have "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f) = F ?b \<star>\<^sub>D lF f"
       proof -
         have "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f) = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D \<Phi> (?b, f))"
           using assms cmp_in_hom D.whisker_left [of "F ?b" "F \<l>\<^sub>C[f]" "\<Phi> (?b, f)"]
           by (simp add: calculation)
         also have "... = F ?b \<star>\<^sub>D lF f"
         proof -
           have "(F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D \<Phi> (?b, f))
                   = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D
                     \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
           proof -
             have 1: "D.seq (F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f])
                            (\<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f))"
               using assms by fastforce
             hence 2: "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
                          (\<Phi> (?b, ?b) \<star>\<^sub>D F f)
                         = (F ?b \<star>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F ?b, F ?b, F f]"
               using assms cmp_in_hom assoc_coherence cmp_components_are_iso
                     D.invert_side_of_triangle(1)
                       [of "F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f)"
                           "\<Phi> (?b, ?b \<star>\<^sub>C f)"
                           "(F ?b \<star>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F ?b, F ?b, F f]"]
                     C.ideD(1) C.ide_hcomp C.trg_hcomp C.trg_trg C.src_trg C.trg.preserves_ide
               by metis
             hence "F ?b \<star>\<^sub>D \<Phi> (?b, f)
                       = (D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
                         (\<Phi> (?b, ?b) \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
             proof -
               have "D.seq (D.inv (\<Phi> (trg\<^sub>C f, trg\<^sub>C f \<star>\<^sub>C f)))
                           (F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D
                              (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f))"
                 using assms 1 D.hseq_char by auto
               moreover have "(F (trg\<^sub>C f) \<star>\<^sub>D \<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F (trg\<^sub>C f), F (trg\<^sub>C f), F f] =
                              D.inv (\<Phi> (trg\<^sub>C f, trg\<^sub>C f \<star>\<^sub>C f)) \<cdot>\<^sub>D
                                F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D
                                (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f)"
                 using assms 2 by simp
               ultimately show ?thesis
                 using assms
                       D.invert_side_of_triangle(2)
                         [of "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
                              (\<Phi> (?b, ?b) \<star>\<^sub>D F f)"
                             "F ?b \<star>\<^sub>D \<Phi> (?b, f)" "\<a>\<^sub>D[F ?b, F ?b, F f]"]
                 by fastforce
             qed
             thus ?thesis
               using D.comp_assoc by simp
           qed
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
                            (D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)) \<cdot>\<^sub>D
                            \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D
                            \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
           proof -
             have 1: "F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) = F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[?b, ?b, f])"
               using assms C.lunit_char(1-2) C.unit_in_hom preserves_inv by auto
             have "F \<a>\<^sub>C[?b, ?b, f] = D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)"
             proof -
               have "F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D D.inv (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)) =
                     D.inv (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[?b, ?b, f]))"
                 using assms by (simp add: C.iso_unit D.inv_comp)
               thus ?thesis
                 using assms 1 D.invert_side_of_triangle D.iso_inv_iso
                 by (metis C.iso_hcomp C.ideD(1) C.ide_is_iso C.iso_lunit C.iso_unit
                     C.lunit_simps(3) C.obj_trg C.src_trg C.trg.as_nat_iso.components_are_iso
                     C.unit_simps(2) D.arr_inv D.inv_inv preserves_iso)
             qed
             thus ?thesis by argo
           qed
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
                            D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f)) \<cdot>\<^sub>D
                            (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
             using D.comp_assoc by auto
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
                            D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D (\<Phi> (?b, f) \<cdot>\<^sub>D (F \<i>\<^sub>C[?b] \<star>\<^sub>D F f)) \<cdot>\<^sub>D
                            (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
             using assms \<Phi>.naturality [of "(\<i>\<^sub>C[?b], f)"] FF_def C.VV.arr_char C.VV.cod_char
                   C.VV.dom_char
             by simp
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
                            D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f) \<cdot>\<^sub>D
                            ((F \<i>\<^sub>C[?b] \<star>\<^sub>D F f)) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D
                            \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
             using D.comp_assoc by auto
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
                            D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D
                            \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
             using assms by (simp add: D.comp_assoc D.whisker_right)
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D
                            (D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D
                            (F ?b \<star>\<^sub>D lF f)"
             using D.comp_assoc assms lF_char(2) by presburger
           also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
           proof -
             have "D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) =
                   D.inv (((F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f))) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
               using assms D.comp_inv_arr D.comp_inv_arr' cmp_simps(4)
                     D.comp_arr_dom D.comp_assoc
               by simp
             also have "... = D.inv (D.inv (\<Phi> (?b, f)) \<cdot>\<^sub>D F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
             proof -
               have 1: "\<Phi> (?b, f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) = F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)"
                 using assms \<Phi>.naturality [of "(?b, \<l>\<^sub>C[f])"] FF_def C.VV.arr_char
                       C.VV.cod_char D.VV.null_char C.VV.dom_simp
                 by simp
               have "(F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) =
                     D.inv (\<Phi> (?b, f)) \<cdot>\<^sub>D F (?b \<star>\<^sub>C \<l>\<^sub>C[f])"
               proof -
                 have "D.seq (\<Phi> (?b, f)) (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])"
                   using assms cmp_in_hom(2) [of ?b f] by auto
                 moreover have "D.iso (\<Phi> (?b, f)) \<and> D.iso (\<Phi> (?b, ?b \<star>\<^sub>C f))"
                   using assms by simp
                 ultimately show ?thesis
                 using 1 D.invert_opposite_sides_of_square by simp
               qed
               thus ?thesis
                 using D.comp_assoc by auto
             qed
             also have "... = D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D \<Phi> (?b, f)"
             proof -
               have "D.iso (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
                 using assms D.isos_compose C.VV.arr_char C.iso_lunit C.VV.dom_simp
                       C.VV.cod_simp
                 by simp
               moreover have "D.iso (D.inv (\<Phi> (?b, f)))"
                 using assms by simp
               moreover have "D.seq (D.inv (\<Phi> (?b, f))) (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
                 using assms C.VV.arr_char C.VV.dom_simp C.VV.cod_simp by simp
               ultimately show ?thesis
                 using assms D.inv_comp by simp
             qed
             also have "... = D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)"
               using D.comp_assoc D.inv_comp assms cmp_simps'(1) cmp_simps(5) by force
             finally have "D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])
                             = D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)"
               by blast
             thus ?thesis by argo
           qed
           also have "... = ((F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
             using D.comp_assoc by simp
           also have "... = F ?b \<star>\<^sub>D lF f"
             using assms D.comp_arr_inv' [of "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]"] D.comp_cod_arr by simp
           finally show ?thesis by simp
         qed
         ultimately show ?thesis by simp
       qed
       ultimately show ?thesis
         using assms D.L.is_faithful
         by (metis D.in_homI lF_char(2-3) lF_simps(4-5))
     qed
 
     lemma lunit_coherence:
     assumes "C.ide f"
     shows "\<l>\<^sub>D[F f] = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f)"
     proof -
       have "\<l>\<^sub>D[F f] = (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f)"
         by (metis C.ideD(1) C.obj_trg D.inv_inv D.invert_side_of_triangle(2)
             D.iso_hcomp D.iso_inv_iso as_nat_iso.components_are_iso assms lF_simps(1)
             lunit_coherence1 lunit_coherence2 preserves_trg unit_char(2) unit_simps(2))
       thus ?thesis
         using assms D.comp_assoc by simp
     qed
 
     text \<open>
       We postpone proving the dual version of this result until after we have developed
       the notion of the ``op bicategory'' in the next section.
     \<close>
 
   end
 
   subsection "Pseudofunctors and Opposite Bicategories"
 
   text \<open>
     There are three duals to a bicategory:
     \begin{enumerate}
       \item ``op'': sources and targets are exchanged;
       \item ``co'': domains and codomains are exchanged;
       \item ``co-op'': both sources and targets and domains and codomains are exchanged.
     \end{enumerate}
     Here we consider the "op" case.
   \<close>
 
   locale op_bicategory =
     B: bicategory V H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
   for V :: "'a comp"               (infixr "\<cdot>" 55)
   and H\<^sub>B :: "'a comp"              (infixr "\<star>\<^sub>B" 53)
   and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<a>\<^sub>B[_, _, _]")
   and \<i>\<^sub>B :: "'a \<Rightarrow> 'a"              ("\<i>\<^sub>B[_]")
   and src\<^sub>B :: "'a \<Rightarrow> 'a"
   and trg\<^sub>B :: "'a \<Rightarrow> 'a"
   begin
 
     abbreviation H  (infixr "\<star>" 53)
     where "H f g \<equiv> H\<^sub>B g f"
 
     abbreviation \<i>   ("\<i>[_]")
     where "\<i> \<equiv> \<i>\<^sub>B"
 
     abbreviation src
     where "src \<equiv> trg\<^sub>B"
 
     abbreviation trg
     where "trg \<equiv> src\<^sub>B"
 
     interpretation horizontal_homs V src trg
       by (unfold_locales, auto)
 
     interpretation H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
       using VV.arr_char VV.dom_simp VV.cod_simp
       apply unfold_locales
           apply (metis (no_types, lifting) B.hseqE B.hseq_char')
          apply auto[3]
       using VV.comp_char VV.seq_char VV.arr_char B.VxV.comp_char B.interchange
       by (metis (no_types, lifting) B.VxV.seqE fst_conv snd_conv)
 
     interpretation horizontal_composition V H src trg
       by (unfold_locales, auto)
 
     abbreviation UP
     where "UP \<mu>\<nu>\<tau> \<equiv> if B.VVV.arr \<mu>\<nu>\<tau> then
                        (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)
                     else VVV.null"
 
     abbreviation DN
     where "DN \<mu>\<nu>\<tau> \<equiv> if VVV.arr \<mu>\<nu>\<tau> then
                          (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)
                       else B.VVV.null"
 
     lemma VVV_arr_char:
     shows "VVV.arr \<mu>\<nu>\<tau> \<longleftrightarrow> B.VVV.arr (DN \<mu>\<nu>\<tau>)"
       using VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char B.VVV.not_arr_null
       by auto
 
     lemma VVV_ide_char:
     shows "VVV.ide \<mu>\<nu>\<tau> \<longleftrightarrow> B.VVV.ide (DN \<mu>\<nu>\<tau>)"
     proof -
       have "VVV.ide \<mu>\<nu>\<tau> \<longleftrightarrow> VVV.arr \<mu>\<nu>\<tau> \<and> B.VxVxV.ide \<mu>\<nu>\<tau>"
         using VVV.ide_char by simp
       also have "... \<longleftrightarrow> B.VVV.arr (DN \<mu>\<nu>\<tau>) \<and> B.VxVxV.ide (DN \<mu>\<nu>\<tau>)"
         using VVV_arr_char B.VxVxV.ide_char by auto
       also have "... \<longleftrightarrow> B.VVV.ide (DN \<mu>\<nu>\<tau>)"
         using B.VVV.ide_char [of "DN \<mu>\<nu>\<tau>"] by blast
       finally show ?thesis by fast
     qed
 
     lemma VVV_dom_char:
     shows "VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
     proof (cases "VVV.arr \<mu>\<nu>\<tau>")
       show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
         using VVV.dom_def VVV.has_domain_iff_arr VVV_arr_char B.VVV.dom_null
         by auto
       show "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
       proof -
         assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
         have "VVV.dom \<mu>\<nu>\<tau> =
               (B.dom (fst \<mu>\<nu>\<tau>), B.dom (fst (snd \<mu>\<nu>\<tau>)), B.dom (snd (snd \<mu>\<nu>\<tau>)))"
           using \<mu>\<nu>\<tau> VVV.dom_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
           by simp
         also have "... = UP (B.dom (snd (snd \<mu>\<nu>\<tau>)), B.dom (fst (snd \<mu>\<nu>\<tau>)), B.dom (fst \<mu>\<nu>\<tau>))"
           by (metis (no_types, lifting) B.VV.arrI B.VVV.arr_char B.arr_dom VV.arrE VVV.arrE
               \<mu>\<nu>\<tau> fst_conv snd_conv src_dom trg_dom)
         also have "... = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
           using \<mu>\<nu>\<tau> B.VVV.dom_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
           by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma VVV_cod_char:
     shows "VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
     proof (cases "VVV.arr \<mu>\<nu>\<tau>")
       show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
         using VVV.cod_def VVV.has_codomain_iff_arr VVV_arr_char B.VVV.cod_null
         by auto
       show "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
       proof -
         assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
         have "VVV.cod \<mu>\<nu>\<tau> = (B.cod (fst \<mu>\<nu>\<tau>), B.cod (fst (snd \<mu>\<nu>\<tau>)), B.cod (snd (snd \<mu>\<nu>\<tau>)))"
           using \<mu>\<nu>\<tau> VVV.cod_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
           by simp
         also have "... = UP (B.cod (snd (snd \<mu>\<nu>\<tau>)), B.cod (fst (snd \<mu>\<nu>\<tau>)), B.cod (fst \<mu>\<nu>\<tau>))"
           by (metis (no_types, lifting) B.VV.arrI B.VVV.arr_char B.arr_cod VV.arrE VVV.arrE
               \<mu>\<nu>\<tau> fst_conv snd_conv src_cod trg_cod)
         also have "... = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
           using \<mu>\<nu>\<tau> B.VVV.cod_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
           by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma HoHV_char:
     shows "HoHV \<mu>\<nu>\<tau> = B.HoVH (DN \<mu>\<nu>\<tau>)"
      using HoHV_def B.HoVH_def VVV_arr_char by simp
 
     lemma HoVH_char:
     shows "HoVH \<mu>\<nu>\<tau> = B.HoHV (DN \<mu>\<nu>\<tau>)"
       using HoVH_def B.HoHV_def VVV_arr_char by simp
 
     definition \<a>   ("\<a>[_, _, _]")
     where "\<a>[\<mu>, \<nu>, \<tau>] \<equiv> B.\<alpha>' (DN (\<mu>, \<nu>, \<tau>))"
 
     interpretation natural_isomorphism VVV.comp \<open>(\<cdot>)\<close> HoHV HoVH
                      \<open>\<lambda>\<mu>\<nu>\<tau>. \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]\<close>
     proof
       fix \<mu>\<nu>\<tau>
       show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = B.null"
         using VVV.arr_char B.VVV.arr_char \<a>_def B.\<alpha>'.is_extensional by auto
       assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
       show "B.dom \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
         using \<mu>\<nu>\<tau> \<a>_def HoHV_def B.\<alpha>'.preserves_dom VVV.arr_char VVV.dom_char VV.arr_char
               B.HoVH_def B.VVV.arr_char B.VV.arr_char B.VVV.dom_char
         by auto
       show "B.cod \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
         using \<mu>\<nu>\<tau> \<a>_def HoVH_def B.\<alpha>'.preserves_cod VVV.arr_char VVV.cod_char VV.arr_char
               B.HoHV_def B.VVV.arr_char B.VV.arr_char B.VVV.cod_char
         by auto
       show "HoVH \<mu>\<nu>\<tau> \<cdot>
               \<a>[fst (VVV.dom \<mu>\<nu>\<tau>), fst (snd (VVV.dom \<mu>\<nu>\<tau>)), snd (snd (VVV.dom \<mu>\<nu>\<tau>))] =
             \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
       proof -
         have "HoVH \<mu>\<nu>\<tau> \<cdot>
                 \<a>[fst (VVV.dom \<mu>\<nu>\<tau>), fst (snd (VVV.dom \<mu>\<nu>\<tau>)), snd (snd (VVV.dom \<mu>\<nu>\<tau>))] =
               HoVH \<mu>\<nu>\<tau> \<cdot> B.\<alpha>' (B.VVV.dom (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
           unfolding \<a>_def
           using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char VVV.dom_char B.VVV.arr_char B.VVV.dom_char
           by auto
         also have "... = B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)"
           using B.\<alpha>'.is_natural_1 VVV_arr_char \<mu>\<nu>\<tau> HoVH_char by presburger
         also have "... = \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
           using \<mu>\<nu>\<tau> \<a>_def by simp
         finally show ?thesis by blast
       qed
       show "\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
               HoHV \<mu>\<nu>\<tau> =
             \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
       proof -
         have "\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
                 HoHV \<mu>\<nu>\<tau> =
               B.\<alpha>' (B.VVV.cod (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)) \<cdot> HoHV \<mu>\<nu>\<tau>"
           unfolding \<a>_def
           using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char VVV.cod_char B.VVV.arr_char B.VVV.cod_char
           by auto
         also have "... = B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)"
           using B.\<alpha>'.is_natural_2 VVV_arr_char \<mu>\<nu>\<tau> HoHV_char by presburger
         also have "... = \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
           using \<mu>\<nu>\<tau> \<a>_def by simp
         finally show ?thesis by blast
       qed
       next
       fix \<mu>\<nu>\<tau>
       assume \<mu>\<nu>\<tau>: "VVV.ide \<mu>\<nu>\<tau>"
       show "B.iso \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
       proof -
         have "B.VVV.ide (DN \<mu>\<nu>\<tau>)"
           using \<mu>\<nu>\<tau> VVV_ide_char by blast
         thus ?thesis
           using \<mu>\<nu>\<tau> \<a>_def B.\<alpha>'.components_are_iso by force
       qed
     qed
 
     sublocale bicategory V H \<a> \<i> src trg
     proof
       show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i> a : H a a \<rightarrow>\<^sub>B a\<guillemotright>"
         using obj_def objE B.obj_def B.objE B.unit_in_hom by meson
       show "\<And>a. obj a \<Longrightarrow> B.iso (\<i> a)"
         using obj_def objE B.obj_def B.objE B.iso_unit by meson
       show "\<And>f g h k. \<lbrakk> B.ide f; B.ide g; B.ide h; B.ide k;
                         src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
               (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) = \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
         unfolding \<a>_def
         using B.\<a>'_def B.comp_assoc B.pentagon' VVV.arr_char VV.arr_char by simp
     qed
 
     proposition is_bicategory:
     shows "bicategory V H \<a> \<i> src trg"
       ..
 
     lemma assoc_ide_simp:
     assumes "B.ide f" and "B.ide g" and "B.ide h"
     and "src f = trg g" and "src g = trg h"
     shows "\<a>[f, g, h] = B.\<a>' h g f"
       using assms \<a>_def B.\<a>'_def by fastforce
 
     lemma lunit_ide_simp:
     assumes "B.ide f"
     shows "lunit f = B.runit f"
     proof (intro B.runit_eqI)
       show "B.ide f" by fact
       show "\<guillemotleft>lunit f : H (trg f) f \<rightarrow>\<^sub>B f\<guillemotright>"
         using assms by simp
       show "trg f \<star> lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sub>B[f, trg f, trg f]"
       proof -
         have "trg f \<star> lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>' (trg f) (trg f) f"
           using assms lunit_char(1-2) [of f] by simp
         moreover have "\<a>' (trg f) (trg f) f = \<a>\<^sub>B[f, trg f, trg f]"
         proof (unfold \<a>'_def)
           have 1: "VVV.ide (trg f, trg f, f)"
             using assms VVV.ide_char VVV.arr_char VV.arr_char by simp
           have "\<alpha>' (trg f, trg f, f) = B.inv \<a>[trg f, trg f, f]"
             using 1 B.\<alpha>'.inverts_components by simp
           also have "... = B.inv (B.\<alpha>' (f, trg f, trg f))"
             unfolding \<a>_def using 1 by simp
           also have "... = \<a>\<^sub>B[f, trg f, trg f]"
             using 1 B.VVV.ide_char B.VVV.arr_char B.VV.arr_char VVV.ide_char
                   VVV.arr_char VV.arr_char B.\<alpha>'.inverts_components B.\<alpha>_def
             by force
           finally show "\<alpha>' (trg f, trg f, f) = \<a>\<^sub>B[f, trg f, trg f]"
             by blast
         qed
         ultimately show ?thesis by simp
       qed
     qed
 
     lemma runit_ide_simp:
     assumes "B.ide f"
     shows "runit f = B.lunit f"
       using assms runit_char(1-2) [of f] B.\<a>'_def assoc_ide_simp
       by (intro B.lunit_eqI) auto
 
   end
 
   context pseudofunctor
   begin
 
     interpretation C': op_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C ..
     interpretation D': op_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
 
     notation C'.H  (infixr "\<star>\<^sub>C\<^sup>o\<^sup>p" 53)
     notation D'.H  (infixr "\<star>\<^sub>D\<^sup>o\<^sup>p" 53)
 
     interpretation F': weak_arrow_of_homs V\<^sub>C C'.src C'.trg V\<^sub>D D'.src D'.trg F
       apply unfold_locales
       using weakly_preserves_src weakly_preserves_trg by simp_all
     interpretation H\<^sub>D'oFF: composite_functor C'.VV.comp D'.VV.comp V\<^sub>D F'.FF
                              \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>D\<^sup>o\<^sup>p snd \<mu>\<nu>\<close> ..
     interpretation FoH\<^sub>C': composite_functor C'.VV.comp V\<^sub>C V\<^sub>D
                              \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>C\<^sup>o\<^sup>p snd \<mu>\<nu>\<close> F
       ..
     interpretation \<Phi>': natural_isomorphism C'.VV.comp V\<^sub>D H\<^sub>D'oFF.map FoH\<^sub>C'.map
                                            \<open>\<lambda>f. \<Phi> (snd f, fst f)\<close>
       using C.VV.arr_char C'.VV.arr_char C'.VV.ide_char C.VV.ide_char FF_def F'.FF_def
             \<Phi>.is_extensional \<Phi>.is_natural_1 \<Phi>.is_natural_2
             C.VV.dom_simp C.VV.cod_simp C'.VV.dom_simp C'.VV.cod_simp
       by unfold_locales auto
     interpretation F': pseudofunctor V\<^sub>C C'.H C'.\<a> \<i>\<^sub>C C'.src C'.trg
                                      V\<^sub>D D'.H D'.\<a> \<i>\<^sub>D D'.src D'.trg
                                      F \<open>\<lambda>f. \<Phi> (snd f, fst f)\<close>
     proof
       fix f g h
       assume f: "C.ide f" and g: "C.ide g" and h: "C.ide h"
       and fg: "C'.src f = C'.trg g" and gh: "C'.src g = C'.trg h"
       show "F (C'.\<a> f g h) \<cdot>\<^sub>D \<Phi> (snd (f \<star>\<^sub>C\<^sup>o\<^sup>p g, h), fst (f \<star>\<^sub>C\<^sup>o\<^sup>p g, h)) \<cdot>\<^sub>D
               (\<Phi> (snd (f, g), fst (f, g)) \<star>\<^sub>D\<^sup>o\<^sup>p F h) =
             \<Phi> (snd (f, g \<star>\<^sub>C\<^sup>o\<^sup>p h), fst (f, g \<star>\<^sub>C\<^sup>o\<^sup>p h)) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (snd (g, h), fst (g, h))) \<cdot>\<^sub>D
               D'.\<a> (F f) (F g) (F h)"
         using f g h fg gh C.VV.in_hom_char FF_def C.VV.arr_char C.VV.dom_simp C.VV.cod_simp
               C'.assoc_ide_simp D'.assoc_ide_simp preserves_inv assoc_coherence
               D.invert_opposite_sides_of_square
                 [of "F (\<a>\<^sub>C h g f)" "\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g))"
                     "\<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h)" "\<a>\<^sub>D (F h) (F g) (F f)"]
               D.comp_assoc
         by auto
     qed
 
     lemma induces_pseudofunctor_between_opposites:
     shows "pseudofunctor (\<cdot>\<^sub>C) (\<star>\<^sub>C\<^sup>o\<^sup>p) C'.\<a> \<i>\<^sub>C C'.src C'.trg
                          (\<cdot>\<^sub>D) (\<star>\<^sub>D\<^sup>o\<^sup>p) D'.\<a> \<i>\<^sub>D D'.src D'.trg
                          F (\<lambda>f. \<Phi> (snd f, fst f))"
       ..
 
     text \<open>
       It is now easy to dualize the coherence condition for \<open>F\<close> with respect to
       left unitors to obtain the corresponding condition for right unitors.
     \<close>
 
     lemma runit_coherence:
     assumes "C.ide f"
     shows "\<r>\<^sub>D[F f] = F \<r>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f))"
     proof -
       have "C'.lunit f = \<r>\<^sub>C[f]"
         using assms C'.lunit_ide_simp by simp
       moreover have "D'.lunit (F f) = \<r>\<^sub>D[F f]"
         using assms D'.lunit_ide_simp by simp
       moreover have "F'.unit (src\<^sub>C f) = unit (src\<^sub>C f)"
         using assms F'.unit_char F'.preserves_trg
         by (intro unit_eqI) auto
       moreover have "D'.lunit (F f) =
                      F (C'.lunit f) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D F'.unit (src\<^sub>C f))"
         using assms F'.lunit_coherence by simp
       ultimately show ?thesis by simp
     qed
 
   end
 
   subsection "Preservation Properties"
 
   text \<open>
     The objective of this section is to establish explicit formulas for the result
     of applying a pseudofunctor to expressions of various forms.
   \<close>
 
   context pseudofunctor
   begin
 
     lemma preserves_lunit:
     assumes "C.ide f"
     shows "F \<l>\<^sub>C[f] = \<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
     and "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]"
     proof -
       show 1: "F \<l>\<^sub>C[f] = \<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
       proof -
         have "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f)) = F \<l>\<^sub>C[f]"
         proof -
           have "D.arr \<l>\<^sub>D[F f]"
             using assms by simp
           moreover have "\<l>\<^sub>D[F f] = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f)"
             using assms lunit_coherence by simp
           moreover have "D.iso (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f))"
             using assms unit_char cmp_components_are_iso
             by (intro D.isos_compose D.seqI) auto
           ultimately show ?thesis
             using assms D.invert_side_of_triangle(2) by metis
         qed
         moreover have "D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f)) =
                         (D.inv (unit (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
           using assms C.VV.arr_char unit_char FF_def D.inv_comp C.VV.dom_simp by simp
         ultimately show ?thesis by simp
       qed
       show "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]"
       proof -
         have "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] =
               D.inv (\<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f)))"
           using assms 1 preserves_inv by simp
         also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]"
           using assms unit_char D.comp_assoc D.isos_compose
           by (auto simp add: D.inv_comp)
         finally show ?thesis by simp
       qed
     qed
 
     lemma preserves_runit:
     assumes "C.ide f"
     shows "F \<r>\<^sub>C[f] = \<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (unit (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
     and "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
     proof -
       show 1: "F \<r>\<^sub>C[f] = \<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (unit (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
       proof -
         have "F \<r>\<^sub>C[f] = \<r>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f)))"
         proof -
           have "\<r>\<^sub>D[F f] = F \<r>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f))"
             using assms runit_coherence by simp
           moreover have "D.iso (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f)))"
             using assms unit_char D.iso_hcomp FF_def
             apply (intro D.isos_compose D.seqI) by auto
           moreover have "D.arr \<r>\<^sub>D[F f]"
             using assms by simp
           ultimately show ?thesis
             using assms D.invert_side_of_triangle(2) by metis
         qed
         moreover have "D.inv (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f))) =
                        (F f \<star>\<^sub>D D.inv (unit (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
           using assms C.VV.arr_char unit_char D.iso_hcomp FF_def D.inv_comp C.VV.dom_simp
           by simp
         ultimately show ?thesis by simp
       qed
       show "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
       proof -
         have "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] =
                D.inv (\<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (unit (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f)))"
           using assms 1 preserves_inv C.iso_runit by simp
         also have "... = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D unit (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
           using assms unit_char D.comp_assoc D.isos_compose
           by (auto simp add: D.inv_comp)
         finally show ?thesis by simp
       qed
     qed
 
     lemma preserves_assoc:
     assumes "C.ide f" and "C.ide g" and "C.ide h"
     and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C h"
     shows "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
                             (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
     and "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
                             (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
     proof -
       show 1: "F \<a>\<^sub>C[f, g, h] =
                \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
                  (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
       proof -
         have "F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
               \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
           using assms assoc_coherence [of f g h] by simp
         moreover have "D.seq (\<Phi> (f, g \<star>\<^sub>C h)) ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
           using assms C.VV.arr_char FF_def C.VV.dom_simp C.VV.cod_simp by auto
         moreover have 2: "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
           using assms C.VV.arr_char FF_def C.VV.dom_simp C.VV.cod_simp by auto
         moreover have "D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)) =
                       (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
           using assms 2 C.VV.arr_char FF_def D.inv_comp C.VV.dom_simp C.VV.cod_simp
           by simp
         ultimately show ?thesis
           using D.invert_side_of_triangle(2)
                   [of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
                       "F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
                 D.comp_assoc
           by simp
       qed
       show "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
             \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
               (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
       proof -
         have "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
                D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
                  (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
           using assms 1 preserves_inv by simp
         also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
                            (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
         proof -
           have "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>C h) : F f \<star>\<^sub>D F (g \<star>\<^sub>C h) \<Rightarrow>\<^sub>D F (f \<star>\<^sub>C g \<star>\<^sub>C h)\<guillemotright> \<and> D.iso (\<Phi> (f, g \<star>\<^sub>C h))"
             using assms by auto
           moreover have "\<guillemotleft>F f \<star>\<^sub>D \<Phi> (g, h) : F f \<star>\<^sub>D F g \<star>\<^sub>D F h \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F (g \<star>\<^sub>C h)\<guillemotright> \<and>
                          D.iso (F f \<star>\<^sub>D \<Phi> (g, h))"
             using assms
             by (intro conjI D.hcomp_in_vhom, auto)
           ultimately show ?thesis
-            using assms D.isos_compose D.comp_assoc
-          by (elim conjE D.in_homE) (auto simp add: D.inv_comp)
+            using assms D.isos_compose D.comp_assoc D.inv_comp
+            by (elim conjE D.in_homE) auto
         qed
         finally show ?thesis by simp
       qed
     qed
 
     lemma preserves_hcomp:
     assumes "C.hseq \<mu> \<nu>"
     shows "F (\<mu> \<star>\<^sub>C \<nu>) =
            \<Phi> (C.cod \<mu>, C.cod \<nu>) \<cdot>\<^sub>D (F \<mu> \<star>\<^sub>D F \<nu>) \<cdot>\<^sub>D D.inv (\<Phi> (C.dom \<mu>, C.dom \<nu>))"
     proof -
       have "F (\<mu> \<star>\<^sub>C \<nu>) \<cdot>\<^sub>D \<Phi> (C.dom \<mu>, C.dom \<nu>) = \<Phi> (C.cod \<mu>, C.cod \<nu>) \<cdot>\<^sub>D (F \<mu> \<star>\<^sub>D F \<nu>)"
         using assms \<Phi>.naturality C.VV.arr_char C.VV.cod_char FF_def C.VV.dom_simp
         by auto
       thus ?thesis
         by (metis (no_types) assms C.hcomp_simps(3) C.hseqE C.ide_dom C.src_dom C.trg_dom
             D.comp_arr_inv' D.comp_assoc cmp_components_are_iso cmp_simps(5)
             as_nat_trans.is_natural_1)
     qed
 
     lemma preserves_adjunction_data:
     assumes "adjunction_data_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
     shows "adjunction_data_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
              (F f) (F g) (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f))
              (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
     proof
       interpret adjunction_data_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
         using assms by auto
       show "D.ide (F f)"
         using preserves_ide by simp
       show "D.ide (F g)"
         using preserves_ide by simp
       show "\<guillemotleft>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f) : src\<^sub>D (F f) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
         using antipar C.VV.ide_char C.VV.arr_char cmp_in_hom(2) unit_in_hom FF_def by auto
       show "\<guillemotleft>D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D src\<^sub>D (F g)\<guillemotright>"
         using antipar C.VV.ide_char C.VV.arr_char FF_def cmp_in_hom(2) unit_in_hom(2)
               unit_char(2)
         by auto
     qed
 
     lemma preserves_equivalence:
     assumes "equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
     shows "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
              (F f) (F g) (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f))
              (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
     proof -
       interpret equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
         using assms by auto
       show "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
              (F f) (F g) (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f))
              (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
         using antipar unit_is_iso preserves_iso unit_char(2) C.VV.ide_char C.VV.arr_char
               FF_def D.isos_compose
         by (unfold_locales) auto
     qed
 
     lemma preserves_equivalence_maps:
     assumes "C.equivalence_map f"
     shows "D.equivalence_map (F f)"
     proof -
       obtain g \<eta> \<epsilon> where E: "equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
         using assms C.equivalence_map_def by auto
       interpret E: equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
         using E by auto
       show ?thesis
         using E preserves_equivalence C.equivalence_map_def D.equivalence_map_def map\<^sub>0_simps
         by blast
     qed
 
     lemma preserves_equivalent_objects:
     assumes "C.equivalent_objects a b"
     shows "D.equivalent_objects (map\<^sub>0 a) (map\<^sub>0 b)"
       using assms D.equivalent_objects_def preserves_equivalence_maps
       unfolding C.equivalent_objects_def by fast
 
     lemma preserves_isomorphic:
     assumes "C.isomorphic f g"
     shows "D.isomorphic (F f) (F g)"
       using assms C.isomorphic_def D.isomorphic_def preserves_iso by auto
 
     lemma preserves_quasi_inverses:
     assumes "C.quasi_inverses f g"
     shows "D.quasi_inverses (F f) (F g)"
       using assms C.quasi_inverses_def D.quasi_inverses_def preserves_equivalence by blast
 
     lemma preserves_quasi_inverse:
     assumes "C.equivalence_map f"
     shows "D.isomorphic (F (C.some_quasi_inverse f)) (D.some_quasi_inverse (F f))"
       using assms preserves_quasi_inverses C.quasi_inverses_some_quasi_inverse
             D.quasi_inverse_unique D.quasi_inverses_some_quasi_inverse
             preserves_equivalence_maps
       by blast
 
   end
 
   subsection "Identity Pseudofunctors"
 
   locale identity_pseudofunctor =
     B: bicategory V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
   for V\<^sub>B :: "'b comp"                    (infixr "\<cdot>\<^sub>B" 55)
   and H\<^sub>B :: "'b comp"                   (infixr "\<star>\<^sub>B" 53)
   and \<a>\<^sub>B :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b"       ("\<a>\<^sub>B[_, _, _]")
   and \<i>\<^sub>B :: "'b \<Rightarrow> 'b"                   ("\<i>\<^sub>B[_]")
   and src\<^sub>B :: "'b \<Rightarrow> 'b"
   and trg\<^sub>B :: "'b \<Rightarrow> 'b"
   begin
 
     text\<open>
       The underlying vertical functor is just the identity functor on the vertical category,
       which is already available as \<open>B.map\<close>.
     \<close>
 
     abbreviation map
     where "map \<equiv> B.map"
 
     interpretation I: weak_arrow_of_homs V\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B src\<^sub>B trg\<^sub>B map
       using B.isomorphic_reflexive by unfold_locales auto
 
     interpretation II: "functor" B.VV.comp B.VV.comp I.FF
       using I.functor_FF by simp
 
     interpretation H\<^sub>BoII: composite_functor B.VV.comp B.VV.comp V\<^sub>B I.FF
                             \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close>
       ..
     interpretation IoH\<^sub>B: composite_functor B.VV.comp V\<^sub>B V\<^sub>B \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close> map
       ..
 
     text\<open>
       The horizontal composition provides the compositor.
     \<close>
 
     abbreviation cmp
     where "cmp \<equiv> \<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>"
 
     interpretation cmp: natural_transformation B.VV.comp V\<^sub>B H\<^sub>BoII.map IoH\<^sub>B.map cmp
       using B.VV.arr_char B.VV.dom_simp B.VV.cod_simp B.H.as_nat_trans.is_natural_1
             B.H.as_nat_trans.is_natural_2 I.FF_def
       apply unfold_locales
           apply auto
       by (meson B.hseqE B.hseq_char')+
 
     interpretation cmp: natural_isomorphism B.VV.comp V\<^sub>B H\<^sub>BoII.map IoH\<^sub>B.map cmp
       by unfold_locales simp
 
     sublocale pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B map cmp
       apply unfold_locales
       by (metis B.assoc_is_natural_2 B.assoc_naturality B.assoc_simps(1) B.comp_ide_self
           B.hcomp_simps(1) B.ide_char B.ide_hcomp B.map_simp fst_conv snd_conv)
 
     lemma is_pseudofunctor:
     shows "pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B map cmp"
       ..
 
     lemma unit_char':
     assumes "B.obj a"
     shows "unit a = a"
     proof -
       have "src\<^sub>B a = a \<and> B.ide a"
         using assms by auto
       hence "a = unit a"
         using assms B.comp_arr_dom B.comp_cod_arr I.map\<^sub>0_def map_def
               B.ide_in_hom(2) B.objE [of a] B.ide_is_iso [of a]
         by (intro unit_eqI) auto
       thus ?thesis by simp
     qed
 
   end
 
   lemma (in identity_pseudofunctor) map\<^sub>0_simp [simp]:
   assumes "B.obj a"
   shows "map\<^sub>0 a = a"
     using assms map\<^sub>0_def by auto
     (* TODO: Does not recognize map\<^sub>0_def unless the context is closed, then re-opened. *)
 
   subsection "Embedding Pseudofunctors"
 
   text \<open>
     In this section, we construct the embedding pseudofunctor of a sub-bicategory
     into the ambient bicategory.
   \<close>
 
   locale embedding_pseudofunctor =
     B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
     S: subbicategory
   begin
 
     no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
     notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     definition map
     where "map \<mu> = (if S.arr \<mu> then \<mu> else B.null)"
 
     lemma map_in_hom [intro]:
     assumes "S.arr \<mu>"
     shows "\<guillemotleft>map \<mu> : src\<^sub>B (map (S.src \<mu>)) \<rightarrow>\<^sub>B src\<^sub>B (map (S.trg \<mu>))\<guillemotright>"
     and "\<guillemotleft>map \<mu> : map (S.dom \<mu>) \<Rightarrow>\<^sub>B map (S.cod \<mu>)\<guillemotright>"
     proof -
       show 1: "\<guillemotleft>map \<mu> : map (S.dom \<mu>) \<Rightarrow>\<^sub>B map (S.cod \<mu>)\<guillemotright>"
         using assms map_def S.in_hom_char by fastforce
       show "\<guillemotleft>map \<mu> : src\<^sub>B (map (S.src \<mu>)) \<rightarrow>\<^sub>B src\<^sub>B (map (S.trg \<mu>))\<guillemotright>"
         using assms 1 map_def S.arr_char S.src_def S.trg_def S.obj_char S.obj_src S.obj_trg
         by auto
     qed
 
     lemma map_simps [simp]:
     assumes "S.arr \<mu>"
     shows "B.arr (map \<mu>)"
     and "src\<^sub>B (map \<mu>) = src\<^sub>B (map (S.src \<mu>))" and "trg\<^sub>B (map \<mu>) = src\<^sub>B (map (S.trg \<mu>))"
     and "B.dom (map \<mu>) = map (S.dom \<mu>)" and "B.cod (map \<mu>) = map (S.cod \<mu>)"
       using assms map_in_hom by blast+
 
     interpretation "functor" S.comp V map
       apply unfold_locales
           apply auto
       using map_def S.comp_char S.seq_char S.arr_char
        apply auto[1]
       using map_def S.comp_simp by auto
 
     interpretation weak_arrow_of_homs S.comp S.src S.trg V src\<^sub>B trg\<^sub>B map
       using S.arr_char map_def S.src_def S.trg_def S.src_closed S.trg_closed B.isomorphic_reflexive
             preserves_ide S.ide_src S.ide_trg
       apply unfold_locales
       by presburger+
 
     interpretation HoFF: composite_functor S.VV.comp B.VV.comp V FF
                            \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close>
       ..
     interpretation FoH: composite_functor S.VV.comp S.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> map
       ..
 
     no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     definition cmp
     where "cmp \<mu>\<nu> = (if S.VV.arr \<mu>\<nu> then fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu> else B.null)"
 
     lemma cmp_in_hom [intro]:
     assumes "S.VV.arr \<mu>\<nu>"
     shows "\<guillemotleft>cmp \<mu>\<nu> : src\<^sub>B (snd \<mu>\<nu>) \<rightarrow>\<^sub>B trg\<^sub>B (fst \<mu>\<nu>)\<guillemotright>"
     and "\<guillemotleft>cmp \<mu>\<nu> : map (S.dom (fst \<mu>\<nu>)) \<star>\<^sub>B map (S.dom (snd \<mu>\<nu>))
                      \<Rightarrow>\<^sub>B map (S.cod (fst \<mu>\<nu>) \<star> S.cod (snd \<mu>\<nu>))\<guillemotright>"
     proof -
       show "\<guillemotleft>cmp \<mu>\<nu> : map (S.dom (fst \<mu>\<nu>)) \<star>\<^sub>B map (S.dom (snd \<mu>\<nu>))
                         \<Rightarrow>\<^sub>B map (S.cod (fst \<mu>\<nu>) \<star> S.cod (snd \<mu>\<nu>))\<guillemotright>"
       proof
         show 1: "B.arr (cmp \<mu>\<nu>)"
           unfolding cmp_def
           using assms S.arr_char S.VV.arr_char S.inclusion S.src_def S.trg_def by auto
         show "B.dom (cmp \<mu>\<nu>) = map (S.dom (fst \<mu>\<nu>)) \<star>\<^sub>B map (S.dom (snd \<mu>\<nu>))"
           unfolding cmp_def map_def
           using assms 1 cmp_def S.dom_simp S.cod_simp S.VV.arr_char S.arr_char S.hcomp_def
                 S.inclusion S.dom_closed
           by auto
         show "B.cod (cmp \<mu>\<nu>) = map (S.cod (fst \<mu>\<nu>) \<star> S.cod (snd \<mu>\<nu>))"
           unfolding cmp_def map_def
           using assms 1 S.H.preserves_arr S.cod_simp S.hcomp_eqI S.hcomp_simps(4) S.hseq_char'
           by auto
       qed
       thus "\<guillemotleft>cmp \<mu>\<nu> : src\<^sub>B (snd \<mu>\<nu>) \<rightarrow>\<^sub>B trg\<^sub>B (fst \<mu>\<nu>)\<guillemotright>"
         using cmp_def by auto
     qed
 
     lemma cmp_simps [simp]:
     assumes "S.VV.arr \<mu>\<nu>"
     shows "B.arr (cmp \<mu>\<nu>)"
     and "src\<^sub>B (cmp \<mu>\<nu>) = S.src (snd \<mu>\<nu>)" and "trg\<^sub>B (cmp \<mu>\<nu>) = S.trg (fst \<mu>\<nu>)"
     and "B.dom (cmp \<mu>\<nu>) = map (S.dom (fst \<mu>\<nu>)) \<star>\<^sub>B map (S.dom (snd \<mu>\<nu>))"
     and "B.cod (cmp \<mu>\<nu>) = map (S.cod (fst \<mu>\<nu>) \<star> S.cod (snd \<mu>\<nu>))"
       using assms cmp_in_hom S.src_def S.trg_def S.VV.arr_char
       by simp_all blast+
 
     lemma iso_cmp:
     assumes "S.VV.ide \<mu>\<nu>"
     shows "B.iso (cmp \<mu>\<nu>)"
       using assms S.VV.ide_char S.VV.arr_char S.arr_char cmp_def S.ide_char S.src_def S.trg_def
       by auto
 
     interpretation \<Phi>\<^sub>E: natural_isomorphism S.VV.comp V HoFF.map FoH.map cmp
     proof
       show "\<And>\<mu>\<nu>. \<not> S.VV.arr \<mu>\<nu> \<Longrightarrow> cmp \<mu>\<nu> = B.null"
         using cmp_def by simp
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "S.VV.arr \<mu>\<nu>"
       have 1: "S.arr (fst \<mu>\<nu>) \<and> S.arr (snd \<mu>\<nu>) \<and> S.src (fst \<mu>\<nu>) = S.trg (snd \<mu>\<nu>)"
         using \<mu>\<nu> S.VV.arr_char by simp
       show "B.dom (cmp \<mu>\<nu>) = HoFF.map (S.VV.dom \<mu>\<nu>)"
         using \<mu>\<nu> FF_def S.VV.arr_char S.VV.dom_char S.arr_dom S.src_def S.trg_def
               S.dom_char S.src.preserves_dom S.trg.preserves_dom
         apply simp
         by (metis (no_types, lifting))
       show "B.cod (cmp \<mu>\<nu>) = FoH.map (S.VV.cod \<mu>\<nu>)"
         using \<mu>\<nu> 1 map_def S.hseq_char S.hcomp_def S.cod_char S.arr_cod S.VV.cod_simp
         by simp
       show "cmp (S.VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoFF.map \<mu>\<nu> = cmp \<mu>\<nu>"
         using \<mu>\<nu> 1 cmp_def S.VV.arr_char S.VV.cod_char FF_def S.arr_cod S.cod_simp
               S.src_def S.trg_def map_def
         apply simp
         by (metis (no_types, lifting) B.comp_cod_arr B.hcomp_simps(4) cmp_simps(1) \<mu>\<nu>)
       show "FoH.map \<mu>\<nu> \<cdot>\<^sub>B cmp (S.VV.dom \<mu>\<nu>) = cmp \<mu>\<nu>"
         unfolding cmp_def map_def
         using \<mu>\<nu> S.VV.arr_char B.VV.arr_char S.VV.dom_char S.VV.cod_char B.comp_arr_dom
               S.hcomp_def
         apply simp
         by (metis (no_types, lifting) B.hcomp_simps(3) cmp_def cmp_simps(1) S.arr_char
             S.dom_char S.hcomp_closed S.src_def S.trg_def)
       next
       show "\<And>fg. S.VV.ide fg \<Longrightarrow> B.iso (cmp fg)"
         using iso_cmp by simp
     qed
 
     sublocale pseudofunctor S.comp S.hcomp S.\<a> \<i> S.src S.trg V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B map cmp
     proof
       fix f g h
       assume f: "S.ide f" and g: "S.ide g" and h: "S.ide h"
       and fg: "S.src f = S.trg g" and gh: "S.src g = S.trg h"
       have 1: "B.ide f \<and> B.ide g \<and> B.ide h \<and> src\<^sub>B f = trg\<^sub>B g \<and> src\<^sub>B g = trg\<^sub>B h"
         using f g h fg gh S.ide_char S.arr_char S.src_def S.trg_def by simp
       show "map (S.\<a> f g h) \<cdot>\<^sub>B cmp (f \<star> g, h) \<cdot>\<^sub>B cmp (f, g) \<star>\<^sub>B map h =
             cmp (f, g \<star> h) \<cdot>\<^sub>B (map f \<star>\<^sub>B cmp (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[map f, map g, map h]"
       proof -
         have "map (S.\<a> f g h) \<cdot>\<^sub>B cmp (f \<star> g, h) \<cdot>\<^sub>B cmp (f, g) \<star>\<^sub>B map h =
               \<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)"
           unfolding map_def cmp_def
           using 1 f g h fg gh S.VVV.arr_char S.VV.arr_char B.VVV.arr_char B.VV.arr_char
                 B.comp_arr_dom S.arr_char S.comp_char S.hcomp_closed S.hcomp_def
                 S.ideD(1) S.src_def
           by (simp add: S.assoc_closed)
         also have "... = cmp (f, g \<star> h) \<cdot>\<^sub>B (map f \<star>\<^sub>B cmp (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[map f, map g, map h]"
           unfolding cmp_def map_def
           using 1 f g h fg gh S.VV.arr_char B.VVV.arr_char B.VV.arr_char
                 B.comp_arr_dom B.comp_cod_arr S.hcomp_def S.comp_char
                 S.arr_char S.assoc_closed S.hcomp_closed S.ideD(1) S.trg_def
           by auto
         finally show ?thesis by blast
       qed
     qed
 
     lemma is_pseudofunctor:
     shows "pseudofunctor S.comp S.hcomp S.\<a> \<i> S.src S.trg V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B map cmp"
       ..
 
     lemma map\<^sub>0_simp [simp]:
     assumes "S.obj a"
     shows "map\<^sub>0 a = a"
       using assms map\<^sub>0_def map_def S.obj_char by auto
 
     lemma unit_char':
     assumes "S.obj a"
     shows "unit a = a"
     proof -
       have a: "S.arr a"
         using assms by auto
       have 1: "B.ide a"
         using assms S.obj_char by auto
       have 2: "src\<^sub>B a = a"
         using assms S.obj_char by auto
       have "a = unit a"
       proof (intro unit_eqI)
         show "S.obj a" by fact
         show "\<guillemotleft>a : map\<^sub>0 a \<Rightarrow>\<^sub>B map a\<guillemotright>"
           using assms a 2 map\<^sub>0_def map_def S.src_def S.dom_char S.cod_char S.obj_char
           by auto
         show "B.iso a"
           using assms 1 by simp
         show "a \<cdot>\<^sub>B \<i>[map\<^sub>0 a] = (map \<i>[a] \<cdot>\<^sub>B cmp (a, a)) \<cdot>\<^sub>B (a \<star>\<^sub>B a)"
         proof -
           have "a \<cdot>\<^sub>B \<i>[a] = \<i>[a] \<cdot>\<^sub>B cmp (a, a) \<cdot>\<^sub>B (a \<star>\<^sub>B a)"
           proof -
             have "a \<cdot>\<^sub>B \<i>[a] = \<i>[a]"
               using assms 1 2 S.comp_cod_arr S.unitor_coincidence S.lunit_in_hom
                     S.obj_char S.comp_simp
               by auto
             moreover have "(a \<star>\<^sub>B a) \<cdot>\<^sub>B (a \<star>\<^sub>B a) = a \<star>\<^sub>B a"
               using assms S.obj_char S.comp_ide_self by auto
             moreover have "B.dom \<i>[a] = a \<star>\<^sub>B a"
               using assms S.obj_char by simp
             moreover have "\<i>[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a) = \<i>[a]"
               using assms S.obj_char B.comp_arr_dom by simp
             ultimately show ?thesis
               using assms cmp_def S.VV.arr_char by auto
           qed
           thus ?thesis
             using assms a 2 map\<^sub>0_def map_def S.src_def B.comp_assoc by simp
         qed
       qed
       thus ?thesis by simp
     qed
 
   end
 
   subsection "Composition of Pseudofunctors"
 
   text \<open>
     In this section, we show how pseudofunctors may be composed.  The main work is to
     establish the coherence condition for associativity.
   \<close>
 
   locale composite_pseudofunctor =
     B: bicategory V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B +
     C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
     D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
     F: pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C F \<Phi>\<^sub>F +
     G: 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 G \<Phi>\<^sub>G
   for V\<^sub>B :: "'b comp"                    (infixr "\<cdot>\<^sub>B" 55)
   and H\<^sub>B :: "'b comp"                   (infixr "\<star>\<^sub>B" 53)
   and \<a>\<^sub>B :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b"       ("\<a>\<^sub>B[_, _, _]")
   and \<i>\<^sub>B :: "'b \<Rightarrow> 'b"                   ("\<i>\<^sub>B[_]")
   and src\<^sub>B :: "'b \<Rightarrow> 'b"
   and trg\<^sub>B :: "'b \<Rightarrow> 'b"
   and V\<^sub>C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'b \<Rightarrow> 'c"
   and \<Phi>\<^sub>F :: "'b * 'b \<Rightarrow> 'c"
   and G :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>G :: "'c * 'c \<Rightarrow> 'd"
   begin
 
     sublocale composite_functor V\<^sub>B V\<^sub>C V\<^sub>D F G ..
 
     sublocale weak_arrow_of_homs V\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>D src\<^sub>D trg\<^sub>D \<open>G o F\<close>
     proof
       show "\<And>\<mu>. B.arr \<mu> \<Longrightarrow> D.isomorphic ((G o F) (src\<^sub>B \<mu>)) (src\<^sub>D ((G o F) \<mu>))"
       proof -
         fix \<mu>
         assume \<mu>: "B.arr \<mu>"
         show "D.isomorphic ((G o F) (src\<^sub>B \<mu>)) (src\<^sub>D ((G o F) \<mu>))"
         proof -
           have "(G o F) (src\<^sub>B \<mu>) = G (F (src\<^sub>B \<mu>))"
             using \<mu> by simp
           also have "D.isomorphic ... (G (src\<^sub>C (F \<mu>)))"
             using \<mu> F.weakly_preserves_src G.preserves_iso
             by (meson C.isomorphicE D.isomorphic_def G.preserves_hom)
           also have "D.isomorphic ... (src\<^sub>D (G (F \<mu>)))"
             using \<mu> G.weakly_preserves_src by blast
           also have "... = src\<^sub>D ((G o F) \<mu>)"
             by simp
           finally show ?thesis by blast
         qed
       qed
       show "\<And>\<mu>. B.arr \<mu> \<Longrightarrow> D.isomorphic ((G o F) (trg\<^sub>B \<mu>)) (trg\<^sub>D ((G o F) \<mu>))"
       proof -
         fix \<mu>
         assume \<mu>: "B.arr \<mu>"
         show "D.isomorphic ((G o F) (trg\<^sub>B \<mu>)) (trg\<^sub>D ((G o F) \<mu>))"
         proof -
           have "(G o F) (trg\<^sub>B \<mu>) = G (F (trg\<^sub>B \<mu>))"
             using \<mu> by simp
           also have "D.isomorphic ... (G (trg\<^sub>C (F \<mu>)))"
             using \<mu> F.weakly_preserves_trg G.preserves_iso
             by (meson C.isomorphicE D.isomorphic_def G.preserves_hom)
           also have "D.isomorphic ... (trg\<^sub>D (G (F \<mu>)))"
             using \<mu> G.weakly_preserves_trg by blast
           also have "... = trg\<^sub>D ((G o F) \<mu>)"
             by simp
           finally show ?thesis by blast
         qed
       qed
     qed
 
     interpretation H\<^sub>DoGF_GF: composite_functor B.VV.comp D.VV.comp V\<^sub>D FF
                                \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>D snd \<mu>\<nu>\<close>
       ..
     interpretation GFoH\<^sub>B: composite_functor B.VV.comp V\<^sub>B V\<^sub>D \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close>
                                \<open>G o F\<close>
       ..
 
     definition cmp
     where "cmp \<mu>\<nu> = (if B.VV.arr \<mu>\<nu> then
                       G (F (H\<^sub>B (fst \<mu>\<nu>) (snd \<mu>\<nu>))) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>)) \<cdot>\<^sub>D
                         \<Phi>\<^sub>G (F (B.dom (fst \<mu>\<nu>)), F (B.dom (snd \<mu>\<nu>)))
                      else D.null)"
 
     lemma cmp_in_hom [intro]:
     assumes "B.VV.arr \<mu>\<nu>"
     shows "\<guillemotleft>cmp \<mu>\<nu> : H\<^sub>DoGF_GF.map (B.VV.dom \<mu>\<nu>) \<Rightarrow>\<^sub>D GFoH\<^sub>B.map (B.VV.cod \<mu>\<nu>)\<guillemotright>"
     proof -
       have "cmp \<mu>\<nu> = G (F (H\<^sub>B (fst \<mu>\<nu>) (snd \<mu>\<nu>))) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>)) \<cdot>\<^sub>D
                      \<Phi>\<^sub>G (F (B.dom (fst \<mu>\<nu>)), F (B.dom (snd \<mu>\<nu>)))"
         using assms cmp_def by simp
-      moreover have "\<guillemotleft> ... : H\<^sub>DoGF_GF.map (B.VV.dom \<mu>\<nu>)
-                                \<Rightarrow>\<^sub>D GFoH\<^sub>B.map (B.VV.cod \<mu>\<nu>)\<guillemotright>"
+      moreover have "\<guillemotleft> ... : H\<^sub>DoGF_GF.map (B.VV.dom \<mu>\<nu>) \<Rightarrow>\<^sub>D GFoH\<^sub>B.map (B.VV.cod \<mu>\<nu>)\<guillemotright>"
       proof (intro D.comp_in_homI)
         show "\<guillemotleft>\<Phi>\<^sub>G (F (B.dom (fst \<mu>\<nu>)), F (B.dom (snd \<mu>\<nu>))) :
                  H\<^sub>DoGF_GF.map (B.VV.dom \<mu>\<nu>)
                    \<Rightarrow>\<^sub>D G (F (B.dom (fst \<mu>\<nu>)) \<star>\<^sub>C F (B.dom (snd \<mu>\<nu>)))\<guillemotright>"
           using assms F.FF_def FF_def B.VV.arr_char B.VV.dom_simp by auto
         show "\<guillemotleft>G (\<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>)) :
                  G (F (B.dom (fst \<mu>\<nu>)) \<star>\<^sub>C F (B.dom (snd \<mu>\<nu>)))
                    \<Rightarrow>\<^sub>D GFoH\<^sub>B.map (B.VV.dom \<mu>\<nu>)\<guillemotright>"
           using assms B.VV.arr_char F.FF_def B.VV.dom_simp B.VV.cod_simp by auto
         show "\<guillemotleft>G (F (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)) :
                  GFoH\<^sub>B.map (B.VV.dom \<mu>\<nu>) \<Rightarrow>\<^sub>D GFoH\<^sub>B.map (B.VV.cod \<mu>\<nu>)\<guillemotright>"
         proof -
           have "B.VV.in_hom \<mu>\<nu> (B.VV.dom \<mu>\<nu>) (B.VV.cod \<mu>\<nu>)"
             using assms by auto
           thus ?thesis by auto
         qed
       qed
       ultimately show ?thesis by argo
     qed
 
     lemma cmp_simps [simp]:
     assumes "B.VV.arr \<mu>\<nu>"
     shows "D.arr (cmp \<mu>\<nu>)"
     and "D.dom (cmp \<mu>\<nu>) = H\<^sub>DoGF_GF.map (B.VV.dom \<mu>\<nu>)"
     and "D.cod (cmp \<mu>\<nu>) = GFoH\<^sub>B.map (B.VV.cod \<mu>\<nu>)"
       using assms cmp_in_hom by blast+
 
     interpretation \<Phi>: natural_transformation
                         B.VV.comp V\<^sub>D H\<^sub>DoGF_GF.map GFoH\<^sub>B.map cmp
     proof
       show "\<And>\<mu>\<nu>. \<not> B.VV.arr \<mu>\<nu> \<Longrightarrow> cmp \<mu>\<nu> = D.null"
         unfolding cmp_def by simp
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "B.VV.arr \<mu>\<nu>"
       show "D.dom (cmp \<mu>\<nu>) = H\<^sub>DoGF_GF.map (B.VV.dom \<mu>\<nu>)"
         using \<mu>\<nu> cmp_in_hom by blast
       show "D.cod (cmp \<mu>\<nu>) = GFoH\<^sub>B.map (B.VV.cod \<mu>\<nu>)"
         using \<mu>\<nu> cmp_in_hom by blast
       show "GFoH\<^sub>B.map \<mu>\<nu> \<cdot>\<^sub>D cmp (B.VV.dom \<mu>\<nu>) = cmp \<mu>\<nu>"
         unfolding cmp_def
         using \<mu>\<nu> B.VV.ide_char B.VV.arr_char D.comp_ide_arr B.VV.dom_char D.comp_assoc
               as_nat_trans.is_natural_1
         apply simp
         by (metis (no_types, lifting) B.H.preserves_arr B.hcomp_simps(3))
       show "cmp (B.VV.cod \<mu>\<nu>) \<cdot>\<^sub>D H\<^sub>DoGF_GF.map \<mu>\<nu> = cmp \<mu>\<nu>"
       proof -
         have "cmp (B.VV.cod \<mu>\<nu>) \<cdot>\<^sub>D H\<^sub>DoGF_GF.map \<mu>\<nu> =
               (G (F (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                 G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                   \<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>)))) \<cdot>\<^sub>D
                     (fst (FF \<mu>\<nu>) \<star>\<^sub>D snd (FF \<mu>\<nu>))"
           unfolding cmp_def
           using \<mu>\<nu> B.VV.arr_char B.VV.dom_simp B.VV.cod_simp by simp
         also have "... = (G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                             \<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>)))) \<cdot>\<^sub>D
                                (fst (FF \<mu>\<nu>) \<star>\<^sub>D snd (FF \<mu>\<nu>))"
         proof -
           have "D.ide (G (F (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))))"
             using \<mu>\<nu> B.VV.arr_char by simp
           moreover have "D.seq (G (F (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))))
                                (G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                                   \<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>))))"
             using \<mu>\<nu> B.VV.arr_char B.VV.dom_char B.VV.cod_char F.FF_def
             apply (intro D.seqI)
                 apply auto
           proof -
             show "G (F (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))) =
                   D.cod (G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                     \<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>))))"
             proof -
               have "D.seq (G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))))
                           (\<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>))))"
                 using \<mu>\<nu> B.VV.arr_char F.FF_def B.VV.arr_char B.VV.dom_char B.VV.cod_char
                 by (intro D.seqI) auto
               thus ?thesis 
                 using \<mu>\<nu> B.VV.arr_char B.VV.cod_simp by simp
             qed
           qed
           ultimately show ?thesis
             using \<mu>\<nu> D.comp_ide_arr [of "G (F (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)))"
                                         "G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                                            \<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>)))"]
             by simp
         qed
         also have "... = G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                             (\<Phi>\<^sub>G (F (B.cod (fst \<mu>\<nu>)), F (B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                                (fst (FF \<mu>\<nu>) \<star>\<^sub>D snd (FF \<mu>\<nu>)))"
           using D.comp_assoc by simp
         also have "... = G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (C.VV.cod (F.FF \<mu>\<nu>)) \<cdot>\<^sub>D G.H\<^sub>DoFF.map (F.FF \<mu>\<nu>)"
           using \<mu>\<nu> B.VV.arr_char F.FF_def G.FF_def FF_def C.VV.cod_simp by auto
         also have "... = G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                            G.FoH\<^sub>C.map (F.FF \<mu>\<nu>) \<cdot>\<^sub>D \<Phi>\<^sub>G (C.VV.dom (F.FF \<mu>\<nu>))"
           using \<mu>\<nu> B.VV.arr_char G.\<Phi>.naturality C.VV.dom_simp C.VV.cod_simp by simp
         also have "... = (G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D
                            G.FoH\<^sub>C.map (F.FF \<mu>\<nu>)) \<cdot>\<^sub>D \<Phi>\<^sub>G (C.VV.dom (F.FF \<mu>\<nu>))"
           using D.comp_assoc by simp
         also have "... = (G (\<Phi>\<^sub>F (B.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C F.H\<^sub>DoFF.map \<mu>\<nu>)) \<cdot>\<^sub>D
                          \<Phi>\<^sub>G (C.VV.dom (F.FF \<mu>\<nu>))"
         proof -
           have "(B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>)) = B.VV.cod \<mu>\<nu>"
             using \<mu>\<nu> B.VV.arr_char B.VV.cod_simp by simp
           moreover have "G.FoH\<^sub>C.map (F.FF \<mu>\<nu>) = G (F.H\<^sub>DoFF.map \<mu>\<nu>)"
             using \<mu>\<nu> F.FF_def by simp
           moreover have "G (\<Phi>\<^sub>F (B.cod (fst \<mu>\<nu>), B.cod (snd \<mu>\<nu>))) \<cdot>\<^sub>D G (F.H\<^sub>DoFF.map \<mu>\<nu>) =
                          G (\<Phi>\<^sub>F (B.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C F.H\<^sub>DoFF.map \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char
             by (metis (no_types, lifting) F.\<Phi>.is_natural_2 F.\<Phi>.preserves_reflects_arr
                 G.preserves_comp calculation(1))
           ultimately show ?thesis by argo
         qed
         also have "... = G (F.FoH\<^sub>C.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>)) \<cdot>\<^sub>D
                          \<Phi>\<^sub>G (C.VV.dom (F.FF \<mu>\<nu>))"
           using \<mu>\<nu> F.\<Phi>.naturality [of \<mu>\<nu>] F.FF_def by simp
         also have "... = G (F.FoH\<^sub>C.map \<mu>\<nu>) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>)) \<cdot>\<^sub>D
                          \<Phi>\<^sub>G (C.VV.dom (F.FF \<mu>\<nu>))"
         proof -
           have "G (F.FoH\<^sub>C.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>)) =
                 G (F.FoH\<^sub>C.map \<mu>\<nu>) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (B.VV.dom \<mu>\<nu>))"
             using \<mu>\<nu>
             by (metis (mono_tags, lifting) F.\<Phi>.is_natural_1 F.\<Phi>.preserves_reflects_arr
                 G.preserves_comp)
           thus ?thesis
             using \<mu>\<nu> D.comp_assoc by simp
         qed
         also have "... = cmp \<mu>\<nu>"
           using \<mu>\<nu> B.VV.arr_char cmp_def F.FF_def F.FF.preserves_dom B.VV.dom_simp
           by auto
         finally show ?thesis by simp
       qed
     qed
 
     interpretation \<Phi>: natural_isomorphism B.VV.comp V\<^sub>D H\<^sub>DoGF_GF.map GFoH\<^sub>B.map cmp
     proof
       show "\<And>hk. B.VV.ide hk \<Longrightarrow> D.iso (cmp hk)"
       proof -
         fix hk
         assume hk: "B.VV.ide hk"
         have "D.iso (G (F (fst hk \<star>\<^sub>B snd hk)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (B.VV.dom hk)) \<cdot>\<^sub>D
                        \<Phi>\<^sub>G (F (B.dom (fst hk)), F (B.dom (snd hk))))"
         proof (intro D.isos_compose)
           show "D.iso (\<Phi>\<^sub>G (F (B.dom (fst hk)), F (B.dom (snd hk))))"
             using hk G.\<Phi>.components_are_iso [of "(F (B.dom (fst hk)), F (B.dom (snd hk)))"]
                   C.VV.ide_char B.VV.arr_char B.VV.dom_char
             by (metis (no_types, lifting) B.VV.ideD(1) B.VV.ideD(2) B.VxV.dom_char
                 F.FF_def F.FF.as_nat_iso.components_are_iso G.\<Phi>.preserves_iso fst_conv snd_conv)
           show "D.iso (G (\<Phi>\<^sub>F (B.VV.dom hk)))"
             using hk F.\<Phi>.components_are_iso B.VV.arr_char B.VV.dom_char B.VV.ideD(2)
             by auto
           show "D.seq (G (\<Phi>\<^sub>F (B.VV.dom hk))) (\<Phi>\<^sub>G (F (B.dom (fst hk)), F (B.dom (snd hk))))"
             using hk B.VV.arr_char B.VV.ide_char B.VV.dom_char C.VV.arr_char F.FF_def
                   C.VV.dom_simp C.VV.cod_simp
             by auto
           show "D.iso (G (F (fst hk \<star>\<^sub>B snd hk)))"
             using hk F.\<Phi>.components_are_iso B.VV.arr_char by simp
           show "D.seq (G (F (fst hk \<star>\<^sub>B snd hk)))
                       (G (\<Phi>\<^sub>F (B.VV.dom hk)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F (B.dom (fst hk)), F (B.dom (snd hk))))"
             using hk B.VV.arr_char B.VV.dom_char
             by (metis (no_types, lifting) B.VV.ideD(1) cmp_def cmp_simps(1))
         qed
         thus "D.iso (cmp hk)"
           unfolding cmp_def using hk by simp
       qed
     qed
 
     sublocale pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>G o F\<close> cmp
     proof
       fix f g h
       assume f: "B.ide f" and g: "B.ide g" and h: "B.ide h"
       assume fg: "src\<^sub>B f = trg\<^sub>B g" and gh: "src\<^sub>B g = trg\<^sub>B h"
       show "map \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>D cmp (f \<star>\<^sub>B g, h) \<cdot>\<^sub>D (cmp (f, g) \<star>\<^sub>D map h) =
             cmp (f, g \<star>\<^sub>B h) \<cdot>\<^sub>D (map f \<star>\<^sub>D cmp (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[map f, map g, map h]"
       proof -
         have "map \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>D cmp (f \<star>\<^sub>B g, h) \<cdot>\<^sub>D (cmp (f, g) \<star>\<^sub>D map h) =
               G (F \<a>\<^sub>B[f, g, h]) \<cdot>\<^sub>D
                 (G (F ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h)) \<cdot>\<^sub>D
                   (G (F (f \<star>\<^sub>B g)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (f, g)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           unfolding cmp_def
           using f g h fg gh B.VV.arr_char B.VV.dom_simp by simp
         also have "... = G (F \<a>\<^sub>B[f, g, h]) \<cdot>\<^sub>D
                           (G (\<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h)) \<cdot>\<^sub>D
                             (G (F (f \<star>\<^sub>B g)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (f, g)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g h fg gh D.comp_ide_arr D.comp_assoc
           by (metis B.ideD(1) B.ide_hcomp B.src_hcomp F.cmp_simps(1) F.cmp_simps(5)
               G.as_nat_trans.is_natural_2)
         also have "... = G (F \<a>\<^sub>B[f, g, h]) \<cdot>\<^sub>D
                           (G (\<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h)) \<cdot>\<^sub>D
                             (G (\<Phi>\<^sub>F (f, g)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g fg
           by (metis (no_types) D.comp_assoc F.cmp_simps(1) F.cmp_simps(5)
               G.as_nat_trans.is_natural_2)
         also have "... = (G (F \<a>\<^sub>B[f, g, h]) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (f \<star>\<^sub>B g, h))) \<cdot>\<^sub>D
                             \<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h) \<cdot>\<^sub>D (G (\<Phi>\<^sub>F (f, g)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using D.comp_assoc by simp
         also have "... = G (F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D
                             \<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h) \<cdot>\<^sub>D (G (\<Phi>\<^sub>F (f, g)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g h fg gh B.VV.arr_char B.VV.cod_simp by simp
         also have "... = G (F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D
                             \<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h) \<cdot>\<^sub>D (G (\<Phi>\<^sub>F (f, g)) \<star>\<^sub>D G (F h)) \<cdot>\<^sub>D
                               (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g h fg gh B.VV.arr_char C.VV.arr_char F.FF_def D.whisker_right
                 B.VV.dom_simp C.VV.cod_simp
           by auto
         also have "... = G (F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D
                           (\<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h) \<cdot>\<^sub>D (G (\<Phi>\<^sub>F (f, g)) \<star>\<^sub>D G (F h))) \<cdot>\<^sub>D
                             (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using D.comp_assoc by simp
         also have "... = G (F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D
                           (G (\<Phi>\<^sub>F (f, g) \<star>\<^sub>C F h) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h)) \<cdot>\<^sub>D
                             (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
         proof -
           have "\<Phi>\<^sub>G (F (f \<star>\<^sub>B g), F h) = \<Phi>\<^sub>G (C.VV.cod (\<Phi>\<^sub>F (f, g), F h))"
             using f g h fg gh B.VV.arr_char C.VV.arr_char B.VV.cod_simp C.VV.cod_simp
             by simp
           moreover have "G (\<Phi>\<^sub>F (f, g)) \<star>\<^sub>D G (F h) = G.H\<^sub>DoFF.map (\<Phi>\<^sub>F (f, g), F h)"
             using f g h fg gh B.VV.arr_char C.VV.arr_char G.FF_def by simp
           moreover have "G.FoH\<^sub>C.map (\<Phi>\<^sub>F (f, g), F h) = G (\<Phi>\<^sub>F (f, g) \<star>\<^sub>C F h)"
             using f g h fg gh B.VV.arr_char by simp
           moreover have "\<Phi>\<^sub>G (C.VV.dom (\<Phi>\<^sub>F (f, g), F h)) = \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h)"
             using f g h fg gh C.VV.arr_char F.cmp_in_hom [of f g] C.VV.dom_simp by auto
           ultimately show ?thesis
             using f g h fg gh B.VV.arr_char G.\<Phi>.naturality
             by (metis (mono_tags, lifting) C.VV.arr_cod_iff_arr C.VV.arr_dom_iff_arr
                 G.FoH\<^sub>C.is_extensional G.H\<^sub>DoFF.is_extensional G.\<Phi>.is_extensional)
         qed
         also have "... = (G (F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>D (G (\<Phi>\<^sub>F (f, g) \<star>\<^sub>C F h))) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using D.comp_assoc by simp
         also have "... = G ((F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h)) \<cdot>\<^sub>C (\<Phi>\<^sub>F (f, g) \<star>\<^sub>C F h)) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g h fg gh B.VV.arr_char F.FF_def B.VV.dom_simp B.VV.cod_simp by auto
         also have "... = G (F \<a>\<^sub>B[f, g, h] \<cdot>\<^sub>C \<Phi>\<^sub>F (f \<star>\<^sub>B g, h) \<cdot>\<^sub>C (\<Phi>\<^sub>F (f, g) \<star>\<^sub>C F h)) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using C.comp_assoc by simp
         also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[F f, F g, F h]) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g h fg gh F.assoc_coherence [of f g h] by simp
         also have "... = G ((\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>C \<a>\<^sub>C[F f, F g, F h]) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using C.comp_assoc by simp
         also have "... = (G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D G \<a>\<^sub>C[F f, F g, F h]) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using f g h fg gh B.VV.arr_char F.FF_def B.VV.dom_simp B.VV.cod_simp by auto
         also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D
                            G \<a>\<^sub>C[F f, F g, F h] \<cdot>\<^sub>D \<Phi>\<^sub>G (F f \<star>\<^sub>C F g, F h) \<cdot>\<^sub>D
                            (\<Phi>\<^sub>G (F f, F g) \<star>\<^sub>D G (F h))"
           using D.comp_assoc by simp
         also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f, F g \<star>\<^sub>C F h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h)) \<cdot>\<^sub>D
                              \<a>\<^sub>D[G (F f), G (F g), G (F h)]"
           using f g h fg gh G.assoc_coherence [of "F f" "F g" "F h"] by simp
         also have "... = (G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D
                            \<Phi>\<^sub>G (F f, F g \<star>\<^sub>C F h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h))) \<cdot>\<^sub>D
                              \<a>\<^sub>D[G (F f), G (F g), G (F h)]"
           using D.comp_assoc by simp
         also have "... = (cmp (f, g \<star>\<^sub>B h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D cmp (g, h))) \<cdot>\<^sub>D
                            \<a>\<^sub>D[G (F f), G (F g), G (F h)]"
         proof -
           have "G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D
                   \<Phi>\<^sub>G (F f, F g \<star>\<^sub>C F h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h)) =
                 cmp (f, g \<star>\<^sub>B h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D cmp (g, h))"
           proof -
             have "cmp (f, g \<star>\<^sub>B h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D cmp (g, h)) =
                   (G (F (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h))) \<cdot>\<^sub>D
                     (G (F f) \<star>\<^sub>D G (F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
               unfolding cmp_def
               using f g h fg gh B.VV.arr_char B.VV.dom_simp B.VV.cod_simp by simp
             also have "... = (G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h))) \<cdot>\<^sub>D
                                (G (F f) \<star>\<^sub>D G (F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
             proof -
               have "G (F (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h))"
                 using f g h fg gh B.VV.arr_char D.comp_ide_arr B.VV.dom_simp B.VV.cod_simp
                 by simp
               thus ?thesis
                 using D.comp_assoc by metis
             qed
             also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D
                                (G (F f) \<star>\<^sub>D G (F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
               using D.comp_assoc by simp
             also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D
                                (G (F f) \<star>\<^sub>D G (\<Phi>\<^sub>F (g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
             proof -
               have "G (F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (g, h)) = G (\<Phi>\<^sub>F (g, h))"
                 using f g h fg gh B.VV.arr_char D.comp_ide_arr B.VV.dom_simp B.VV.cod_simp
                 by simp
               thus ?thesis
                 using D.comp_assoc by metis
             qed
             also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D
                                (G (F f) \<star>\<^sub>D G (\<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
               using f g h fg gh
                     D.whisker_left [of "G (F f)" "G (\<Phi>\<^sub>F (g, h))" "\<Phi>\<^sub>G (F g, F h)"]
               by fastforce
             also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D
                                (\<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h)) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D G (\<Phi>\<^sub>F (g, h)))) \<cdot>\<^sub>D
                                  (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
               using D.comp_assoc by simp
             also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D
                                (G (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F f, F g \<star>\<^sub>C F h)) \<cdot>\<^sub>D
                                  (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
             proof -
               have "\<Phi>\<^sub>G (C.VV.cod (F f, \<Phi>\<^sub>F (g, h))) = \<Phi>\<^sub>G (F f, F (g \<star>\<^sub>B h))"
                 using f g h fg gh B.VV.arr_char C.VV.cod_char B.VV.dom_simp B.VV.cod_simp
                 by auto
               moreover have "G.H\<^sub>DoFF.map (F f, \<Phi>\<^sub>F (g, h)) = G (F f) \<star>\<^sub>D G (\<Phi>\<^sub>F (g, h))"
                 using f g h fg gh B.VV.arr_char G.FF_def by auto
               moreover have "G.FoH\<^sub>C.map (F f, \<Phi>\<^sub>F (g, h)) = G (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))"
                 using f g h fg gh B.VV.arr_char C.VV.arr_char by simp
               moreover have "C.VV.dom (F f, \<Phi>\<^sub>F (g, h)) = (F f, F g \<star>\<^sub>C F h)"
                 using f g h fg gh B.VV.arr_char C.VV.arr_char C.VV.dom_char
                       F.cmp_in_hom [of g h]
                 by auto
               ultimately show ?thesis
                 using f g h fg gh B.VV.arr_char C.VV.arr_char
                       G.\<Phi>.naturality [of "(F f, \<Phi>\<^sub>F (g, h))"]
                 by simp
             qed
             also have "... = (G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h)) \<cdot>\<^sub>D (G (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h)))) \<cdot>\<^sub>D
                                \<Phi>\<^sub>G (F f, F g \<star>\<^sub>C F h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
               using D.comp_assoc by simp
             also have "... = G (\<Phi>\<^sub>F (f, g \<star>\<^sub>B h) \<cdot>\<^sub>C (F f \<star>\<^sub>C \<Phi>\<^sub>F (g, h))) \<cdot>\<^sub>D
                                \<Phi>\<^sub>G (F f, F g \<star>\<^sub>C F h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D \<Phi>\<^sub>G (F g, F h))"
               using f g h fg gh B.VV.arr_char
               by (metis (no_types, lifting) B.assoc_simps(1) C.comp_assoc C.seqE
                   F.preserves_assoc(1) F.preserves_reflects_arr G.preserves_comp)
             finally show ?thesis by simp
           qed
           thus ?thesis by simp
         qed
         also have "... = cmp (f, g \<star>\<^sub>B h) \<cdot>\<^sub>D (G (F f) \<star>\<^sub>D cmp (g, h)) \<cdot>\<^sub>D
                            \<a>\<^sub>D[G (F f), G (F g), G (F h)]"
           using D.comp_assoc by simp
         finally show ?thesis by simp
       qed
     qed
 
     lemma is_pseudofunctor:
     shows "pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (G o F) cmp"
       ..
 
     lemma map\<^sub>0_simp [simp]:
     assumes "B.obj a"
     shows "map\<^sub>0 a = G.map\<^sub>0 (F.map\<^sub>0 a)"
       using assms map\<^sub>0_def by auto
 
     lemma unit_char':
     assumes "B.obj a"
     shows "unit a = G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a)"
     proof -
       have "G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a) = unit a"
       proof (intro unit_eqI [of a "G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a)"])
         show "B.obj a" by fact
         show "\<guillemotleft>G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a) : map\<^sub>0 a \<Rightarrow>\<^sub>D map a\<guillemotright>"
           using assms by auto
         show "D.iso (G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a))"
           by (simp add: D.isos_compose F.unit_char(2) G.unit_char(2) assms)
         show "(G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a)) \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] =
               (map \<i>\<^sub>B[a] \<cdot>\<^sub>D cmp (a, a)) \<cdot>\<^sub>D
                 (G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a))"
         proof -
           have 1: "cmp (a, a) = G (\<Phi>\<^sub>F (a, a)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F a, F a)"
           proof -
             have "cmp (a, a) = (G (F (a \<star>\<^sub>B a)) \<cdot>\<^sub>D G (\<Phi>\<^sub>F (a, a))) \<cdot>\<^sub>D \<Phi>\<^sub>G (F a, F a)"
               using assms cmp_def B.VV.ide_char B.VV.arr_char B.VV.dom_char B.VV.cod_char
                     B.VxV.dom_char B.objE D.comp_assoc B.obj_simps
               by simp
             also have "... = G (\<Phi>\<^sub>F (a, a)) \<cdot>\<^sub>D \<Phi>\<^sub>G (F a, F a)"
               using assms D.comp_cod_arr B.VV.arr_char B.VV.ide_char by auto
             finally show ?thesis by blast
           qed
           have "(map \<i>\<^sub>B[a] \<cdot>\<^sub>D cmp (a, a)) \<cdot>\<^sub>D
                   (G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a)) =
                 map \<i>\<^sub>B[a] \<cdot>\<^sub>D G (\<Phi>\<^sub>F (a, a)) \<cdot>\<^sub>D
                     (\<Phi>\<^sub>G (F a, F a) \<cdot>\<^sub>D (G (F.unit a) \<star>\<^sub>D G (F.unit a))) \<cdot>\<^sub>D
                     (G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G.unit (F.map\<^sub>0 a))"
             using assms 1 D.comp_assoc D.interchange by simp
           also have "... = (map \<i>\<^sub>B[a] \<cdot>\<^sub>D G (\<Phi>\<^sub>F (a, a)) \<cdot>\<^sub>D G (F.unit a \<star>\<^sub>C F.unit a)) \<cdot>\<^sub>D
                              \<Phi>\<^sub>G (F.map\<^sub>0 a, F.map\<^sub>0 a) \<cdot>\<^sub>D
                              (G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G.unit (F.map\<^sub>0 a))"
             using assms G.\<Phi>.naturality [of "(F.unit a, F.unit a)"]
                   C.VV.arr_char C.VV.dom_char C.VV.cod_char G.FF_def D.comp_assoc
             by simp
           also have "... = (G (F \<i>\<^sub>B[a] \<cdot>\<^sub>C \<Phi>\<^sub>F (a, a) \<cdot>\<^sub>C (F.unit a \<star>\<^sub>C F.unit a))) \<cdot>\<^sub>D
                              \<Phi>\<^sub>G (F.map\<^sub>0 a, F.map\<^sub>0 a) \<cdot>\<^sub>D
                              (G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G.unit (F.map\<^sub>0 a))"
           proof -
             have "C.arr (F \<i>\<^sub>B[a] \<cdot>\<^sub>C \<Phi>\<^sub>F (a, a) \<cdot>\<^sub>C (F.unit a \<star>\<^sub>C F.unit a))"
               using assms B.VV.ide_char B.VV.arr_char F.cmp_in_hom(2)
               by (intro C.seqI' C.comp_in_homI) auto
             hence "map \<i>\<^sub>B[a] \<cdot>\<^sub>D G (\<Phi>\<^sub>F (a, a)) \<cdot>\<^sub>D G (F.unit a \<star>\<^sub>C F.unit a) =
                   G (F \<i>\<^sub>B[a] \<cdot>\<^sub>C \<Phi>\<^sub>F (a, a) \<cdot>\<^sub>C (F.unit a \<star>\<^sub>C F.unit a))"
               by auto
             thus ?thesis by argo
           qed
           also have "... = G (F.unit a \<cdot>\<^sub>C \<i>\<^sub>C[F.map\<^sub>0 a]) \<cdot>\<^sub>D
                              \<Phi>\<^sub>G (F.map\<^sub>0 a, F.map\<^sub>0 a) \<cdot>\<^sub>D
                              (G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G.unit (F.map\<^sub>0 a))"
             using assms F.unit_char C.comp_assoc by simp
           also have "... = G (F.unit a) \<cdot>\<^sub>D (G \<i>\<^sub>C[F.map\<^sub>0 a] \<cdot>\<^sub>D
                              \<Phi>\<^sub>G (F.map\<^sub>0 a, F.map\<^sub>0 a)) \<cdot>\<^sub>D
                              (G.unit (F.map\<^sub>0 a) \<star>\<^sub>D G.unit (F.map\<^sub>0 a))"
             using assms D.comp_assoc by simp
           also have "... = (G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a)) \<cdot>\<^sub>D \<i>\<^sub>D[G.map\<^sub>0 (F.map\<^sub>0 a)]"
             using assms G.unit_char D.comp_assoc by simp
           also have "... = (G (F.unit a) \<cdot>\<^sub>D G.unit (F.map\<^sub>0 a)) \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a]"
             using assms map\<^sub>0_def by auto
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis by simp
     qed
 
   end
 
   subsection "Restriction of Pseudofunctors"
 
   text \<open>
     In this section, we construct the restriction and corestriction of a pseudofunctor to
     a subbicategory of its domain and codomain, respectively.
   \<close>
 
   locale restricted_pseudofunctor =
     C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
     D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
     F: 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> +
     C': subbicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C Arr
   for V\<^sub>C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd"
   and \<Phi> :: "'c * 'c \<Rightarrow> 'd"
   and Arr :: "'c \<Rightarrow> bool"
   begin
 
     abbreviation map
     where "map \<equiv> \<lambda>\<mu>. if C'.arr \<mu> then F \<mu> else D.null"
 
     abbreviation cmp
     where "cmp \<equiv> \<lambda>\<mu>\<nu>. if C'.VV.arr \<mu>\<nu> then \<Phi> \<mu>\<nu> else D.null"
 
     interpretation "functor" C'.comp V\<^sub>D map
       using C'.inclusion C'.arr_char C'.dom_char C'.cod_char C'.seq_char C'.comp_char
             C'.arr_dom C'.arr_cod
       apply (unfold_locales)
           apply auto
       by presburger
 
     interpretation weak_arrow_of_homs C'.comp C'.src C'.trg V\<^sub>D src\<^sub>D trg\<^sub>D map
       using C'.arrE C'.ide_src C'.ide_trg C'.inclusion C'.src_def C'.trg_def
             F.weakly_preserves_src F.weakly_preserves_trg
       by unfold_locales auto
 
     interpretation H\<^sub>D\<^sub>'oFF: composite_functor C'.VV.comp D.VV.comp V\<^sub>D FF
                              \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>D snd \<mu>\<nu>\<close>
       ..
     interpretation FoH\<^sub>C\<^sub>': composite_functor C'.VV.comp C'.comp V\<^sub>D
                              \<open>\<lambda>\<mu>\<nu>. C'.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> map
       ..
 
     interpretation \<Phi>: natural_transformation C'.VV.comp V\<^sub>D H\<^sub>D\<^sub>'oFF.map FoH\<^sub>C\<^sub>'.map cmp
       using C'.arr_char C'.dom_char C'.cod_char C'.VV.arr_char C'.VV.dom_char C'.VV.cod_char
             FF_def C'.inclusion C'.dom_closed C'.cod_closed C'.src_def C'.trg_def
             C'.hcomp_def C'.hcomp_closed F.\<Phi>.is_natural_1 F.\<Phi>.is_natural_2
             C.VV.arr_char C.VV.dom_char C.VV.cod_char F.FF_def
       by unfold_locales auto
 
     interpretation \<Phi>: natural_isomorphism C'.VV.comp V\<^sub>D H\<^sub>D\<^sub>'oFF.map FoH\<^sub>C\<^sub>'.map cmp
       using C.VV.ide_char C.VV.arr_char C'.VV.ide_char C'.VV.arr_char C'.arr_char
             C'.src_def C'.trg_def C'.ide_char F.\<Phi>.components_are_iso
       by unfold_locales auto
 
     sublocale pseudofunctor C'.comp C'.hcomp C'.\<a> \<i>\<^sub>C C'.src C'.trg V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
                 map cmp
       using F.assoc_coherence C'.VVV.arr_char C'.VV.arr_char C'.arr_char C'.hcomp_def
             C'.src_def C'.trg_def C'.assoc_closed C'.hcomp_closed C'.ide_char
-      by unfold_locales (simp add: C'.ide_char C'.src_def C'.trg_def)
+      by unfold_locales auto
 
     lemma is_pseudofunctor:
     shows "pseudofunctor C'.comp C'.hcomp C'.\<a> \<i>\<^sub>C C'.src C'.trg V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D map cmp"
       ..
 
     lemma map\<^sub>0_simp [simp]:
     assumes "C'.obj a"
     shows "map\<^sub>0 a = F.map\<^sub>0 a"
       using assms map\<^sub>0_def C'.obj_char by auto
 
     lemma unit_char':
     assumes "C'.obj a"
     shows "F.unit a = unit a"
       using assms map\<^sub>0_simp C'.obj_char F.unit_in_hom(2) [of a] F.unit_char(2-3) \<i>_simps(1)
       apply (intro unit_eqI)
          apply auto
       by blast
 
   end
 
   text \<open>
     We define the corestriction construction only for the case of sub-bicategories
     determined by a set of objects of the ambient bicategory.
     There are undoubtedly more general constructions, but this one is adequate for our
     present needs.
   \<close>
 
   locale corestricted_pseudofunctor =
     C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
     D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
     F: 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> +
     D': subbicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>\<lambda>\<mu>. D.arr \<mu> \<and> Obj (src\<^sub>D \<mu>) \<and> Obj (trg\<^sub>D \<mu>)\<close>
   for V\<^sub>C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd"
   and \<Phi> :: "'c * 'c \<Rightarrow> 'd"
   and Obj :: "'d \<Rightarrow> bool" +
   assumes preserves_arr: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D'.arr (F \<mu>)"
   begin
 
     abbreviation map
     where "map \<equiv> F"
 
     abbreviation cmp
     where "cmp \<equiv> \<Phi>"
 
     interpretation "functor" V\<^sub>C D'.comp F
       using preserves_arr F.is_extensional D'.arr_char D'.dom_char D'.cod_char D'.comp_char
       by (unfold_locales) auto
 
     interpretation weak_arrow_of_homs V\<^sub>C src\<^sub>C trg\<^sub>C D'.comp D'.src D'.trg F
     proof
       fix \<mu>
       assume \<mu>: "C.arr \<mu>"
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F (src\<^sub>C \<mu>) \<Rightarrow>\<^sub>D src\<^sub>D (F \<mu>)\<guillemotright> \<and> D.iso \<phi>"
         using \<mu> F.weakly_preserves_src by auto
       have 2: "D'.in_hom \<phi> (F (src\<^sub>C \<mu>)) (D'.src (F \<mu>))"
         using \<mu> \<phi> D'.arr_char D'.dom_char D'.cod_char D'.src_def D.vconn_implies_hpar(1-2)
               preserves_arr
         by (metis (no_types, lifting) C.src.preserves_arr D'.in_hom_char D'.src.preserves_arr
             D.arrI)
       moreover have "D'.iso \<phi>"
         using 2 \<phi> D'.iso_char D'.arr_char by fastforce
       ultimately show "D'.isomorphic (F (src\<^sub>C \<mu>)) (D'.src (F \<mu>))"
         using D'.isomorphic_def by auto
       obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : F (trg\<^sub>C \<mu>) \<Rightarrow>\<^sub>D trg\<^sub>D (F \<mu>)\<guillemotright> \<and> D.iso \<psi>"
         using \<mu> F.weakly_preserves_trg by auto
       have 2: "D'.in_hom \<psi> (F (trg\<^sub>C \<mu>)) (D'.trg (F \<mu>))"
         using \<mu> \<psi> D'.arr_char D'.dom_char D'.cod_char D'.trg_def D.vconn_implies_hpar(1-2)
               preserves_arr
         by (metis (no_types, lifting) C.trg.preserves_arr D'.in_hom_char D'.trg.preserves_arr
             D.arrI)
       moreover have "D'.iso \<psi>"
         using 2 \<psi> D'.iso_char D'.arr_char by fastforce
       ultimately show "D'.isomorphic (F (trg\<^sub>C \<mu>)) (D'.trg (F \<mu>))"
         using D'.isomorphic_def by auto
     qed
 
     interpretation H\<^sub>D\<^sub>'oFF: composite_functor C.VV.comp D'.VV.comp D'.comp FF
                              \<open>\<lambda>\<mu>\<nu>. D'.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
       ..
     interpretation FoH\<^sub>C: composite_functor C.VV.comp V\<^sub>C D'.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>C snd \<mu>\<nu>\<close>
                              F
       ..
 
     interpretation natural_transformation C.VV.comp D'.comp H\<^sub>D\<^sub>'oFF.map FoH\<^sub>C.map \<Phi>
     proof
       show "\<And>\<mu>\<nu>. \<not> C.VV.arr \<mu>\<nu> \<Longrightarrow> \<Phi> \<mu>\<nu> = D'.null"
         by (simp add: F.\<Phi>.is_extensional)
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "C.VV.arr \<mu>\<nu>"
       have 1: "D'.arr (\<Phi> \<mu>\<nu>)"
         using \<mu>\<nu> D'.arr_char F.\<Phi>.is_natural_1 F.\<Phi>.components_are_iso
         by (metis (no_types, lifting) D.src_vcomp D.trg_vcomp FoH\<^sub>C.preserves_arr
             F.\<Phi>.preserves_reflects_arr)
       show "D'.dom (\<Phi> \<mu>\<nu>) = H\<^sub>D\<^sub>'oFF.map (C.VV.dom \<mu>\<nu>)"
         using 1 \<mu>\<nu> D'.dom_char C.VV.arr_char C.VV.dom_char F.FF_def FF_def D'.hcomp_def
         by simp
       show "D'.cod (\<Phi> \<mu>\<nu>) = FoH\<^sub>C.map (C.VV.cod \<mu>\<nu>)"
         using 1 \<mu>\<nu> D'.cod_char C.VV.arr_char F.FF_def FF_def D'.hcomp_def by simp
       show "D'.comp (FoH\<^sub>C.map \<mu>\<nu>) (\<Phi> (C.VV.dom \<mu>\<nu>)) = \<Phi> \<mu>\<nu>"
         using 1 \<mu>\<nu> D'.arr_char D'.comp_char C.VV.dom_char F.\<Phi>.is_natural_1
               C.VV.arr_dom D.src_vcomp D.trg_vcomp FoH\<^sub>C.preserves_arr F.\<Phi>.preserves_reflects_arr
         by (metis (mono_tags, lifting))
       show "D'.comp (\<Phi> (C.VV.cod \<mu>\<nu>)) (H\<^sub>D\<^sub>'oFF.map \<mu>\<nu>) = \<Phi> \<mu>\<nu>"
       proof -
         have "Obj (F.map\<^sub>0 (trg\<^sub>C (fst \<mu>\<nu>))) \<and> Obj (F.map\<^sub>0 (trg\<^sub>C (snd \<mu>\<nu>)))"
           using \<mu>\<nu> C.VV.arr_char
           by (metis (no_types, lifting) C.src_trg C.trg.preserves_reflects_arr D'.arr_char
               F.map\<^sub>0_def preserves_hseq)
         moreover have "Obj (F.map\<^sub>0 (src\<^sub>C (snd \<mu>\<nu>)))"
           using \<mu>\<nu> C.VV.arr_char
           by (metis (no_types, lifting) C.src.preserves_reflects_arr C.trg_src D'.arr_char
               F.map\<^sub>0_def preserves_hseq)
         ultimately show ?thesis
           using \<mu>\<nu> 1 D'.arr_char D'.comp_char D'.hseq_char C.VV.arr_char C.VV.cod_char
                 C.VxV.cod_char FF_def F.FF_def D'.hcomp_char preserves_hseq
           apply simp
           using F.\<Phi>.is_natural_2 by force
       qed
     qed
 
     interpretation natural_isomorphism C.VV.comp D'.comp H\<^sub>D\<^sub>'oFF.map FoH\<^sub>C.map \<Phi>
       apply unfold_locales
       using D'.iso_char D'.arr_char by fastforce
 
     sublocale pseudofunctor V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C D'.comp D'.hcomp D'.\<a> \<i>\<^sub>D D'.src D'.trg
                 F \<Phi>
     proof
       fix f g h
       assume f: "C.ide f" and g: "C.ide g" and h: "C.ide h"
       and fg: "src\<^sub>C f = trg\<^sub>C g" and gh: "src\<^sub>C g = trg\<^sub>C h"
       have "D'.comp (F \<a>\<^sub>C[f, g, h]) (D'.comp (\<Phi> (f \<star>\<^sub>C g, h)) (D'.hcomp (\<Phi> (f, g)) (F h))) =
             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)"
       proof -
         have 1: "D'.arr (cmp (f, g) \<star>\<^sub>D map h)"
           by (metis (mono_tags, lifting) C.ideD(1) D'.arr_char D'.hcomp_closed
               F.\<Phi>.preserves_reflects_arr F.cmp_simps(1-2) F.preserves_hseq 
               f fg g gh h preserves_reflects_arr)
         moreover have 2: "D.seq (cmp (f \<star>\<^sub>C g, h)) (cmp (f, g) \<star>\<^sub>D map h)"
           using 1 f g h fg gh D'.arr_char C.VV.arr_char C.VV.dom_char C.VV.cod_char F.FF_def
           by (intro D.seqI) auto
         moreover have "D'.arr (cmp (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (cmp (f, g) \<star>\<^sub>D map h))"
           using 1 2 D'.arr_char
           by (metis (no_types, lifting) D'.comp_char D'.seq_char D.seqE F.\<Phi>.preserves_reflects_arr
               preserves_reflects_arr)
         ultimately show ?thesis
           using f g h fg gh D'.dom_char D'.cod_char D'.comp_char D'.hcomp_def C.VV.arr_char
           apply simp
           by force
       qed
       also have "... = \<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 f g h fg gh F.assoc_coherence [of f g h] by blast
       also have "... = D'.comp (\<Phi> (f, g \<star>\<^sub>C h))
                                (D'.comp (D'.hcomp (F f) (\<Phi> (g, h))) (D'.\<a> (F f) (F g) (F h)))"
       proof -
         have "D.seq (map f \<star>\<^sub>D cmp (g, h)) \<a>\<^sub>D[map f, map g, map h]"
           using f g h fg gh C.VV.arr_char C.VV.dom_char C.VV.cod_char F.FF_def
           by (intro D.seqI) auto
         moreover have "D'.arr \<a>\<^sub>D[map f, map g, map h]"
           using f g h fg gh D'.arr_char preserves_arr by auto
         moreover have "D'.arr (map f \<star>\<^sub>D cmp (g, h))"
           using f g h fg gh
           by (metis (no_types, lifting) D'.arr_char D.seqE D.vseq_implies_hpar(1)
               D.vseq_implies_hpar(2) calculation(1-2))
         moreover have "D'.arr ((map f \<star>\<^sub>D cmp (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[map f, map g, map h])"
           using f g h fg gh
           by (metis (no_types, lifting) D'.arr_char D'.comp_closed D.seqE
               calculation(1-3))
         moreover have "D.seq (cmp (f, g \<star>\<^sub>C h))
                              ((map f \<star>\<^sub>D cmp (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[map f, map g, map h])"
           using f g h fg gh F.cmp_simps'(1) F.cmp_simps(4) F.cmp_simps(5) by auto
         ultimately show ?thesis
           using f g h fg gh C.VV.arr_char D'.VVV.arr_char D'.VV.arr_char D'.comp_char
                 D'.hcomp_def
         by simp
       qed
       finally show "D'.comp (F \<a>\<^sub>C[f, g, h])
                             (D'.comp (\<Phi> (f \<star>\<^sub>C g, h)) (D'.hcomp (\<Phi> (f, g)) (F h))) =
                     D'.comp (\<Phi> (f, g \<star>\<^sub>C h))
                             (D'.comp (D'.hcomp (F f) (\<Phi> (g, h))) (D'.\<a> (F f) (F g) (F h)))"
         by blast
     qed
 
     lemma is_pseudofunctor:
     shows "pseudofunctor V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C D'.comp D'.hcomp D'.\<a> \<i>\<^sub>D D'.src D'.trg F \<Phi>"
       ..
 
     lemma map\<^sub>0_simp [simp]:
     assumes "C.obj a"
     shows "map\<^sub>0 a = F.map\<^sub>0 a"
       using assms map\<^sub>0_def D'.src_def by auto
 
     lemma unit_char':
     assumes "C.obj a"
     shows "F.unit a = unit a"
     proof (intro unit_eqI)
       show "C.obj a" by fact
       show 1: "D'.in_hom (F.unit a) (map\<^sub>0 a) (map a)"
         using D'.arr_char D'.in_hom_char assms unit_in_hom(2) by force
       show "D'.iso (F.unit a)"
         using assms D'.iso_char D'.arr_char F.unit_char(2)
               \<open>D'.in_hom (F.unit a) (map\<^sub>0 a) (map a)\<close>
         by auto
       show "D'.comp (F.unit a) \<i>\<^sub>D[map\<^sub>0 a] =
             D'.comp (D'.comp (map \<i>\<^sub>C[a]) (cmp (a, a)))
                     (D'.hcomp (F.unit a) (F.unit a))"
       proof -
         have "D'.comp (F.unit a) \<i>\<^sub>D[map\<^sub>0 a] = F.unit a \<cdot>\<^sub>D \<i>\<^sub>D[src\<^sub>D (map a)]"
           using assms D'.comp_char D'.arr_char
           apply simp
           by (metis (no_types, lifting) C.obj_simps(1-2) F.preserves_src preserves_arr)
         also have "... = (map \<i>\<^sub>C[a] \<cdot>\<^sub>D cmp (a, a)) \<cdot>\<^sub>D (F.unit a \<star>\<^sub>D F.unit a)"
           using assms F.unit_char(3) [of a] by auto
         also have "... = D'.comp (D'.comp (map \<i>\<^sub>C[a]) (cmp (a, a)))
                                  (D'.hcomp (F.unit a) (F.unit a))"
         proof -
           have "D'.arr (map \<i>\<^sub>C[a] \<cdot>\<^sub>D cmp (a, a))"
             using assms D'.comp_simp by auto
           moreover have "D.seq (map \<i>\<^sub>C[a] \<cdot>\<^sub>D cmp (a, a)) (F.unit a \<star>\<^sub>D F.unit a)"
             using assms C.VV.arr_char F.cmp_simps(4-5)
             by (intro D.seqI) auto
           ultimately show ?thesis
             by (metis (no_types, lifting) "1" D'.comp_eqI' D'.hcomp_eqI' D'.hseqI'
                 D'.iso_is_arr D'.seq_char D'.vconn_implies_hpar(1-2)
                 \<i>_simps(1) \<open>D'.iso (F.unit a)\<close> assms map\<^sub>0_simps(2-3))
         qed
         finally show ?thesis by blast
       qed
     qed
 
   end
 
 
   subsection "Equivalence Pseudofunctors"
 
   text \<open>
     In this section, we define ``equivalence pseudofunctors'', which are pseudofunctors
     that are locally fully faithful, locally essentially surjective, and biessentially
     surjective on objects.  In a later section, we will show that a pseudofunctor is
     an equivalence pseudofunctor if and only if it can be extended to an equivalence
     of bicategories.
 
     The definition below requires that an equivalence pseudofunctor be (globally) faithful
     with respect to vertical composition.  Traditional formulations do not consider a
     pseudofunctor as a single global functor, so we have to consider whether this condition
     is too strong.  In fact, a pseudofunctor (as defined here) is locally faithful if and
     only if it is globally faithful.
   \<close>
 
   context pseudofunctor
   begin
 
     definition locally_faithful
     where "locally_faithful \<equiv>
            \<forall>f g \<mu> \<mu>'. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> F \<mu> = F \<mu>' \<longrightarrow> \<mu> = \<mu>'"
 
     lemma locally_faithful_iff_faithful:
     shows "locally_faithful \<longleftrightarrow> faithful_functor V\<^sub>C V\<^sub>D F"
     proof
       show "faithful_functor V\<^sub>C V\<^sub>D F \<Longrightarrow> locally_faithful"
         by (metis category.in_homE faithful_functor.is_faithful functor_axioms
             functor_def locally_faithful_def)
       show "locally_faithful \<Longrightarrow> faithful_functor V\<^sub>C V\<^sub>D F"
       proof -
         assume 1: "locally_faithful"
         show "faithful_functor V\<^sub>C V\<^sub>D F"
         proof
           fix \<mu> \<mu>'
           assume par: "C.par \<mu> \<mu>'" and eq: "F \<mu> = F \<mu>'"
           obtain f g where fg: "\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>C g\<guillemotright>"
             using par by auto
           show "\<mu> = \<mu>'"
             using 1 fg locally_faithful_def eq by simp
         qed
       qed
     qed
 
   end
 
   text \<open>
     In contrast, it is not true that a pseudofunctor that is locally full is also
     globally full, because we can have \<open>\<guillemotleft>\<nu> : F h \<Rightarrow>\<^sub>D F k\<guillemotright>\<close> even if \<open>h\<close> and \<open>k\<close>
     are not in the same hom-category.  So it would be a mistake to require that an
     equivalence functor be globally full.
   \<close>
 
   locale equivalence_pseudofunctor =
     pseudofunctor +
     faithful_functor V\<^sub>C V\<^sub>D F +
   assumes biessentially_surjective_on_objects:
             "D.obj a' \<Longrightarrow> \<exists>a. C.obj a \<and> D.equivalent_objects (map\<^sub>0 a) a'"
   and locally_essentially_surjective:
             "\<lbrakk> C.obj a; C.obj b; \<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright>; D.ide g \<rbrakk> \<Longrightarrow>
                 \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) g"
   and locally_full:
             "\<lbrakk> C.ide f; C.ide f'; src\<^sub>C f = src\<^sub>C f'; trg\<^sub>C f = trg\<^sub>C f'; \<guillemotleft>\<nu> : F f \<Rightarrow>\<^sub>D F f'\<guillemotright> \<rbrakk> \<Longrightarrow>
                 \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C f'\<guillemotright> \<and> F \<mu> = \<nu>"
   begin
 
     lemma reflects_ide:
     assumes "C.endo \<mu>" and "D.ide (F \<mu>)"
     shows "C.ide \<mu>"
       using assms is_faithful [of "C.dom \<mu>" \<mu>] C.ide_char'
       by (metis C.arr_dom C.cod_dom C.dom_dom C.seqE D.ide_char preserves_dom)
 
     lemma reflects_iso:
     assumes "C.arr \<mu>" and "D.iso (F \<mu>)"
     shows "C.iso \<mu>"
     proof -
       obtain \<mu>' where \<mu>': "\<guillemotleft>\<mu>' : C.cod \<mu> \<Rightarrow>\<^sub>C C.dom \<mu>\<guillemotright> \<and> F \<mu>' = D.inv (F \<mu>)"
         using assms locally_full [of "C.cod \<mu>" "C.dom \<mu>" "D.inv (F \<mu>)"]
               D.inv_in_hom C.in_homE preserves_hom C.in_homI
         by auto
       have "C.inverse_arrows \<mu> \<mu>'"
         using assms \<mu>' reflects_ide
         apply (intro C.inverse_arrowsI)
          apply (metis C.cod_comp C.dom_comp C.ide_dom C.in_homE C.seqI D.comp_inv_arr'
                 faithful_functor_axioms faithful_functor_def functor.preserves_ide
                 as_nat_trans.preserves_comp_2 preserves_dom)
         by (metis C.cod_comp C.dom_comp C.ide_cod C.in_homE C.seqI D.comp_arr_inv'
             faithful_functor_axioms faithful_functor_def functor.preserves_ide
             preserves_cod as_nat_trans.preserves_comp_2)
       thus ?thesis by auto
     qed
 
     lemma reflects_isomorphic:
     assumes "C.ide f" and "C.ide f'" and "src\<^sub>C f = src\<^sub>C f'" and "trg\<^sub>C f = trg\<^sub>C f'"
     and "D.isomorphic (F f) (F f')"
     shows "C.isomorphic f f'"
       using assms C.isomorphic_def D.isomorphic_def locally_full reflects_iso C.arrI
       by metis
 
     lemma reflects_equivalence:
     assumes "C.ide f" and "C.ide g"
     and "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
     and "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
            (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f))
            (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
     shows "equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
     proof -
       interpret E': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close>
                       \<open>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f)\<close>
                       \<open>D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)\<close>
         using assms by auto
       show ?thesis
       proof
         show "C.ide f"
           using assms(1) by simp
         show "C.ide g"
           using assms(2) by simp
         show "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>"
           using assms(3) by simp
         show "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
           using assms(4) by simp
         have 0: "src\<^sub>C f = trg\<^sub>C g \<and> src\<^sub>C g = trg\<^sub>C f"
           using \<open>\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>\<close>
           by (metis C.hseqE C.ideD(1) C.ide_cod C.ide_dom C.in_homE assms(4))
         show "C.iso \<eta>"
         proof -
           have "D.iso (F \<eta>)"
           proof -
             have 1:  "\<guillemotleft>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f) : map\<^sub>0 (src\<^sub>C f) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
               using \<open>C.ide f\<close> \<open>C.ide g\<close> \<open>\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>\<close>
                     unit_char cmp_in_hom cmp_components_are_iso
               by (metis (mono_tags, lifting) C.ideD(1) E'.unit_in_vhom preserves_src)
             have 2: "D.iso (\<Phi> (g, f)) \<and> \<guillemotleft>\<Phi> (g, f) : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
               using 0 \<open>C.ide f\<close> \<open>C.ide g\<close> cmp_in_hom by simp
             have 3: "D.iso (D.inv (unit (src\<^sub>C f))) \<and>
                      \<guillemotleft>D.inv (unit (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright>"
                using \<open>C.ide f\<close> unit_char by simp
             have "D.iso (\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f)) \<cdot>\<^sub>D
                     D.inv (unit (src\<^sub>C f)))"
               using 1 2 3 E'.unit_is_iso D.isos_compose by blast
             moreover have "\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f)) \<cdot>\<^sub>D
                              D.inv (unit (src\<^sub>C f)) =
                            F \<eta>"
             proof -
               have "\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D unit (src\<^sub>C f)) \<cdot>\<^sub>D
                     D.inv (unit (src\<^sub>C f))
                       = (\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D (unit (src\<^sub>C f)) \<cdot>\<^sub>D
                         D.inv (unit (src\<^sub>C f)))"
                 using D.comp_assoc by simp
               also have "... = F (g \<star>\<^sub>C f) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D F (src\<^sub>C f)"
                 using 2 3 D.comp_arr_inv D.comp_inv_arr D.inv_is_inverse
                 by (metis C.ideD(1) C.obj_src D.comp_assoc D.dom_inv D.in_homE unit_char(2)
                           assms(1))
               also have "... = F \<eta>"
                 using \<open>\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>\<close> D.comp_arr_dom D.comp_cod_arr by auto
               finally show ?thesis by simp
             qed
             ultimately show ?thesis by simp
           qed
           thus ?thesis
             using assms reflects_iso by auto
         qed
         show "C.iso \<epsilon>"
         proof -
           have "D.iso (F \<epsilon>)"
           proof -
             have 1:  "\<guillemotleft>D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C g)\<guillemotright>"
               using \<open>C.ide f\<close> \<open>C.ide g\<close> \<open>\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>\<close>
                     unit_char cmp_in_hom cmp_components_are_iso
               by (metis (mono_tags, lifting) C.ideD(1) E'.counit_in_vhom preserves_src)
             have 2: "D.iso (D.inv (\<Phi> (f, g))) \<and>
                      \<guillemotleft>D.inv (\<Phi> (f, g)) : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g\<guillemotright>"
               using 0 \<open>C.ide f\<close> \<open>C.ide g\<close> \<open>\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>\<close> cmp_in_hom(2) D.inv_in_hom
               by simp
             have 3: "D.iso (unit (trg\<^sub>C f)) \<and> \<guillemotleft>unit (trg\<^sub>C f) : map\<^sub>0 (trg\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
                using \<open>C.ide f\<close> unit_char by simp
             have "D.iso (unit (trg\<^sub>C f) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
                   D.inv (\<Phi> (f, g)))"
               using 0 1 2 3 E'.counit_is_iso D.isos_compose
               by (metis D.arrI D.cod_comp D.cod_inv D.seqI D.seqI')
             moreover have "unit (trg\<^sub>C f) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
                              D.inv (\<Phi> (f, g)) =
                            F \<epsilon>"
             proof -
               have "unit (trg\<^sub>C f) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
                       D.inv (\<Phi> (f, g)) =
                     (unit (trg\<^sub>C f) \<cdot>\<^sub>D D.inv (unit (trg\<^sub>C f))) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D (\<Phi> (f, g) \<cdot>\<^sub>D D.inv (\<Phi> (f, g)))"
                 using D.comp_assoc by simp
               also have "... = F (trg\<^sub>C f) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D F (f \<star>\<^sub>C g)"
                 using 0 3 D.comp_arr_inv' D.comp_inv_arr'
                 by (simp add: C.VV.arr_char C.VV.ide_char assms(1-2))
               also have "... = F \<epsilon>"
                 using 0 \<open>\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>\<close> D.comp_arr_dom D.comp_cod_arr by auto
               finally show ?thesis by simp
             qed
             ultimately show ?thesis by simp
           qed
           thus ?thesis
             using assms reflects_iso by auto
         qed
       qed
     qed
 
     lemma reflects_equivalence_map:
     assumes "C.ide f" and "D.equivalence_map (F f)"
     shows "C.equivalence_map f"
     proof -
       obtain g' \<phi> \<psi> where E': "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) g' \<phi> \<psi>"
         using assms D.equivalence_map_def by auto
       interpret E': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> g' \<phi> \<psi>
         using E' by auto
       obtain g where g: "\<guillemotleft>g : trg\<^sub>C f \<rightarrow>\<^sub>C src\<^sub>C f\<guillemotright> \<and> C.ide g \<and> D.isomorphic (F g) g'"
         using assms E'.antipar locally_essentially_surjective [of "trg\<^sub>C f" "src\<^sub>C f" g']
         by auto
       obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : g' \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<mu>"
         using g D.isomorphic_def D.isomorphic_symmetric by blast
       interpret E'': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close>
                        \<open>(F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>\<close>
                        \<open>\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>)\<close>
         using assms \<mu> E'.equivalence_in_bicategory_axioms D.ide_is_iso
               D.equivalence_respects_iso [of "F f" g' \<phi> \<psi> "F f" "F f" \<mu> "F g"]
         by auto
       let ?\<eta>' = "\<Phi> (g, f) \<cdot>\<^sub>D (F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi> \<cdot>\<^sub>D D.inv (unit (src\<^sub>C f))"
       have \<eta>': "\<guillemotleft>?\<eta>' : F (src\<^sub>C f) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
         using assms \<mu> g unit_char  E'.unit_in_hom(2) E'.antipar E''.antipar cmp_in_hom
         apply (intro D.comp_in_homI)
             apply auto
         using E'.antipar(2) by blast
       have iso_\<eta>': "D.iso ?\<eta>'"
         using assms g \<mu> \<eta>' E'.antipar unit_char
         by (metis C.in_hhomE D.arrI D.inv_comp_left(2) D.inv_comp_right(2) D.iso_hcomp
                   D.iso_inv_iso D.isos_compose D.seqE E''.antipar(2) E''.unit_is_iso
                   E'.unit_is_iso as_nat_iso.components_are_iso cmp_components_are_iso)
       let ?\<epsilon>' = "unit (src\<^sub>C g) \<cdot>\<^sub>D \<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>) \<cdot>\<^sub>D
                  D.inv (\<Phi> (f, g))"
       have \<epsilon>': "\<guillemotleft>?\<epsilon>' : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
       proof (intro D.comp_in_homI)
         show "\<guillemotleft>D.inv (\<Phi> (f, g)) : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g\<guillemotright>"
           using assms g cmp_in_hom C.VV.ide_char C.VV.arr_char by auto
         show "\<guillemotleft>F f \<star>\<^sub>D D.inv \<mu> : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F f \<star>\<^sub>D g'\<guillemotright>"
           using assms g \<mu> E''.antipar D.ide_in_hom(2) by auto
         show "\<guillemotleft>D.inv (F f) \<star>\<^sub>D g' : F f \<star>\<^sub>D g' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D g'\<guillemotright>"
           using assms E'.antipar D.ide_is_iso by auto
         show "\<guillemotleft>\<psi> :  F f \<star>\<^sub>D g' \<Rightarrow>\<^sub>D trg\<^sub>D (F f)\<guillemotright>"
           using E'.counit_in_hom by simp
         show "\<guillemotleft>unit (src\<^sub>C g) : trg\<^sub>D (F f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
           using assms g unit_char by auto
       qed
       have iso_\<epsilon>': "D.iso ?\<epsilon>'"
       proof -
         have "D.iso (\<Phi> (f, g))"
           using assms g C.VV.ide_char C.VV.arr_char by auto
         thus ?thesis
           by (metis C.in_hhomE D.arrI D.hseq_char' D.ide_is_iso D.inv_comp_left(2)
               D.inv_comp_right(2) D.iso_hcomp D.iso_inv_iso D.isos_compose D.seqE
               D.seq_if_composable E''.counit_is_iso E'.counit_is_iso E'.ide_left
               \<epsilon>' \<mu> g unit_char(2))
       qed
       obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright> \<and> F \<eta> = ?\<eta>'"
         using assms g E'.antipar \<eta>' locally_full [of "src\<^sub>C f" "g \<star>\<^sub>C f" ?\<eta>']
         by (metis C.ide_hcomp C.ideD(1) C.in_hhomE C.src.preserves_ide C.hcomp_simps(1-2)
             C.src_trg C.trg_trg)
       have iso_\<eta>: "C.iso \<eta>"
         using \<eta> \<eta>' iso_\<eta>' reflects_iso by auto
       have 1: "\<exists>\<epsilon>. \<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> F \<epsilon> = ?\<epsilon>'"
         using assms g \<epsilon>' locally_full [of "f \<star>\<^sub>C g" "src\<^sub>C g" ?\<epsilon>'] by force
       obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> F \<epsilon> = ?\<epsilon>'"
         using 1 by blast
       have iso_\<epsilon>: "C.iso \<epsilon>"
         using \<epsilon> \<epsilon>' iso_\<epsilon>' reflects_iso by auto
       have "equivalence_in_bicategory (\<cdot>\<^sub>C) (\<star>\<^sub>C) \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
         using assms g \<eta> \<epsilon> iso_\<eta> iso_\<epsilon> by (unfold_locales, auto)
       thus ?thesis
         using C.equivalence_map_def by auto
     qed
 
     lemma reflects_equivalent_objects:
     assumes "C.obj a" and "C.obj b" and "D.equivalent_objects (map\<^sub>0 a) (map\<^sub>0 b)"
     shows "C.equivalent_objects a b"
     proof -
       obtain f' where f': "\<guillemotleft>f' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright> \<and> D.equivalence_map f'"
         using assms D.equivalent_objects_def D.equivalence_map_def by auto
       obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) f'"
         using assms f' locally_essentially_surjective [of a b f'] D.equivalence_map_is_ide
         by auto
       have "D.equivalence_map (F f)"
         using f f' D.equivalence_map_preserved_by_iso [of f' "F f"] D.isomorphic_symmetric
         by simp
       hence "C.equivalence_map f"
         using f f' reflects_equivalence_map [of f] by simp
       thus ?thesis
         using f C.equivalent_objects_def by auto
     qed
 
   end
 
   text\<open>
     For each pair of objects \<open>a\<close>, \<open>b\<close> of \<open>C\<close>, an equivalence pseudofunctor restricts
     to an equivalence of categories between \<open>C.hhom a b\<close> and \<open>D.hhom (map\<^sub>0 a) (map\<^sub>0 b)\<close>.
   \<close>
 
   (* TODO: Change the "perspective" of this locale to be the defined functor. *)
   locale equivalence_pseudofunctor_at_hom =
     equivalence_pseudofunctor +
   fixes a :: 'a and a' :: 'a
   assumes obj_a: "C.obj a"
   and obj_a': "C.obj a'"
   begin
 
     sublocale hhom\<^sub>C: subcategory V\<^sub>C \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : a \<rightarrow>\<^sub>C a'\<guillemotright>\<close>
       using C.hhom_is_subcategory by simp
     sublocale hhom\<^sub>D: subcategory V\<^sub>D \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a'\<guillemotright>\<close>
       using D.hhom_is_subcategory by simp
 
     definition F\<^sub>1
     where "F\<^sub>1 = (\<lambda>\<mu>. if hhom\<^sub>C.arr \<mu> then F \<mu> else D.null)"
 
     interpretation F\<^sub>1: "functor" hhom\<^sub>C.comp hhom\<^sub>D.comp F\<^sub>1
       unfolding F\<^sub>1_def
       using hhom\<^sub>C.arr_char hhom\<^sub>D.arr_char hhom\<^sub>C.dom_char hhom\<^sub>D.dom_char
             hhom\<^sub>C.cod_char hhom\<^sub>D.cod_char hhom\<^sub>C.seq_char hhom\<^sub>C.comp_char hhom\<^sub>D.comp_char
       by unfold_locales auto
 
     interpretation F\<^sub>1: fully_faithful_and_essentially_surjective_functor
                          hhom\<^sub>C.comp hhom\<^sub>D.comp F\<^sub>1
     proof
       show "\<And>\<mu> \<mu>'. \<lbrakk>hhom\<^sub>C.par \<mu> \<mu>'; F\<^sub>1 \<mu> = F\<^sub>1 \<mu>'\<rbrakk> \<Longrightarrow> \<mu> = \<mu>'"
         unfolding F\<^sub>1_def
         using is_faithful hhom\<^sub>C.dom_char hhom\<^sub>D.dom_char hhom\<^sub>C.cod_char hhom\<^sub>D.cod_char
         by (metis C.in_hhom_def hhom\<^sub>C.arrE)
       show "\<And>f f' \<nu>. \<lbrakk>hhom\<^sub>C.ide f; hhom\<^sub>C.ide f'; hhom\<^sub>D.in_hom \<nu> (F\<^sub>1 f') (F\<^sub>1 f)\<rbrakk>
                \<Longrightarrow> \<exists>\<mu>. hhom\<^sub>C.in_hom \<mu> f' f \<and> F\<^sub>1 \<mu> = \<nu>"
       proof (unfold F\<^sub>1_def)
         fix f f' \<nu>
         assume f: "hhom\<^sub>C.ide f" and f': "hhom\<^sub>C.ide f'"
         assume "hhom\<^sub>D.in_hom \<nu> (if hhom\<^sub>C.arr f' then F f' else D.null)
                               (if hhom\<^sub>C.arr f then F f else D.null)"
         hence \<nu>: "hhom\<^sub>D.in_hom \<nu> (F f') (F f)"
           using f f' by simp
         have "\<exists>\<mu>. hhom\<^sub>C.in_hom \<mu> f' f \<and> F \<mu> = \<nu>"
         proof -
           have 1: "src\<^sub>C f' = src\<^sub>C f \<and> trg\<^sub>C f' = trg\<^sub>C f"
             using f f' hhom\<^sub>C.ide_char by (metis C.in_hhomE hhom\<^sub>C.arrE)
           hence ex: "\<exists>\<mu>. C.in_hom \<mu> f' f \<and> F \<mu> = \<nu>"
             by (meson \<nu> f f' hhom\<^sub>D.in_hom_char horizontal_homs.hhom_is_subcategory
                       locally_full subcategory.ide_char weak_arrow_of_homs_axioms
                       weak_arrow_of_homs_def)
           obtain \<mu> where \<mu>: "C.in_hom \<mu> f' f \<and> F \<mu> = \<nu>"
             using ex by blast
           have "hhom\<^sub>C.in_hom \<mu> f' f"
             by (metis C.arrI C.in_hhom_def C.vconn_implies_hpar(1-2) \<mu> f f'
                 hhom\<^sub>C.arr_char hhom\<^sub>C.ide_char hhom\<^sub>C.in_hom_char)
           thus ?thesis
             using \<mu> by auto
         qed
         thus "\<exists>\<mu>. hhom\<^sub>C.in_hom \<mu> f' f \<and> (if hhom\<^sub>C.arr \<mu> then F \<mu> else D.null) = \<nu>"
           by auto
       qed
       show "\<And>g. hhom\<^sub>D.ide g \<Longrightarrow> \<exists>f. hhom\<^sub>C.ide f \<and> hhom\<^sub>D.isomorphic (F\<^sub>1 f) g"
       proof (unfold F\<^sub>1_def)
         fix g
         assume g: "hhom\<^sub>D.ide g"
         show "\<exists>f. hhom\<^sub>C.ide f \<and> hhom\<^sub>D.isomorphic (if hhom\<^sub>C.arr f then F f else D.null) g"
         proof -
           have "C.obj a \<and> C.obj a'"
             using obj_a obj_a' by simp
           moreover have 1: "D.ide g \<and> \<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a'\<guillemotright>"
             using g obj_a obj_a' hhom\<^sub>D.ide_char by auto
           ultimately have 2: "\<exists>f. C.in_hhom f a a' \<and> C.ide f \<and> D.isomorphic (F f) g"
             using locally_essentially_surjective [of a a' g] by simp
           obtain f \<phi> where f: "C.in_hhom f a a' \<and> C.ide f \<and> D.in_hom \<phi> (F f) g \<and> D.iso \<phi>"
             using 2 by auto
           have "hhom\<^sub>C.ide f"
             using f hhom\<^sub>C.ide_char hhom\<^sub>C.arr_char by simp
           moreover have "hhom\<^sub>D.isomorphic (F f) g"
           proof -
             have "hhom\<^sub>D.arr \<phi> \<and> hhom\<^sub>D.arr (D.inv \<phi>)"
               by (metis 1 D.arrI D.in_hhom_def D.vconn_implies_hpar(1-4) D.inv_in_homI
                         f hhom\<^sub>D.arrI)
             hence "hhom\<^sub>D.in_hom \<phi> (F f) g \<and> hhom\<^sub>D.iso \<phi>"
               by (metis D.in_homE f hhom\<^sub>D.cod_simp hhom\<^sub>D.dom_simp hhom\<^sub>D.in_homI hhom\<^sub>D.iso_char)
             thus ?thesis
               unfolding hhom\<^sub>D.isomorphic_def by blast
           qed
           ultimately show "\<exists>f. hhom\<^sub>C.ide f \<and>
                                hhom\<^sub>D.isomorphic (if hhom\<^sub>C.arr f then F f else D.null) g"
             by force
         qed
       qed
     qed
 
     lemma equivalence_functor_F\<^sub>1:
     shows "fully_faithful_and_essentially_surjective_functor hhom\<^sub>C.comp hhom\<^sub>D.comp F\<^sub>1"
     and "equivalence_functor hhom\<^sub>C.comp hhom\<^sub>D.comp F\<^sub>1"
       ..
 
     definition G\<^sub>1
     where "G\<^sub>1 = (SOME G. \<exists>\<eta>\<epsilon>.
                  adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G F\<^sub>1 (fst \<eta>\<epsilon>) (snd \<eta>\<epsilon>))"
 
     lemma G\<^sub>1_props:
     assumes "C.obj a" and "C.obj a'"
     shows "\<exists>\<eta> \<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>"
     proof -
       have "\<exists>G. \<exists>\<eta>\<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G F\<^sub>1 (fst \<eta>\<epsilon>) (snd \<eta>\<epsilon>)"
         using F\<^sub>1.extends_to_adjoint_equivalence by simp
       hence "\<exists>\<eta>\<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 (fst \<eta>\<epsilon>) (snd \<eta>\<epsilon>)"
         unfolding G\<^sub>1_def
         using someI_ex
                 [of "\<lambda>G. \<exists>\<eta>\<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G F\<^sub>1 (fst \<eta>\<epsilon>) (snd \<eta>\<epsilon>)"]
         by blast
       thus ?thesis by simp
     qed
 
     definition \<eta>
     where "\<eta> = (SOME \<eta>. \<exists>\<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>)"
 
     definition \<epsilon>
     where "\<epsilon> = (SOME \<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>)"
 
     lemma \<eta>\<epsilon>_props:
     shows "adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>"
       using obj_a obj_a' \<eta>_def \<epsilon>_def G\<^sub>1_props
             someI_ex [of "\<lambda>\<eta>. \<exists>\<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>"]
             someI_ex [of "\<lambda>\<epsilon>. adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>"]
       by simp
 
     sublocale \<eta>\<epsilon>: adjoint_equivalence hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta> \<epsilon>
       using \<eta>\<epsilon>_props by simp
 
     sublocale \<eta>\<epsilon>: meta_adjunction hhom\<^sub>C.comp hhom\<^sub>D.comp G\<^sub>1 F\<^sub>1 \<eta>\<epsilon>.\<phi> \<eta>\<epsilon>.\<psi>
       using \<eta>\<epsilon>.induces_meta_adjunction by simp
 
   end
 
   context identity_pseudofunctor
   begin
 
     sublocale equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
                 map cmp
       using B.isomorphic_reflexive B.arrI
       apply unfold_locales
       by (auto simp add: B.equivalent_objects_reflexive map\<^sub>0_def B.obj_simps)
 
      lemma is_equivalence_pseudofunctor:
      shows "equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
               map cmp"
        ..
 
   end
 
   locale composite_equivalence_pseudofunctor =
     composite_pseudofunctor +
     F: equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C F \<Phi>\<^sub>F +
     G: 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 G \<Phi>\<^sub>G
   begin
 
     interpretation faithful_functor V\<^sub>B V\<^sub>D \<open>G o F\<close>
       using F.faithful_functor_axioms G.faithful_functor_axioms faithful_functors_compose
       by blast
 
     interpretation equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
                      \<open>G o F\<close> cmp
     proof
       show "\<And>c. D.obj c \<Longrightarrow> \<exists>a. B.obj a \<and> D.equivalent_objects (map\<^sub>0 a) c"
       proof -
         fix c
         assume c: "D.obj c"
         obtain b where b: "C.obj b \<and> D.equivalent_objects (G.map\<^sub>0 b) c"
           using c G.biessentially_surjective_on_objects by auto
         obtain a where a: "B.obj a \<and> C.equivalent_objects (F.map\<^sub>0 a) b"
           using b F.biessentially_surjective_on_objects by auto
         have "D.equivalent_objects (map\<^sub>0 a) c"
           using a b map\<^sub>0_def G.preserves_equivalent_objects D.equivalent_objects_transitive
           by fastforce
         thus "\<exists>a. B.obj a \<and> D.equivalent_objects (map\<^sub>0 a) c"
           using a by auto
       qed
       show "\<And>a a' h. \<lbrakk>B.obj a; B.obj a'; \<guillemotleft>h : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a'\<guillemotright>; D.ide h\<rbrakk>
                  \<Longrightarrow> \<exists>f. B.in_hhom f a a' \<and> B.ide f \<and> D.isomorphic ((G \<circ> F) f) h"
       proof -
         fix a a' h
         assume a: "B.obj a" and a': "B.obj a'"
         and h_in_hom: "\<guillemotleft>h : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a'\<guillemotright>" and ide_h: "D.ide h"
         obtain g
           where g: "C.in_hhom g (F.map\<^sub>0 a) (F.map\<^sub>0 a') \<and> C.ide g \<and> D.isomorphic (G g) h"
           using a a' h_in_hom ide_h map\<^sub>0_def B.obj_simps
                 G.locally_essentially_surjective [of "F.map\<^sub>0 a" "F.map\<^sub>0 a'" h]
           by auto
         obtain f where f: "B.in_hhom f a a' \<and> B.ide f \<and> C.isomorphic (F f) g"
           using a a' g F.locally_essentially_surjective by blast
         have "D.isomorphic ((G o F) f) h"
           by (metis D.isomorphic_transitive G.preserves_isomorphic comp_apply f g)
         thus "\<exists>f. B.in_hhom f a a' \<and> B.ide f \<and> D.isomorphic ((G \<circ> F) f) h"
           using f by auto
       qed
       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> : (G \<circ> F) f \<Rightarrow>\<^sub>D (G \<circ> F) f'\<guillemotright>\<rbrakk>
                  \<Longrightarrow> \<exists>\<tau>. \<guillemotleft>\<tau> : f \<rightarrow>\<^sub>B f'\<guillemotright> \<and> (G \<circ> F) \<tau> = \<nu>"
       proof -
         fix f f' \<nu>
         assume f: "B.ide f" and f': "B.ide f'"
         and src: "src\<^sub>B f = src\<^sub>B f'" and trg: "trg\<^sub>B f = trg\<^sub>B f'"
         and \<nu>: "\<guillemotleft>\<nu> : (G \<circ> F) f \<Rightarrow>\<^sub>D (G \<circ> F) f'\<guillemotright>"
         have \<nu>: "\<guillemotleft>\<nu> : G (F f) \<Rightarrow>\<^sub>D G (F f')\<guillemotright>"
           using \<nu> by simp
         have 1: "src\<^sub>C (F f) = src\<^sub>C (F f') \<and> trg\<^sub>C (F f) = trg\<^sub>C (F f')"
           using f f' src trg by simp
         have 2: "\<exists>\<mu>. \<guillemotleft>\<mu> : F f \<Rightarrow>\<^sub>C F f'\<guillemotright> \<and> G \<mu> = \<nu>"
           using f f' 1 \<nu> G.locally_full F.preserves_ide by simp
         obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : F f \<Rightarrow>\<^sub>C F f'\<guillemotright> \<and> G \<mu> = \<nu>"
           using 2 by auto
         obtain \<tau> where \<tau>: "\<guillemotleft>\<tau> : f \<rightarrow>\<^sub>B f'\<guillemotright> \<and> F \<tau> = \<mu>"
           using f f' src trg 2 \<mu> F.locally_full by blast
         show "\<exists>\<tau>. \<guillemotleft>\<tau> : f \<rightarrow>\<^sub>B f'\<guillemotright> \<and> (G \<circ> F) \<tau> = \<nu>"
           using \<mu> \<tau> by auto
       qed
     qed
 
     sublocale equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
                 \<open>G o F\<close> cmp ..
 
     lemma is_equivalence_pseudofunctor:
     shows "equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
                 (G o F) cmp"
       ..
 
   end
 
 end
diff --git a/thys/Bicategory/SpanBicategory.thy b/thys/Bicategory/SpanBicategory.thy
--- a/thys/Bicategory/SpanBicategory.thy
+++ b/thys/Bicategory/SpanBicategory.thy
@@ -1,5485 +1,4479 @@
 (*  Title:       SpanBicategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Span Bicategories"
 
 text \<open>
   In this section we construct the bicategory \<open>Span(C)\<close>, where \<open>C\<close> is a category with pullbacks.
   The $0$-cells of \<open>Span(C)\<close> are the objects of \<open>C\<close>, the $1$-cells of \<open>Span(C)\<close> are pairs
   \<open>(f\<^sub>0, f\<^sub>1)\<close> of arrows of \<open>C\<close> having a common domain, and the $2$-cells of \<open>Span(C)\<close>
   are ``arrows of spans''.  An arrow of spans from \<open>(f\<^sub>0, f\<^sub>1)\<close> to \<open>(g\<^sub>0, g\<^sub>1)\<close> is
   an arrow \<open>\<guillemotleft>u: dom f\<^sub>0 \<rightarrow> dom g\<^sub>0\<guillemotright>\<close> of \<open>C\<close>, such that \<open>g\<^sub>0 \<cdot> u = f\<^sub>0\<close> and \<open>g\<^sub>1 \<cdot> u = f\<^sub>1\<close>.
 
   In the present development, a \emph{span} is formalized as a structure \<open>\<lparr>Leg0 = f\<^sub>0, Leg1 = f\<^sub>1\<rparr>\<close>,
   where \<open>f\<^sub>0\<close> and \<open>f\<^sub>1\<close> are arrows of \<open>C\<close> with a common domain, which we call the \emph{apex} of
   the span.
   An \emph{arrow of spans}  is formalized as a structure \<open>\<lparr>Chn = u, Dom = S, Cod = T\<rparr>\<close>,
   where \<open>S\<close> and \<open>T\<close> are spans, and \<open>\<guillemotleft>u : S.apex \<rightarrow> T.apex\<guillemotright>\<close> satisfies \<open>Leg0 T \<cdot> u = Leg0 S\<close>
   and \<open>Leg1 T \<cdot> u = Leg1 S\<close>.  We refer to the arrow \<open>u\<close> as the \emph{chine} of the arrow of spans.
 
   Arrows of spans inherit a composition from that of \<open>C\<close>; this is ``vertical composition''.
   Spans may be composed via pullback in \<open>C\<close>; this ``horizontal composition'' extends to
   arrows of spans, so that it is functorial with respect to vertical composition.
   These two compositions determine a bicategory, as we shall show.
 \<close>
 
 theory SpanBicategory
 imports Bicategory InternalAdjunction Category3.FreeCategory Category3.CategoryWithPullbacks
 begin
 
 subsection "Spans"
 
   record 'a span_data =
     Leg0 :: 'a
     Leg1 :: 'a
 
   locale span_in_category =
     C: category +
   fixes S :: "'a span_data" (structure)
   assumes is_span: "C.span (Leg0 S) (Leg1 S)"
   begin
 
     abbreviation leg0
     where "leg0 \<equiv> Leg0 S"
 
     abbreviation leg1
     where "leg1 \<equiv> Leg1 S"
 
     abbreviation src
     where "src \<equiv> C.cod leg0"
 
     abbreviation trg
     where "trg \<equiv> C.cod leg1"
 
     definition apex
     where "apex \<equiv> C.dom leg0"
 
     lemma ide_apex [simp]:
     shows "C.ide apex"
       using is_span apex_def by simp
 
     lemma leg_in_hom [intro]:
     shows "\<guillemotleft>leg0 : apex \<rightarrow> src\<guillemotright>"
     and "\<guillemotleft>leg1 : apex \<rightarrow> trg\<guillemotright>"
       using is_span apex_def by auto
 
     lemma leg_simps [simp]:
     shows "C.arr leg0" and "C.dom leg0 = apex"
     and "C.arr leg1" and "C.dom leg1 = apex"
       using leg_in_hom by auto
 
   end
 
   record 'a arrow_of_spans_data =
     Chn :: 'a
     Dom :: "'a span_data"
     Cod :: "'a span_data"
 
   locale arrow_of_spans =
     C: category C +
     dom: span_in_category C \<open>Dom \<mu>\<close> +
     cod: span_in_category C \<open>Cod \<mu>\<close>
   for C :: "'a comp"  (infixr "\<cdot>" 55)
   and \<mu> :: "'a arrow_of_spans_data" (structure) +
   assumes chine_in_hom [intro]: "\<guillemotleft>Chn \<mu> : dom.apex \<rightarrow> cod.apex\<guillemotright>"
   and leg0_commutes [simp]: "cod.leg0 \<cdot> Chn \<mu> = dom.leg0"
   and leg1_commutes [simp]: "cod.leg1 \<cdot> (Chn \<mu>) = dom.leg1"
   begin
 
     abbreviation chine
     where "chine \<equiv> Chn \<mu>"
 
     lemma chine_simps [simp]:
     shows "C.arr chine" and "C.dom chine = dom.apex" and "C.cod chine = cod.apex"
       using chine_in_hom by auto
 
     lemma cod_src_eq_dom_src [simp]:
     shows "cod.src = dom.src"
       using dom.is_span cod.is_span
       by (metis C.cod_comp leg0_commutes)
 
     lemma cod_trg_eq_dom_trg [simp]:
     shows "cod.trg = dom.trg"
       using dom.is_span cod.is_span
       by (metis C.cod_comp leg1_commutes)
 
     abbreviation dsrc
     where "dsrc \<equiv> dom.src"
 
     abbreviation dtrg
     where "dtrg \<equiv> dom.trg"
 
   end
 
   locale identity_arrow_of_spans =
     arrow_of_spans +
   assumes chine_is_identity [simp]: "C.ide (Chn \<mu>)"
   begin
 
     abbreviation apex
     where "apex \<equiv> dom.apex"
 
     abbreviation leg0
     where "leg0 \<equiv> dom.leg0"
 
     abbreviation leg1
     where "leg1 \<equiv> dom.leg1"
 
     lemma chine_eq_apex [simp]:
     shows "chine = apex"
       using chine_is_identity C.ideD(2) chine_simps(2) by presburger
 
     lemma cod_simps [simp]:
     shows "cod.apex = apex" and "cod.leg0 = leg0" and "cod.leg1 = leg1"
       using chine_is_identity chine_simps(3) C.comp_arr_ide leg0_commutes leg1_commutes
       by force+
 
   end
 
   subsection "The Vertical Category of Spans"
 
   text \<open>
     The following locale constructs the category of spans and arrows of spans in
     an underlying category C, which is not yet assumed to have pullbacks.
     The composition is vertical composition of arrows of spans, to which we will
     later add horizontal composition to obtain a bicategory.
   \<close>
 
   locale span_vertical_category =
     C: category
   begin
 
     abbreviation Null
     where "Null \<equiv> \<lparr>Chn = C.null,
                    Dom = \<lparr>Leg0 = C.null, Leg1 = C.null\<rparr>,
                    Cod = \<lparr>Leg0 = C.null, Leg1 = C.null\<rparr>\<rparr>"
 
     lemma not_arr_Null:
     shows "\<not> arrow_of_spans C Null"
       unfolding arrow_of_spans_def arrow_of_spans_axioms_def
       by auto
 
     text \<open>
       Arrows of spans are composed simply by composing their chines.
     \<close>
 
     definition vcomp
     where "vcomp \<nu> \<mu> \<equiv> if arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>
                        then \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
                        else Null"
 
     notation vcomp        (infixr "\<bullet>" 55)
 
     (*
      * TODO: The reason why the this and the subsequent category interpretation are declared
      * as V: is that subsequently proved facts with the same names as the partial_magma and
      * category locales silently override the latter, resulting in problems proving things.
      * The presence of the extra "V" is only an issue up until a later sublocale declaration
      * inherits everything from horizontal_homs.  I wish I could say that I completely
      * understood the inheritance and overriding rules for locales.
      *)
     interpretation V: partial_magma vcomp
       using not_arr_Null vcomp_def
       apply unfold_locales
       by (metis (no_types, opaque_lifting))
 
     lemma is_partial_magma:
     shows "partial_magma vcomp"
       ..
 
     lemma null_char:
     shows "V.null = Null"
       using V.null_def vcomp_def not_arr_Null
       by (metis (no_types, lifting) V.comp_null(2))
 
     text \<open>
       Identities are arrows of spans whose chines are identities of C.
     \<close>
 
     lemma ide_char:
     shows "V.ide \<mu> \<longleftrightarrow> arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
     proof
       show "V.ide \<mu> \<Longrightarrow> arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
       proof
         assume 0: "V.ide \<mu>"
         have 1: "vcomp \<mu> \<mu> \<noteq> Null \<and> (\<forall>\<nu>. (\<nu> \<bullet> \<mu> \<noteq> Null \<longrightarrow> \<nu> \<bullet> \<mu> = \<nu>) \<and>
                                           (\<mu> \<bullet> \<nu> \<noteq> Null \<longrightarrow> \<mu> \<bullet> \<nu> = \<nu>))"
           using 0 V.ide_def null_char by simp
         show \<mu>: "arrow_of_spans C \<mu>"
           using 1 vcomp_def by metis
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu> by auto
         show "C.ide (Chn \<mu>)"
         proof -
           have "\<mu>.chine \<cdot> \<mu>.chine \<noteq> C.null"
             using 1 vcomp_def
             by (metis C.in_homE C.not_arr_null C.seqI \<mu>.chine_in_hom)
           moreover have "\<And>f. f \<cdot> Chn \<mu> \<noteq> C.null \<Longrightarrow> f \<cdot> Chn \<mu> = f"
           proof -
             fix f
             assume "f \<cdot> \<mu>.chine \<noteq> C.null"
             hence f: "\<guillemotleft>f : \<mu>.cod.apex \<rightarrow> C.cod f\<guillemotright>"
               using C.ext C.in_homI by force
             let ?cod_\<mu> = "\<lparr>Chn = C.cod \<mu>.chine, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
             interpret cod_\<mu>: arrow_of_spans C ?cod_\<mu>
               using C.ide_in_hom \<mu>.cod.ide_apex \<mu>.chine_in_hom C.comp_arr_dom
               by (unfold_locales, auto)
             have "?cod_\<mu> \<bullet> \<mu> = ?cod_\<mu>"
-            proof -
-              have "?cod_\<mu> \<bullet> \<mu> \<noteq> Null"
-                unfolding vcomp_def
-                using \<mu> cod_\<mu>.arrow_of_spans_axioms \<mu>.cod.is_span C.comp_cod_arr
-                apply simp
-                using \<mu>.chine_simps(1) by force
-              thus ?thesis
-                using 1 by simp
-            qed
+              by (metis (no_types, opaque_lifting) "1" C.not_arr_null
+                  \<mu>.cod.span_in_category_axioms arrow_of_spans_data.select_convs(2)
+                  cod_\<mu>.arrow_of_spans_axioms span_data.select_convs(1)
+                  span_in_category.leg_simps(1) vcomp_def)
             thus "f \<cdot> \<mu>.chine = f"
-              unfolding vcomp_def
-              using f C.comp_arr_ide C.comp_cod_arr \<mu>.arrow_of_spans_axioms
-                    cod_\<mu>.arrow_of_spans_axioms
+              using C.comp_arr_ide C.comp_cod_arr \<mu> cod_\<mu>.arrow_of_spans_axioms f vcomp_def
               by auto
           qed
           moreover have "\<And>f. \<mu>.chine \<cdot> f \<noteq> C.null \<Longrightarrow> \<mu>.chine \<cdot> f = f"
-          proof -
-            fix f
-            assume "\<mu>.chine \<cdot> f \<noteq> C.null"
-            hence f: "\<guillemotleft>f : C.dom f \<rightarrow> \<mu>.dom.apex\<guillemotright>"
-              using C.ext C.in_homI by force
-            let ?dom_\<mu> = "\<lparr>Chn = C.cod f, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
-            interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
-              using f C.ide_in_hom \<mu>.dom.ide_apex \<mu>.chine_in_hom C.comp_arr_dom
-              by (unfold_locales, auto)
-            have "\<mu> \<bullet> ?dom_\<mu> = ?dom_\<mu>"
-            proof -
-              have "\<mu> \<bullet> ?dom_\<mu> \<noteq> Null"
-                unfolding vcomp_def
-                using \<mu> dom_\<mu>.arrow_of_spans_axioms \<mu>.cod.is_span by (simp, force)
-              thus ?thesis
-                using 1 by simp
-            qed
-            hence "\<mu>.chine \<cdot> C.cod f = C.cod f"
-              unfolding vcomp_def
-              using \<mu> dom_\<mu>.arrow_of_spans_axioms f 0 C.comp_ide_arr C.comp_arr_ide
-              by simp
-            thus "\<mu>.chine \<cdot> f = f"
-              unfolding vcomp_def
-              using f C.comp_ide_arr C.comp_arr_dom \<mu>.arrow_of_spans_axioms
-                    dom_\<mu>.arrow_of_spans_axioms
-              by auto
-          qed
+            by (metis C.comp_cod_arr C.comp_ide_arr C.ext C.ide_char' calculation(1-2))
           ultimately show "C.ide \<mu>.chine"
             unfolding C.ide_def by simp
         qed
       qed
       show "arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>) \<Longrightarrow> V.ide \<mu>"
       proof -
         assume \<mu>: "arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu> by auto
         have 1: "Dom \<mu> = Cod \<mu>"
-        proof -
-          have "\<mu>.dom.leg0 = \<mu>.cod.leg0 \<and> \<mu>.dom.leg1 = \<mu>.cod.leg1"
-            using \<mu> C.comp_arr_ide \<mu>.cod.is_span by force
-          thus ?thesis by simp
-        qed
+          using \<mu> identity_arrow_of_spans.cod_simps(2) identity_arrow_of_spans.cod_simps(3)
+                identity_arrow_of_spans.intro identity_arrow_of_spans_axioms.intro
+          by fastforce
         show "V.ide \<mu>"
         proof -
           have "\<mu> \<bullet> \<mu> \<noteq> V.null"
             using \<mu> 1 vcomp_def by (simp add: C.ide_def null_char)
           moreover have "\<And>\<nu>. vcomp \<nu> \<mu> \<noteq> V.null \<Longrightarrow> vcomp \<nu> \<mu> = \<nu>"
           proof -
             fix \<nu> :: "'a arrow_of_spans_data"
             assume \<nu>: "\<nu> \<bullet> \<mu> \<noteq> V.null"
             have 2: "arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
               using \<nu> 1 vcomp_def by (metis V.comp_null(2))
             interpret \<nu>: arrow_of_spans C \<nu>
               using 2 by auto
             show "\<nu> \<bullet> \<mu> = \<nu>"
               unfolding vcomp_def
               using \<mu> 1 2 C.comp_arr_ide by simp
           qed
           moreover have "\<And>\<nu>. \<mu> \<bullet> \<nu> \<noteq> V.null \<Longrightarrow> \<mu> \<bullet> \<nu> = \<nu>"
           proof -
             fix \<nu> :: "'a arrow_of_spans_data"
             assume \<nu>: "\<mu> \<bullet> \<nu> \<noteq> V.null"
             have 2: "arrow_of_spans C \<nu> \<and> Dom \<mu> = Cod \<nu>"
               using \<nu> 1 vcomp_def by (metis V.comp_null(1))
             interpret \<nu>: arrow_of_spans C \<nu>
               using 2 by auto
             show "\<mu> \<bullet> \<nu> = \<nu>"
               unfolding vcomp_def
               using \<mu> 1 2 C.comp_ide_arr by simp
           qed
           ultimately show ?thesis
             unfolding V.ide_def by blast
         qed
       qed
     qed
 
     lemma has_domain_char:
     shows "V.domains \<mu> \<noteq> {} \<longleftrightarrow> arrow_of_spans C \<mu>"
     proof
       show "V.domains \<mu> \<noteq> {} \<Longrightarrow> arrow_of_spans C \<mu>"
         using V.domains_def null_char vcomp_def by fastforce
       show "arrow_of_spans C \<mu> \<Longrightarrow> V.domains \<mu> \<noteq> {}"
       proof -
         assume \<mu>: "arrow_of_spans C \<mu>"
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu> by auto
         let ?dom_\<mu> = "\<lparr>Chn = \<mu>.dom.apex, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
         interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
           using C.comp_arr_dom by (unfold_locales, auto)
         have "?dom_\<mu> \<in> V.domains \<mu>"
         proof -
           have "V.ide ?dom_\<mu>"
             using ide_char dom_\<mu>.arrow_of_spans_axioms by simp
           moreover have "\<mu> \<bullet> ?dom_\<mu> \<noteq> V.null"
             using \<mu> vcomp_def \<mu>.cod.span_in_category_axioms dom_\<mu>.arrow_of_spans_axioms
                   null_char span_in_category.leg_simps(1)
             by fastforce
           ultimately show ?thesis
             unfolding V.domains_def by blast
         qed
         thus "V.domains \<mu> \<noteq> {}" by blast
       qed
     qed
 
     lemma has_codomain_char:
     shows "V.codomains \<mu> \<noteq> {} \<longleftrightarrow> arrow_of_spans C \<mu>"
     proof
       show "V.codomains \<mu> \<noteq> {} \<Longrightarrow> arrow_of_spans C \<mu>"
         using V.codomains_def null_char vcomp_def by fastforce
       show "arrow_of_spans C \<mu> \<Longrightarrow> V.codomains \<mu> \<noteq> {}"
       proof -
         assume \<mu>: "arrow_of_spans C \<mu>"
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu> by auto
         let ?cod_f = "\<lparr>Chn = \<mu>.cod.apex, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
         interpret cod_f: arrow_of_spans C ?cod_f
           using C.comp_arr_dom by (unfold_locales, auto)
         have "?cod_f \<in> V.codomains \<mu>"
         proof -
           have "V.ide ?cod_f"
             using ide_char cod_f.arrow_of_spans_axioms by simp
           moreover have "?cod_f \<bullet> \<mu> \<noteq> V.null"
             using \<mu> vcomp_def \<mu>.cod.span_in_category_axioms cod_f.arrow_of_spans_axioms
                   null_char span_in_category.leg_simps(1)
             by fastforce
           ultimately show ?thesis
             unfolding V.codomains_def by blast
         qed
         thus "V.codomains \<mu> \<noteq> {}" by blast
       qed
     qed
 
     lemma arr_char:
     shows "V.arr \<mu> \<longleftrightarrow> arrow_of_spans C \<mu>"
       unfolding V.arr_def
       using has_domain_char has_codomain_char by simp
 
     lemma seq_char:
     shows "V.seq \<nu> \<mu> \<longleftrightarrow> arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
     proof
       show "V.seq \<nu> \<mu> \<Longrightarrow> arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
         using vcomp_def by (metis V.not_arr_null null_char)
       show "arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu> \<Longrightarrow> V.seq \<nu> \<mu>"
       proof -
         assume 1: "arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
         interpret \<mu>: arrow_of_spans C \<mu>
           using 1 by auto
         interpret \<nu>: arrow_of_spans C \<nu>
           using 1 by auto
         show "V.seq \<nu> \<mu>"
         proof -
           let ?\<nu>\<mu> = "\<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>"
           have "\<nu> \<bullet> \<mu> = ?\<nu>\<mu>"
             using 1 vcomp_def by metis
           moreover have "V.arr ?\<nu>\<mu>"
           proof -
             interpret Dom: span_in_category C \<open>Dom ?\<nu>\<mu>\<close>
               by (simp add: \<mu>.dom.span_in_category_axioms)
             interpret Cod: span_in_category C \<open>Cod ?\<nu>\<mu>\<close>
               by (simp add: \<nu>.cod.span_in_category_axioms)
             have "arrow_of_spans C ?\<nu>\<mu>"
               using 1 \<mu>.chine_in_hom \<nu>.chine_in_hom C.comp_reduce
               by (unfold_locales, cases ?\<nu>\<mu>, auto)
             thus ?thesis
               using arr_char by blast
           qed
           ultimately show ?thesis by simp
         qed
       qed
     qed
 
     interpretation V: category vcomp
     proof
       show "\<And>\<mu>. (V.domains \<mu> \<noteq> {}) = (V.codomains \<mu> \<noteq> {})"
         using has_domain_char has_codomain_char by simp
       show "\<And>\<nu> \<mu>. \<nu> \<bullet> \<mu> \<noteq> V.null \<Longrightarrow> V.seq \<nu> \<mu>"
         using seq_char vcomp_def null_char by metis
       show "\<And>\<pi> \<nu> \<mu>. V.seq \<pi> \<nu> \<Longrightarrow> V.seq (\<pi> \<bullet> \<nu>) \<mu> \<Longrightarrow> V.seq \<nu> \<mu>"
         using seq_char vcomp_def by (metis arrow_of_spans_data.select_convs(2))
       show "\<And>\<pi> \<nu> \<mu>. V.seq \<pi> (\<nu> \<bullet> \<mu>) \<Longrightarrow> V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu>"
         using seq_char vcomp_def by (metis arrow_of_spans_data.select_convs(3))
       show "\<And>\<nu> \<mu> \<pi>. V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu> \<Longrightarrow> V.seq (\<pi> \<bullet> \<nu>) \<mu>"
         using seq_char vcomp_def by (metis arr_char arrow_of_spans_data.select_convs(2))
       show "\<And>\<nu> \<mu> \<pi>. V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu> \<Longrightarrow> (\<pi> \<bullet> \<nu>) \<bullet> \<mu> = \<pi> \<bullet> \<nu> \<bullet> \<mu>"
       proof -
         fix \<mu> \<nu> \<pi>
         assume \<mu>\<nu>: "V.seq \<nu> \<mu>" and \<nu>\<pi>: "V.seq \<pi> \<nu>"
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu>\<nu> seq_char by auto
         interpret \<nu>: arrow_of_spans C \<nu>
           using \<mu>\<nu> seq_char by auto
         interpret \<pi>: arrow_of_spans C \<pi>
           using \<nu>\<pi> seq_char by auto
         show "(\<pi> \<bullet> \<nu>) \<bullet> \<mu> = \<pi> \<bullet> \<nu> \<bullet> \<mu>"
           unfolding vcomp_def
           using \<mu>\<nu> \<nu>\<pi> seq_char \<mu>.chine_in_hom \<nu>.chine_in_hom \<pi>.chine_in_hom
           by (simp add: C.comp_assoc, metis arr_char vcomp_def)
       qed
     qed
 
     lemma is_category:
     shows "category vcomp"
       ..
 
     lemma dom_char:
     shows "V.dom = (\<lambda>\<mu>. if V.arr \<mu> then
                           \<lparr>Chn = span_in_category.apex C (Dom \<mu>), Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>
                         else V.null)"
     proof
       fix \<mu>
       have "\<not> V.arr \<mu> \<Longrightarrow> V.dom \<mu> = V.null"
         by (simp add: V.arr_def V.dom_def)
       moreover have "V.arr \<mu> \<Longrightarrow> V.dom \<mu> = \<lparr>Chn = span_in_category.apex C (Dom \<mu>),
                                             Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
-      proof (intro V.dom_eqI)
-        assume \<mu>: "V.arr \<mu>"
-        interpret \<mu>: arrow_of_spans C \<mu>
-          using \<mu> arr_char by auto
-        let ?dom_\<mu> = "\<lparr>Chn = \<mu>.dom.apex, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
-        interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
-          using C.comp_arr_dom by (unfold_locales, auto)
-        show "V.ide ?dom_\<mu>"
-          using ide_char dom_\<mu>.arrow_of_spans_axioms by simp
-        thus "V.seq \<mu> ?dom_\<mu>"
-          using seq_char ide_char \<mu>.arrow_of_spans_axioms by simp
-      qed
+        by (metis V.comp_arr_dom V.comp_ide_self V.ideD(1) V.ide_dom arrow_of_spans_data.cases
+            arrow_of_spans_data.select_convs(1-3) ide_char identity_arrow_of_spans.chine_eq_apex
+            identity_arrow_of_spans_axioms.intro identity_arrow_of_spans_def seq_char)
       ultimately show "V.dom \<mu> = (if V.arr \<mu> then
                                      \<lparr>Chn = span_in_category.apex C (Dom \<mu>),
                                       Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>
                                   else V.null)"
         by argo
     qed
 
     lemma cod_char:
     shows "V.cod = (\<lambda>\<mu>. if V.arr \<mu> then
                           \<lparr>Chn = span_in_category.apex C (Cod \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>
                         else V.null)"
     proof
       fix \<mu>
       have "\<not> V.arr \<mu> \<Longrightarrow> V.cod \<mu> = V.null"
         by (simp add: V.arr_def V.cod_def)
       moreover have "V.arr \<mu> \<Longrightarrow> V.cod \<mu> = \<lparr>Chn = span_in_category.apex C (Cod \<mu>),
                                             Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
-      proof (intro V.cod_eqI)
-        assume \<mu>: "V.arr \<mu>"
-        interpret \<mu>: arrow_of_spans C \<mu>
-          using \<mu> arr_char by auto
-        let ?cod_\<mu> = "\<lparr>Chn = \<mu>.cod.apex, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
-        interpret cod_\<mu>: arrow_of_spans C ?cod_\<mu>
-          using C.comp_arr_dom by (unfold_locales, auto)
-       show "V.ide ?cod_\<mu>"
-          using ide_char cod_\<mu>.arrow_of_spans_axioms by simp
-        thus "V.seq ?cod_\<mu> \<mu>"
-          using seq_char ide_char \<mu>.arrow_of_spans_axioms by simp
-      qed
+        by (metis V.arr_cod V.comp_cod_arr V.dom_cod dom_char span_vertical_category.seq_char
+                  span_vertical_category_axioms)
       ultimately show "V.cod \<mu> = (if V.arr \<mu> then
                                     \<lparr>Chn = span_in_category.apex C (Cod \<mu>),
                                      Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>
                                   else V.null)"
         by argo
     qed
 
     lemma vcomp_char:
     shows "vcomp = (\<lambda>\<nu> \<mu>. if V.seq \<nu> \<mu> then
                              \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
                            else V.null)"
-    proof -
-      have "\<And>\<mu> \<nu>. \<nu> \<bullet> \<mu> = (if V.seq \<nu> \<mu> then
-                             \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
-                           else V.null)"
-        using vcomp_def seq_char null_char by simp
-      thus ?thesis by auto
-    qed
+      by (meson V.ext seq_char vcomp_def)
 
     lemma vcomp_eq:
     assumes "V.seq \<nu> \<mu>"
     shows "\<nu> \<bullet> \<mu> = \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>"
       using assms vcomp_char by meson
 
     lemma Chn_vcomp:
     assumes "V.seq \<nu> \<mu>"
     shows "Chn (\<nu> \<bullet> \<mu>) = Chn \<nu> \<cdot> Chn \<mu>"
       using assms vcomp_eq [of \<nu> \<mu>] by simp
 
     lemma ide_char':
     shows "V.ide \<mu> \<longleftrightarrow> identity_arrow_of_spans C \<mu>"
       using arr_char ide_char identity_arrow_of_spans_axioms_def identity_arrow_of_spans_def
             identity_arrow_of_spans.axioms(1) identity_arrow_of_spans.chine_is_identity
       by metis
 
     lemma Chn_in_hom:
     assumes "V.in_hom \<tau> f g"
     shows "C.in_hom (Chn \<tau>) (Chn f) (Chn g)"
-      using assms ide_char arr_char dom_char cod_char
-      by (metis (no_types, lifting) C.ide_char arrow_of_spans.chine_in_hom
-          arrow_of_spans.chine_simps(3) arrow_of_spans_data.simps(3) V.ide_cod
-          V.ide_dom V.in_homE)
+      by (metis arr_char arrow_of_spans.chine_in_hom arrow_of_spans_data.select_convs(1)
+                assms category.in_homE is_category span_vertical_category.cod_char
+                span_vertical_category.dom_char span_vertical_category_axioms)
 
     abbreviation mkIde
     where "mkIde f0 f1 \<equiv>
            \<lparr>Chn = C.dom f0, Dom = \<lparr>Leg0 = f0, Leg1 = f1\<rparr>, Cod = \<lparr>Leg0 = f0, Leg1 = f1\<rparr>\<rparr>"
 
     lemma ide_mkIde:
     assumes "C.span f0 f1"
     shows "V.ide (mkIde f0 f1)"
     proof -
       interpret f: span_in_category C \<open>\<lparr>Leg0 = f0, Leg1 = f1\<rparr>\<close>
         using assms by (unfold_locales, auto)
       interpret ff: arrow_of_spans C \<open>mkIde f0 f1\<close>
         using assms f.apex_def C.comp_arr_dom
         by (unfold_locales, auto)
       show ?thesis
         using assms ff.arrow_of_spans_axioms ide_char by simp
     qed
 
     abbreviation mkObj
     where "mkObj a \<equiv> mkIde a a"
 
     lemma ide_mkObj:
     assumes "C.ide a"
     shows "V.ide (mkObj a)"
       using assms ide_mkIde [of a a] by auto
 
     lemma inverse_arrows:
     assumes "V.arr \<mu>" and "C.iso (Chn \<mu>)"
     shows "V.inverse_arrows \<mu> \<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       let ?\<nu> = "\<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
       interpret \<nu>: arrow_of_spans C ?\<nu>
         using assms C.invert_side_of_triangle(2) [of \<mu>.dom.leg0 \<mu>.cod.leg0 \<mu>.chine]
               C.invert_side_of_triangle(2) [of \<mu>.dom.leg1 \<mu>.cod.leg1 \<mu>.chine]
         by (unfold_locales, auto)
       show "V.inverse_arrows \<mu> ?\<nu>"
       proof
         show "V.ide (?\<nu> \<bullet> \<mu>)"
-        proof -
-          have 1: "V.seq ?\<nu> \<mu>"
-            using arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
-                  \<nu>.arrow_of_spans_axioms
-            by (intro V.seqI', auto)
-          have 2: "?\<nu> \<bullet> \<mu> = \<lparr>Chn = C.inv (Chn \<mu>) \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
-            using 1 arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
-                  \<nu>.arrow_of_spans_axioms
-            by simp
-          moreover have
-            "V.ide \<lparr>Chn = C.inv (Chn \<mu>) \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
-            using assms 1 2 arr_char ide_char by (simp add: C.comp_inv_arr')
-          ultimately show ?thesis by simp
-        qed
-        show "V.ide (\<mu> \<bullet> ?\<nu>)"
-        proof -
-          have 1: "V.seq \<mu> ?\<nu>"
-            using arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
-                  \<nu>.arrow_of_spans_axioms
-            by (intro V.seqI', auto)
-          have 2: "\<mu> \<bullet> ?\<nu> = \<lparr>Chn = Chn \<mu> \<cdot> C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
-            using 1 arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
-                  \<nu>.arrow_of_spans_axioms
-            by simp
-          moreover have "V.ide \<lparr>Chn = Chn \<mu> \<cdot> C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
-            using assms 1 2 arr_char ide_char by (simp add: C.comp_arr_inv')
-          ultimately show ?thesis by simp
-        qed
+          by (metis C.invert_side_of_triangle(1) Chn_vcomp \<mu>.arrow_of_spans_axioms
+                    \<mu>.chine_simps(1) \<mu>.chine_simps(2) \<mu>.dom.ide_apex \<nu>.arrow_of_spans_axioms
+                    arr_char select_convs(1-2) assms(2) C.comp_arr_dom ide_char seq_char)
+        thus "V.ide (\<mu> \<bullet> ?\<nu>)"
+          by (metis C.comp_inv_arr' C.inv_inv C.iso_inv_iso V.ide_compE \<mu>.cod.ide_apex
+                    \<nu>.chine_simps(2) arr_char select_convs(1-2) assms(2) ide_char
+                    Chn_vcomp)
       qed
     qed
 
     lemma iso_char:
     shows "V.iso \<mu> \<longleftrightarrow> V.arr \<mu> \<and> C.iso (Chn \<mu>)"
     proof
       show "V.iso \<mu> \<Longrightarrow> V.arr \<mu> \<and> C.iso (Chn \<mu>)"
         using vcomp_eq ide_char
         by (metis C.iso_iff_section_and_retraction C.retractionI C.sectionI Chn_vcomp
             V.arr_cod V.arr_dom V.comp_arr_inv' V.comp_inv_arr' V.ide_cod V.ide_dom
             V.iso_is_arr)
       show "V.arr \<mu> \<and> C.iso (Chn \<mu>) \<Longrightarrow> V.iso \<mu>"
         using inverse_arrows by auto
     qed
 
     lemma inv_eq:
     assumes "V.iso \<mu>"
     shows "V.inv \<mu> = \<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
       using assms inverse_arrows iso_char by (simp add: V.inverse_unique)
 
   end
 
   subsection "Putting Spans in Homs"
 
   context span_vertical_category
   begin
 
     interpretation V: category vcomp
       using is_category by simp
 
     definition src
     where "src \<mu> \<equiv> if V.arr \<mu> then mkObj (C.cod (Leg0 (Dom \<mu>))) else V.null"
 
     lemma ide_src [simp]:
     assumes "V.arr \<mu>"
     shows "V.ide (src \<mu>)"
       using assms src_def arr_char ide_mkObj C.ide_cod
       by (simp add: arrow_of_spans_def span_in_category.leg_simps(1))
 
     interpretation src: endofunctor vcomp src
     proof
       show "\<And>\<mu>. \<not> V.arr \<mu> \<Longrightarrow> src \<mu> = V.null"
         using arr_char by (simp add: src_def null_char)
       show 1: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.arr (src \<mu>)"
         using ide_src by simp
       show 2: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.dom (src \<mu>) = src (V.dom \<mu>)"
         using 1 arr_char src_def dom_char ide_src V.arr_dom V.ideD(2) by force      
       show 3: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.cod (src \<mu>) = src (V.cod \<mu>)"
         using 1 arr_char src_def cod_char ide_src V.arr_cod V.ideD(3)
               arrow_of_spans.cod_src_eq_dom_src
         by force
       show "\<And>\<mu> \<nu>. V.seq \<nu> \<mu> \<Longrightarrow> src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
-      proof -
-        fix \<mu> \<nu>
-        assume \<mu>\<nu>: "V.seq \<nu> \<mu>"
-        show "src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
-        proof -
-          have "src (\<nu> \<bullet> \<mu>) = mkObj (C.cod (Leg0 (Dom \<mu>)))"
-            using \<mu>\<nu> src_def vcomp_def
-            apply simp
-            using V.not_arr_null null_char by auto
-          also have
-            "... = \<lparr>Chn = C.dom (C.cod (Leg0 (Dom \<mu>))) \<cdot> C.dom (C.cod (Leg0 (Dom \<mu>))),
-                    Dom = \<lparr>Leg0 = C.cod (Leg0 (Dom \<mu>)), Leg1 = C.cod (Leg0 (Dom \<mu>))\<rparr>,
-                    Cod = \<lparr>Leg0 = C.cod (Leg0 (Dom \<mu>)), Leg1 = C.cod (Leg0 (Dom \<mu>))\<rparr>\<rparr>"
-            using \<mu>\<nu> 1
-            by (simp add: arrow_of_spans_def seq_char span_in_category.leg_simps(1))
-          also have "... = src \<nu> \<bullet> src \<mu>"
-            using \<mu>\<nu> 1 src_def vcomp_def
-            apply (elim V.seqE, simp)
-            by (metis \<mu>\<nu> arrow_of_spans.cod_src_eq_dom_src ide_char seq_char ide_src)
-          finally show ?thesis by blast
-        qed
-      qed
+        by (metis (no_types, lifting) "1" "2" "3" V.comp_ide_self V.dom_comp V.ideD(2)
+            V.seqE span_vertical_category.ide_src span_vertical_category_axioms)
     qed
 
     lemma src_is_endofunctor:
     shows "endofunctor vcomp src"
       ..
 
     lemma src_vcomp:
     assumes "V.seq \<nu> \<mu>"
     shows "src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
       using assms src.preserves_comp by simp
 
     definition trg
     where "trg \<mu> \<equiv> if V.arr \<mu> then mkObj (C.cod (Leg1 (Dom \<mu>))) else V.null"
 
     lemma ide_trg [simp]:
     assumes "V.arr \<mu>"
     shows "V.ide (trg \<mu>)"
       using assms trg_def arr_char ide_mkObj C.ide_cod
       by (simp add: arrow_of_spans_def span_in_category.leg_simps(3))
 
     interpretation trg: endofunctor vcomp trg
     proof
       show "\<And>\<mu>. \<not> V.arr \<mu> \<Longrightarrow> trg \<mu> = V.null"
         using arr_char by (simp add: trg_def null_char)
       show 1: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.arr (trg \<mu>)"
         using ide_trg by simp
       show 2: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.dom (trg \<mu>) = trg (V.dom \<mu>)"
         using 1 arr_char trg_def dom_char ide_trg V.arr_dom V.ideD(2) by force      
       show 3: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.cod (trg \<mu>) = trg (V.cod \<mu>)"
         using 1 arr_char trg_def cod_char ide_trg V.arr_cod V.ideD(3)
               arrow_of_spans.cod_trg_eq_dom_trg
         by force
       show "\<And>\<mu> \<nu>. V.seq \<nu> \<mu> \<Longrightarrow> trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
-      proof -
-        fix \<mu> \<nu>
-        assume \<mu>\<nu>: "V.seq \<nu> \<mu>"
-        show "trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
-        proof -
-          have "trg (\<nu> \<bullet> \<mu>) = mkObj (C.cod (Leg1 (Dom \<mu>)))"
-            using \<mu>\<nu> trg_def vcomp_def
-            apply simp
-            using V.not_arr_null null_char by auto
-          also have "... = \<lparr>Chn = Chn (trg \<nu>) \<cdot> Chn (trg \<mu>),
-                            Dom = Dom (trg \<mu>), Cod = Cod (trg \<nu>)\<rparr>"
-            using \<mu>\<nu> 1 trg_def vcomp_def
-            apply (elim V.seqE, simp)
-            by (metis C.ide_def \<mu>\<nu> arrow_of_spans.cod_trg_eq_dom_trg select_convs(1) ide_char
-                ide_trg seq_char)
-          also have "... = trg \<nu> \<bullet> trg \<mu>"
-            using \<mu>\<nu> 1 src_def vcomp_def
-            apply (elim V.seqE, simp)
-            by (metis "2" "3" V.ideD(2) V.ideD(3) select_convs(2) select_convs(3) ide_char
-                ide_trg trg_def)  
-          finally show ?thesis by blast
-        qed
-      qed
+        by (metis "2" "3" V.comp_ide_self V.dom_comp V.ide_char V.seqE ide_trg)
     qed
 
     lemma trg_is_endofunctor:
     shows "endofunctor vcomp trg"
       ..
 
     lemma trg_vcomp:
     assumes "V.seq \<nu> \<mu>"
     shows "trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
       using assms trg.preserves_comp by simp
 
     lemma src_trg_simps [simp]:
     assumes "V.arr \<mu>"
     shows "src (src \<mu>) = src \<mu>"
     and "src (trg \<mu>) = trg \<mu>"
     and "trg (src \<mu>) = src \<mu>"
     and "trg (trg \<mu>) = trg \<mu>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       have 1: "V.arr \<lparr>Chn = \<mu>.dsrc, Dom = \<lparr>Leg0 = \<mu>.dsrc, Leg1 = \<mu>.dsrc\<rparr>,
                       Cod = \<lparr>Leg0 = \<mu>.dsrc, Leg1 = \<mu>.dsrc\<rparr>\<rparr>"
         using ide_mkObj by auto
       have 2: "V.arr \<lparr>Chn = \<mu>.dtrg, Dom = \<lparr>Leg0 = \<mu>.dtrg, Leg1 = \<mu>.dtrg\<rparr>,
                       Cod = \<lparr>Leg0 = \<mu>.dtrg, Leg1 = \<mu>.dtrg\<rparr>\<rparr>"
         using ide_mkObj by auto
       show "src (src \<mu>) = src \<mu>"
         using assms 1 src_def by simp
       show "trg (src \<mu>) = src \<mu>"
         using assms 1 src_def trg_def by simp
       show "src (trg \<mu>) = trg \<mu>"
         using assms 2 src_def trg_def by simp
       show "trg (trg \<mu>) = trg \<mu>"
         using assms 2 trg_def by simp
     qed
 
     sublocale horizontal_homs vcomp src trg
       by (unfold_locales, simp_all)
 
     lemma has_horizontal_homs:
     shows "horizontal_homs vcomp src trg"
       ..
 
     lemma obj_char:
     shows "obj a \<longleftrightarrow> V.ide a \<and> a = mkObj (Chn a)"
-    proof
-      show "obj a \<Longrightarrow> V.ide a \<and> a = mkObj (Chn a)"
-      proof
-        assume a: "obj a"
-        show 1: "V.ide a"
-          using a by auto
-        show "a = mkObj (Chn a)"
-          using a 1 obj_def src_def ide_char
-          apply simp
-          by (metis arrow_of_spans_data.select_convs(1) arrow_of_spans_def category.dom_cod)
-      qed
-      show "V.ide a \<and> a = mkObj (Chn a) \<Longrightarrow> obj a"
-      proof -
-        assume a: "V.ide a \<and> a = mkObj (Chn a)"
-        show "obj a"
-          unfolding obj_def src_def
-          using a
-          apply simp
-          by (metis C.ide_char arrow_of_spans_data.select_convs(2) ide_char
-              span_data.select_convs(1))
-      qed
-    qed
+      by (metis C.dom_cod V.comp_ide_self V.ide_char arrow_of_spans.chine_simps(3)
+          arrow_of_spans_data.select_convs(1,3) objE objI_trg span_data.select_convs(2)
+          cod_char seq_char trg_def)
 
   end
 
   subsection "Horizontal Composite of Spans"
 
   text \<open>
     We now define the horizontal composite \<open>S \<star> T\<close> of spans \<open>S\<close> and \<open>T\<close>,
     assuming that \<open>C\<close> is a category with chosen pullbacks.
     We think of Leg0 as an input and Leg1 as an output.
     The following then defines the composite span \<open>S \<star> T\<close>, with \<open>T\<close> on the ``input side'' of \<open>S\<close>.
     The notation is such that the \<open>\<p>\<^sub>0\<close> projections of \<open>C\<close> are used for legs on the input
     (\emph{i.e.} the ``0'') side and the \<open>\<p>\<^sub>1\<close> projections are used for legs on the output
     (\emph{i.e.} the ``1'') side.
   \<close>
 
   locale composite_span =
     C: elementary_category_with_pullbacks +
     S: span_in_category C S +
     T: span_in_category C T
   for S (structure)
   and T (structure) +
   assumes composable: "C.cod (Leg0 S) = C.cod (Leg1 T)"
   begin
 
     abbreviation this
     where "this \<equiv> \<lparr>Leg0 = T.leg0 \<cdot> \<p>\<^sub>0[S.leg0, T.leg1], Leg1 = S.leg1 \<cdot> \<p>\<^sub>1[S.leg0, T.leg1]\<rparr>"
 
     lemma leg0_prj_in_hom:
     shows "\<guillemotleft>T.leg0 \<cdot> \<p>\<^sub>0[S.leg0, T.leg1] : S.leg0 \<down>\<down> T.leg1 \<rightarrow> C.cod (Leg0 T)\<guillemotright>"
       using S.is_span T.is_span C.prj0_in_hom [of "Leg0 S" "Leg1 T"] composable by auto
 
     lemma leg1_prj_in_hom:
     shows "\<guillemotleft>S.leg1 \<cdot> \<p>\<^sub>1[S.leg0, T.leg1] : S.leg0 \<down>\<down> T.leg1 \<rightarrow> C.cod (Leg1 S)\<guillemotright>"
       using S.is_span T.is_span C.prj1_in_hom [of "Leg0 S" "Leg1 T"] composable by auto
 
     lemma is_span [simp]:
     shows "span_in_category C this"
       using leg0_prj_in_hom leg1_prj_in_hom
       by (unfold_locales, fastforce)
 
     sublocale span_in_category C this
       using is_span by auto
 
   end
 
   locale span_bicategory =
   C: elementary_category_with_pullbacks +
      span_vertical_category
   begin
 
     definition chine_hcomp
     where "chine_hcomp \<nu> \<mu> \<equiv>
            \<langle>Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]
              \<lbrakk>Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)\<rbrakk>
             Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]\<rangle>"
 
     text \<open>
 $$\xymatrix{
   & & \scriptstyle{{\rm src}({\rm Dom}~\nu)} \;=\; {{\rm trg}({\rm Dom}~\mu)} & &\\
   &
     \ar[ddl] _{{\rm Leg1}({\rm Dom}~\nu)}
     \ar [ur] ^<>(0.4){{\rm Leg0}({\rm Dom}~\nu)\hspace{20pt}}
     \ar[dddd] ^{{\rm Chn}~\nu}
   &
   &
     \ar[ul] _<>(0.4){\hspace{20pt}{\rm Leg1}({\rm Dom}~\mu)}
     \ar[ddr] ^{{\rm Leg0}({\rm Dom}~\mu)}
     \ar[dddd] _{{\rm Chn}~\mu}
   \\
   & &
     \ar[ul] ^{p_1}
     \ar[ur] _{p_0}
     \ar@ {.>}[dd]^<>(0.3){{\rm chn\_hcomp~\mu~\nu}}
   \\
   \scriptstyle{{\rm trg}~\nu} & & & & \scriptstyle{{\rm src}~\mu} \\
   & &
     \ar[dl] _{p_1}
     \ar[dr] ^{p_0}
   & &
   \\
   &
     \ar[uul] ^{{\rm Leg1}({\rm Cod}~\nu)}
     \ar[dr] _<>(0.4){{\rm Leg1}({\rm Cod}~\nu)\hspace{20pt}}
   & &
     \ar[dl] ^<>(0.4){\hspace{20pt}{\rm Leg1}({\rm Cod}~\mu)}
     \ar[uur] _{{\rm Leg0}({\rm Cod}~\mu)}
   \\
   & & \scriptstyle{{\rm src}({\rm Cod}~\nu)} \;=\; {{\rm trg}({\rm Cod}~\mu)} & &
 }$$
     \<close>
 
     definition hcomp
     where "hcomp \<nu> \<mu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu> then
                           \<lparr>Chn = chine_hcomp \<nu> \<mu>,
                            Dom = composite_span.this C prj0 prj1 (Dom \<nu>) (Dom \<mu>),
                            Cod = composite_span.this C prj0 prj1 (Cod \<nu>) (Cod \<mu>)\<rparr>
                        else
                           null"
 
     notation hcomp        (infixr "\<star>" 53)
 
     lemma chine_hcomp_props:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "\<guillemotleft>chine_hcomp \<nu> \<mu> : Leg0 (Dom \<nu>) \<down>\<down> Leg1 (Dom \<mu>) \<rightarrow>\<^sub>C Leg0 (Cod \<nu>) \<down>\<down> Leg1 (Cod \<mu>)\<guillemotright>"
     and "C.commutative_square (Leg0 (Cod \<nu>)) (Leg1 (Cod \<mu>))
             (Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)])
             (Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)])"
     and "C.commutative_square \<p>\<^sub>1[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] (Chn \<nu>)
             (chine_hcomp \<nu> \<mu>) \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
     and "C.commutative_square \<p>\<^sub>0[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] (Chn \<mu>)
             (chine_hcomp \<nu> \<mu>) \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
     and "\<p>\<^sub>0[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] \<cdot> chine_hcomp \<nu> \<mu> =
          Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
     and "\<p>\<^sub>1[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] \<cdot> chine_hcomp \<nu> \<mu> =
          Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu>
         using assms arr_char by auto
       show 0: "C.commutative_square \<nu>.cod.leg0 \<mu>.cod.leg1
                  (\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]) (\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
         using assms src_def trg_def C.pullback_commutes C.comp_reduce C.commutative_square_def
         by auto
       show 1: "\<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu> = \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
         unfolding chine_hcomp_def
         using 0 by simp
       show 2: "\<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu> = \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
         unfolding chine_hcomp_def
         using 0 by simp
       show 3: "\<guillemotleft>chine_hcomp \<nu> \<mu> : \<nu>.dom.leg0 \<down>\<down> \<mu>.dom.leg1 \<rightarrow>\<^sub>C \<nu>.cod.leg0 \<down>\<down> \<mu>.cod.leg1\<guillemotright>"
         unfolding chine_hcomp_def
         using assms 0 src_def trg_def C.tuple_in_hom by auto
       show "C.commutative_square \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<nu>.chine
                (chine_hcomp \<nu> \<mu>) \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
         using assms src_def trg_def 1 3 by auto
       show "C.commutative_square \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<mu>.chine
                (chine_hcomp \<nu> \<mu>) \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
         using assms src_def trg_def 2 3 by auto
     qed
 
     lemma chine_hcomp_in_hom [intro]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "\<guillemotleft>chine_hcomp \<nu> \<mu> : Leg0 (Dom \<nu>) \<down>\<down> Leg1 (Dom \<mu>) \<rightarrow>\<^sub>C Leg0 (Cod \<nu>) \<down>\<down> Leg1 (Cod \<mu>)\<guillemotright>"
       using assms chine_hcomp_props(1) by simp
 
     lemma arrow_of_spans_hcomp:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "arrow_of_spans C (\<nu> \<star> \<mu>)"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu>
         using assms arr_char by auto
       show ?thesis
       proof
         show span_Dom: "C.span (Leg0 (Dom (\<nu> \<star> \<mu>))) (Leg1 (Dom (\<nu> \<star> \<mu>)))"
           using assms src_def trg_def hcomp_def C.seqI' by auto
         interpret Dom: span_in_category C \<open>Dom (\<nu> \<star> \<mu>)\<close>
           using span_Dom by (unfold_locales, auto)
         show span_Cod: "C.span (Leg0 (Cod (\<nu> \<star> \<mu>))) (Leg1 (Cod (\<nu> \<star> \<mu>)))"
           using assms hcomp_def src_def trg_def by auto
         interpret Cod: span_in_category C \<open>Cod (\<nu> \<star> \<mu>)\<close>
           using span_Cod by (unfold_locales, auto)
         show map: "\<guillemotleft>Chn (\<nu> \<star> \<mu>) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
           using assms src_def trg_def chine_hcomp_props hcomp_def Cod.apex_def Dom.apex_def
           by auto
         show "Cod.leg0 \<cdot> Chn (\<nu> \<star> \<mu>) = Dom.leg0"
-        proof -
-          have "(\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
-                \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-          proof -
-            have "(\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
-                  \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu>"
-              using assms
-              by (metis (full_types) C.category_axioms C.comp_reduce C.dom_comp C.match_2
-                  C.seqE C.seqI category.ext)
-            also have "... = \<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-              using assms src_def trg_def
-              by (simp add: chine_hcomp_def chine_hcomp_props(2))
-            also have "... = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-              using assms \<mu>.leg0_commutes C.comp_reduce
-              by (metis (mono_tags, lifting) C.commutative_squareE \<mu>.dom.leg_simps(1)
-                  chine_hcomp_props(2))
-            finally show ?thesis by simp
-          qed
-          thus ?thesis
-            using assms src_def trg_def hcomp_def chine_hcomp_props \<mu>.chine_in_hom C.comp_reduce
-            by auto
-        qed
+          by (metis C.comp_assoc \<mu>.leg0_commutes arrow_of_spans_data.select_convs(1-3)
+              assms(1-3) chine_hcomp_props(5) hcomp_def span_data.select_convs(1))
         show "Cod.leg1 \<cdot> Chn (\<nu> \<star> \<mu>) = Dom.leg1"
         proof -
           have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
                  \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-          proof -
-            have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
-                  \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu>"
-              using assms
-              by (metis (full_types) C.category_axioms C.comp_reduce C.dom_comp C.match_2
-                  C.seqE C.seqI category.ext)
-            also have "... = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-              using assms src_def trg_def
-              by (simp add: chine_hcomp_def chine_hcomp_props(2))
-            also have "... = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-              using assms \<nu>.leg1_commutes C.comp_reduce
-              by (metis (mono_tags, lifting) C.commutative_squareE \<nu>.dom.leg_simps(3)
-                  chine_hcomp_props(2))
-            finally show ?thesis by blast
-          qed
+            by (metis C.comp_assoc \<nu>.leg1_commutes assms(1-3) chine_hcomp_props(6))
           thus ?thesis
             using assms src_def trg_def hcomp_def chine_hcomp_props \<nu>.chine_in_hom C.comp_reduce
             by auto
         qed
       qed
     qed
 
     lemma chine_hcomp_ide_arr:
     assumes "ide f" and "arr \<mu>" and "src f = trg \<mu>"
     shows "chine_hcomp f \<mu> =
            \<langle>\<p>\<^sub>1[Leg0 (Dom f), Leg1 (Dom \<mu>)]
               \<lbrakk>Leg0 (Cod f), Leg1 (Cod \<mu>)\<rbrakk>
             Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom f), Leg1 (Dom \<mu>)]\<rangle>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret f: arrow_of_spans C f
         using assms ide_char by auto
       have 1: "C.cospan f.dom.leg0 \<mu>.dom.leg1"
         using assms src_def trg_def by auto
       have "chine_hcomp f \<mu> = \<langle>f.chine \<cdot> \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1]
                                  \<lbrakk>f.cod.leg0, \<mu>.cod.leg1\<rbrakk>
                                \<mu>.chine \<cdot> \<p>\<^sub>0[f.dom.leg0, \<mu>.dom.leg1]\<rangle>"
         unfolding chine_hcomp_def
         using assms ide_char by simp
       moreover have "f.chine \<cdot> \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1] = \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1]"
         using assms 1 C.comp_ide_arr ide_char by auto
       ultimately show ?thesis by argo
     qed
 
     lemma chine_hcomp_arr_ide:
     assumes "arr \<mu>" and "ide f" and "src \<mu> = trg f"
     shows "chine_hcomp \<mu> f =
            \<langle>Chn \<mu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<mu>), Leg1 (Dom f)]
               \<lbrakk>Leg0 (Cod \<mu>), Leg1 (Cod f)\<rbrakk>
             \<p>\<^sub>0[Leg0 (Dom \<mu>), Leg1 (Dom f)]\<rangle>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret f: arrow_of_spans C f
         using assms ide_char by auto
       have 1: "C.cospan \<mu>.dom.leg0 f.dom.leg1"
         using assms src_def trg_def by auto
       have "chine_hcomp \<mu> f = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, f.dom.leg1]
                                  \<lbrakk>\<mu>.cod.leg0, f.cod.leg1\<rbrakk>
                                f.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1]\<rangle>"
         unfolding chine_hcomp_def
         using assms ide_char by simp
       moreover have "f.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1] = \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1]"
         using assms 1 C.comp_ide_arr ide_char by auto
       ultimately show ?thesis by argo
     qed
 
     lemma chine_hcomp_ide_ide:
     assumes "ide g" and "ide f" and "src g = trg f"
     shows "chine_hcomp g f = Leg0 (Dom g) \<down>\<down> Leg1 (Dom f)"
     proof -
       interpret g: identity_arrow_of_spans C g
         using assms ide_char' by auto
       interpret f: identity_arrow_of_spans C f
         using assms ide_char' by auto
       have 1: "C.cospan g.dom.leg0 f.dom.leg1"
         using assms src_def trg_def by auto
        have "chine_hcomp g f = \<langle>g.chine \<cdot> \<p>\<^sub>1[g.dom.leg0, f.dom.leg1]
                                \<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
                               \<p>\<^sub>0[g.dom.leg0, f.dom.leg1]\<rangle>"
         using assms chine_hcomp_arr_ide by simp
       moreover have "g.chine \<cdot> \<p>\<^sub>1[g.dom.leg0, f.dom.leg1] = \<p>\<^sub>1[g.dom.leg0, f.dom.leg1]"
         using assms 1 C.comp_ide_arr ide_char by auto
       ultimately have "chine_hcomp g f = \<langle>\<p>\<^sub>1[g.dom.leg0, f.dom.leg1]
                                           \<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
                                         \<p>\<^sub>0[g.dom.leg0, f.dom.leg1]\<rangle>"
         by simp
       also have "... =
                  \<langle>\<p>\<^sub>1[g.dom.leg0, f.dom.leg1] \<cdot> (g.dom.leg0 \<down>\<down> f.dom.leg1)
                     \<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
                   \<p>\<^sub>0[g.dom.leg0, f.dom.leg1] \<cdot> (g.dom.leg0 \<down>\<down> f.dom.leg1)\<rangle>"
         using assms 1 C.comp_arr_dom by simp
       also have "... = g.dom.leg0 \<down>\<down> f.dom.leg1"
         using 1 C.pullback_commutes C.tuple_prj by simp
       finally show ?thesis by simp
     qed
 
     lemma chine_hcomp_trg_arr:
     assumes "arr \<mu>"
     shows "chine_hcomp (trg \<mu>) \<mu> =
            \<langle>\<p>\<^sub>1[C.cod (Leg1 (Dom \<mu>)), Leg1 (Dom \<mu>)]
               \<lbrakk>C.cod (Leg1 (Dom \<mu>)), Leg1 (Cod \<mu>)\<rbrakk>
             Chn \<mu> \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom \<mu>)), Leg1 (Dom \<mu>)]\<rangle>"
-    proof -
-      interpret \<mu>: arrow_of_spans C \<mu>
-        using assms arr_char by auto
-      interpret trg_\<mu>: arrow_of_spans C \<open>trg \<mu>\<close>
-        using assms ide_trg ide_char by simp
-      have "trg_\<mu>.dom.leg0 = C.cod \<mu>.dom.leg1 \<and> trg_\<mu>.cod.leg0 = C.cod \<mu>.dom.leg1 \<and>
-            trg_\<mu>.dom.leg0 = C.cod \<mu>.dom.leg1"
-        using assms ide_char src_def trg_def by simp
-      thus ?thesis
-        using assms chine_hcomp_ide_arr [of "trg \<mu>" \<mu>] by auto
-    qed
+      using assms chine_hcomp_ide_arr ide_trg src_trg trg_def by force
 
     lemma chine_hcomp_trg_ide:
     assumes "ide f"
     shows "chine_hcomp (trg f) f = C.cod (Leg1 (Dom f)) \<down>\<down> Leg1 (Dom f)"
-    proof -
-      interpret f: arrow_of_spans C f
-        using assms arr_char by auto
-      interpret trg_f: arrow_of_spans C \<open>trg f\<close>
-        using assms ide_trg ide_char by simp
-      have "trg_f.dom.leg0 = C.cod f.dom.leg1"
-        using assms trg_def by simp
-      thus ?thesis
-        using assms chine_hcomp_ide_ide [of "trg f" f] by auto
-    qed
+      using assms chine_hcomp_ide_ide ide_trg src_trg trg_def by force
 
     lemma chine_hcomp_arr_src:
     assumes "arr \<mu>"
     shows "chine_hcomp \<mu> (src \<mu>) =
            \<langle>Chn \<mu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<mu>), C.cod (Leg0 (Dom \<mu>))]
               \<lbrakk>Leg0 (Cod \<mu>), C.cod (Leg0 (Dom \<mu>))\<rbrakk>
             \<p>\<^sub>0[Leg0 (Dom \<mu>), C.cod (Leg0 (Dom \<mu>))]\<rangle>"
-    proof -
-      interpret \<mu>: arrow_of_spans C \<mu>
-        using assms arr_char by auto
-      interpret src_\<mu>: arrow_of_spans C \<open>src \<mu>\<close>
-        using assms ide_src ide_char by simp
-      have "src_\<mu>.dom.leg1 = \<mu>.dsrc \<and> src_\<mu>.cod.leg1 = \<mu>.dsrc"
-        using assms ide_char src_def trg_def by simp
-      thus ?thesis
-        using assms chine_hcomp_arr_ide by auto
-    qed
+      using assms chine_hcomp_arr_ide ide_src src_def trg_src by force
 
     lemma chine_hcomp_ide_src:
     assumes "ide f"
     shows "chine_hcomp f (src f) = Leg0 (Dom f) \<down>\<down> C.cod (Leg0 (Dom f))"
-    proof -
-      interpret f: arrow_of_spans C f
-        using assms arr_char by auto
-      interpret src_f: arrow_of_spans C \<open>src f\<close>
-        using assms ide_src ide_char by simp
-      have "C.cod f.dom.leg0 = src_f.dom.leg1"
-        using assms src_def by simp
-      thus ?thesis
-        using assms chine_hcomp_ide_ide by auto
-    qed
+      using assms chine_hcomp_ide_ide src.preserves_ide src_def trg_src by force
 
     lemma src_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "src (\<nu> \<star> \<mu>) = src \<mu>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu>
         using assms arr_char by auto
       have "C.cod (\<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]) = C.cod \<mu>.dom.leg0"
         using assms C.commutative_squareE chine_hcomp_props(2)
         by (metis (mono_tags, lifting) C.cod_comp C.match_3 \<mu>.leg0_commutes \<mu>.dom.is_span)
       thus ?thesis
         using assms arr_char hcomp_def src_def C.comp_cod_arr C.comp_arr_dom arrow_of_spans_hcomp
         by simp
     qed
 
     lemma trg_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "trg (\<nu> \<star> \<mu>) = trg \<nu>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu>
         using assms arr_char by auto
       have "C.cod (\<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]) = \<nu>.dtrg"
         using assms C.commutative_squareE chine_hcomp_props(2)
         by (metis (mono_tags, lifting) C.cod_comp C.match_3 \<nu>.leg1_commutes \<nu>.dom.is_span)
       thus ?thesis
         using assms arr_char hcomp_def trg_def C.comp_cod_arr C.comp_arr_dom arrow_of_spans_hcomp
         by simp
     qed
 
     lemma dom_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu>
         using assms arr_char by auto
       interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
         using assms arr_char arrow_of_spans_hcomp by simp
       have 1: "C.cospan \<mu>.dom.leg1 \<nu>.dom.leg0"
         using assms \<mu>.dom.is_span \<nu>.dom.is_span src_def trg_def by auto
       have "dom (\<nu> \<star> \<mu>) = 
             \<lparr>Chn = \<nu>.dom.leg0 \<down>\<down> \<mu>.dom.leg1,
              Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
                     Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
              Cod = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
                     Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>\<rparr>"
         using assms \<nu>\<mu>.arrow_of_spans_axioms \<nu>\<mu>.dom.leg_simps(2) \<nu>\<mu>.dom.is_span
               arr_char dom_char hcomp_def
         by auto
       also have "... =
                  \<lparr>Chn = chine_hcomp (dom \<nu>) (dom \<mu>),
                   Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
                          Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
                   Cod = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
                          Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>\<rparr>"
         using assms src_dom trg_dom ide_dom dom_char chine_hcomp_ide_ide
         apply auto
         by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
       also have "... = dom \<nu> \<star> dom \<mu>"
         using assms src_dom trg_dom arr_dom dom_char hcomp_def
         apply auto
         by (metis (no_types, lifting))
       finally show ?thesis by blast
     qed
 
     lemma cod_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     shows "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu>
         using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu>
         using assms arr_char by auto
       interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
         using assms arr_char arrow_of_spans_hcomp by simp
       have 1: "C.cospan \<mu>.cod.leg1 \<nu>.cod.leg0"
         using assms \<mu>.cod.is_span \<nu>.cod.is_span src_def trg_def by simp
       have 2: "cod (\<nu> \<star> \<mu>) =
                \<lparr>Chn = \<nu>.cod.leg0 \<down>\<down> \<mu>.cod.leg1,
                 Dom = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
                        Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>,
                 Cod = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
                        Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>\<rparr>"
         using assms \<nu>\<mu>.arrow_of_spans_axioms \<nu>\<mu>.cod.leg_simps(2) \<nu>\<mu>.cod.is_span
               arr_char cod_char hcomp_def
         by auto
       also have "... =
                \<lparr>Chn = chine_hcomp (cod \<nu>) (cod \<mu>),
                 Dom = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
                        Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>,
                 Cod = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
                        Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>\<rparr>"
         using assms src_cod trg_cod ide_cod cod_char chine_hcomp_ide_ide
         apply auto
         by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
       also have "... = cod \<nu> \<star> cod \<mu>"
         using assms src_cod trg_cod arr_cod cod_char hcomp_def
         apply auto
         by (metis (no_types, lifting))
       finally show ?thesis by simp
     qed
 
     lemma hcomp_vcomp:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
     and "arr \<mu>'" and "arr \<nu>'" and "src \<nu>' = trg \<mu>'"
     and "seq \<mu>' \<mu>" and "seq \<nu>' \<nu>"
     shows "(\<nu>' \<bullet> \<nu>) \<star> (\<mu>' \<bullet> \<mu>) = (\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>)"
     proof -
       interpret \<mu>: arrow_of_spans C \<mu> using assms arr_char by auto
       interpret \<nu>: arrow_of_spans C \<nu> using assms arr_char by auto
       interpret \<mu>': arrow_of_spans C \<mu>' using assms arr_char by auto
       interpret \<nu>': arrow_of_spans C \<nu>' using assms arr_char by auto
       interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
         using assms arr_char arrow_of_spans_hcomp by auto
       interpret \<nu>'\<mu>': arrow_of_spans C \<open>hcomp \<nu>' \<mu>'\<close>
         using assms arr_char arrow_of_spans_hcomp by auto
 
       have 1: "Dom \<nu>' = Cod \<nu> \<and> Dom \<mu>' = Cod \<mu>"
           using assms src_def trg_def seq_char by blast
       have 2: "Dom (\<mu>' \<bullet> \<mu>) = Dom \<mu> \<and> Dom (\<nu>' \<bullet> \<nu>) = Dom \<nu> \<and>
                Cod (\<mu>' \<bullet> \<mu>) = Cod \<mu>' \<and> Cod (\<nu>' \<bullet> \<nu>) = Cod \<nu>'"
         using assms seq_char arr_char vcomp_def
         by (metis arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
       have 3: "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
                \<langle>Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]
                   \<lbrakk>\<nu>'.cod.leg0, \<mu>'.cod.leg1\<rbrakk>
                 Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rangle>"
         unfolding chine_hcomp_def using 2 by simp
 
       have C1: "C.commutative_square \<nu>'.cod.leg0 \<mu>'.cod.leg1
                  (Chn \<nu>' \<cdot> \<p>\<^sub>1[\<nu>'.dom.leg0, \<mu>'.dom.leg1])
                  (Chn \<mu>' \<cdot> \<p>\<^sub>0[\<nu>'.dom.leg0, \<mu>'.dom.leg1])"
          using assms 1 vcomp_def seq_char arr_char chine_hcomp_props(2) by blast
       have C2: "C.commutative_square \<nu>'.cod.leg0 \<mu>'.cod.leg1
                  (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
                  (Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
-      (* using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2) src_vcomp trg_vcomp
-         by smt *)
-      proof
-        show 3: "C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1"
-          using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
-                src_vcomp trg_vcomp
-          by (meson C.commutative_squareE)
-        show 4: "C.span (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
-                     (Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
-          using assms 1 2 3 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
-                src_vcomp trg_vcomp
-          by simp
-        show "C.dom \<nu>'.cod.leg0 = C.cod (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])"
-          using assms 1 2 4 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
-                src_vcomp trg_vcomp
-          by simp
-        show "\<nu>'.cod.leg0 \<cdot> Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1] =
-              \<mu>'.cod.leg1 \<cdot> Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-          using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
-                src_vcomp trg_vcomp
-          by (metis (mono_tags, lifting) C.comp_assoc C.pullback_commutes' Chn_vcomp
-              \<mu>'.cod_trg_eq_dom_trg \<mu>'.leg1_commutes \<mu>.cod_trg_eq_dom_trg \<mu>.dom.leg_simps(3)
-              \<mu>.leg1_commutes \<nu>'.cod_src_eq_dom_src \<nu>'.leg0_commutes \<nu>.cod_src_eq_dom_src
-              \<nu>.dom.leg_simps(1) \<nu>.leg0_commutes \<open>C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1\<close>)
-      qed
+        by (metis "2" assms(3,6-8) chine_hcomp_props(2) src.as_nat_trans.preserves_comp_2
+                  trg.as_nat_trans.preserves_comp_2 vseq_implies_hpar(2))
       have "(\<nu>' \<bullet> \<nu>) \<star> (\<mu>' \<bullet> \<mu>) =
             \<lparr>Chn = chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>),
              Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
                     Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
              Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
                     Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
-      proof -
-        have "\<nu>' \<bullet> \<nu> \<star> \<mu>' \<bullet> \<mu> =
-              \<lparr>Chn = chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>),
-               Dom =
-                 \<lparr>Leg0 = Leg0 (Dom (\<mu>' \<bullet> \<mu>)) \<cdot> \<p>\<^sub>0[Leg0 (Dom (\<nu>' \<bullet> \<nu>)), Leg1 (Dom (\<mu>' \<bullet> \<mu>))],
-                  Leg1 = Leg1 (Dom (\<nu>' \<bullet> \<nu>)) \<cdot> \<p>\<^sub>1[Leg0 (Dom (\<nu>' \<bullet> \<nu>)), Leg1 (Dom (\<mu>' \<bullet> \<mu>))]\<rparr>,
-               Cod = \<lparr>Leg0 = Leg0 (Cod (\<mu>' \<bullet> \<mu>)) \<cdot> \<p>\<^sub>0[Leg0 (Cod (\<nu>' \<bullet> \<nu>)), Leg1 (Cod (\<mu>' \<bullet> \<mu>))],
-               Leg1 = Leg1 (Cod (\<nu>' \<bullet> \<nu>)) \<cdot> \<p>\<^sub>1[Leg0 (Cod (\<nu>' \<bullet> \<nu>)), Leg1 (Cod (\<mu>' \<bullet> \<mu>))]\<rparr>\<rparr>"
-          by (simp add: assms(3) assms(6-8) hcomp_def)
-        then show ?thesis
-          by (metis "2")
-      qed
-      moreover
-      have "(\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>) =
-            \<lparr>Chn = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>,
-             Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
-                    Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
-             Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
-                    Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
-      proof -
-        have "arr (\<nu>' \<star> \<mu>') \<and> arr (\<nu> \<star> \<mu>)"
-          using assms arrow_of_spans_hcomp arr_char by simp
-        moreover have "Dom (\<nu>' \<star> \<mu>') = Cod (\<nu> \<star> \<mu>)"
-          using assms src_def trg_def seq_char hcomp_def src_hcomp trg_hcomp by simp
-        ultimately show ?thesis
-          using assms seq_char arr_char vcomp_eq hcomp_def by auto
-      qed
+        using "2" assms(3,6-8) hcomp_def src_vcomp trg_vcomp by presburger
+      moreover have "(\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>) =
+                     \<lparr>Chn = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>,
+                      Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
+                             Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
+                      Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
+                             Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
+        using "1" \<nu>'\<mu>'.arrow_of_spans_axioms \<nu>\<mu>.arrow_of_spans_axioms assms(1-6)
+              hcomp_def span_vertical_category.seq_char span_vertical_category_axioms vcomp_eq
+        by fastforce
       moreover have "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
       proof -
         have "C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1"
           using assms src_def trg_def by simp
         moreover have "C.seq \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] (chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>))"
           using assms 2 C2 chine_hcomp_props [of "\<mu>' \<bullet> \<mu>" "\<nu>' \<bullet> \<nu>"] by auto
         moreover have "C.seq \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] (chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>)"
           using assms 1 chine_hcomp_props [of \<mu> \<nu>] chine_hcomp_props [of \<mu>' \<nu>'] by auto
         moreover have "\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
                        \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
-        proof -
-          have "\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
-                Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-            using C2 3 by simp
-          also have "... = (\<mu>'.chine \<cdot> \<mu>.chine) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-            using assms vcomp_def seq_char arr_char
-            by (metis arrow_of_spans_data.select_convs(1))
-          also have "... = \<mu>'.chine \<cdot> \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-            using C.comp_assoc by simp
-          also have "... = (\<mu>'.chine \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu>"
-            using assms 1
-                  C.prj_tuple(1)
-                    [of "\<nu>.cod.leg0" "\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-                        "\<mu>.cod.leg1" "\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"]
-            by (metis (mono_tags, lifting) C.commutative_squareE C.comp_assoc chine_hcomp_props(4))
-          also have "... = (\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>') \<cdot> chine_hcomp \<nu> \<mu>"
-            using assms 1
-              by (metis (mono_tags, lifting) C.commutative_squareE chine_hcomp_props(4))
-          also have "... = \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
-            using C.comp_assoc by simp
-          finally show ?thesis by blast
-        qed
+          by (metis (no_types, lifting) "1" "2" C.comp_assoc Chn_vcomp assms(1-8)
+              chine_hcomp_props(5) src_vcomp trg_vcomp)
         moreover have "\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
                        \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
-        proof -
-          have "\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
-                \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot>
-                   \<langle>Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]
-                     \<lbrakk>Leg0 (Cod \<nu>'), Leg1 (Cod \<mu>')\<rbrakk>
-                    Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rangle>"
-            using 3 by simp
-          also have "... = Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-             using C2 C.prj_tuple(2) [of "Leg0 (Cod \<nu>')"
-                                         "Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-                                         "Leg1 (Cod \<mu>')"
-                                         "Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"]
-               by simp
-          also have "... = (\<nu>'.chine \<cdot> \<nu>.chine) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-            using assms vcomp_def seq_char arr_char
-            by (metis (no_types, lifting) arrow_of_spans_data.select_convs(1))
-          also have "... = \<nu>'.chine \<cdot> \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
-            using C.comp_assoc by simp
-          also have "... = (\<nu>'.chine \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu>"
-          proof -
-            have "C.commutative_square \<nu>.cod.leg0 \<mu>.cod.leg1
-                     (\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
-                     (\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
-              using assms 1 vcomp_def seq_char arr_char chine_hcomp_props(2) by auto            
-            thus ?thesis
-              using assms 1 \<nu>'.leg0_commutes C.prj_tuple(2) apply (simp add: C.comp_assoc)
-              by (metis (mono_tags, lifting) C.commutative_squareE chine_hcomp_props(3))
-          qed
-          also have "... = (\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>') \<cdot> chine_hcomp \<nu> \<mu>"
-            unfolding chine_hcomp_def using C1 1 C.prj_tuple(2) by simp
-          also have "... = \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
-            using C.comp_assoc by simp
-          finally show ?thesis by blast
-        qed
+          by (metis (no_types, lifting) "1" "3" C.comp_assoc C.prj_tuple(2) C1 C2 Chn_vcomp
+              assms(1-3,8) chine_hcomp_def chine_hcomp_props(6))
         ultimately show ?thesis
           using C.prj_joint_monic
                   [of "\<nu>'.cod.leg0" "\<mu>'.cod.leg1"
                       "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>)" "chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"]
           by simp
       qed
       ultimately show ?thesis by auto
     qed
 
     interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>\<close>
     proof
       show "\<And>\<nu>\<mu>. \<not> VV.arr \<nu>\<mu> \<Longrightarrow> fst \<nu>\<mu> \<star> snd \<nu>\<mu> = null"
         using hcomp_def VV.arr_char null_char by auto
       show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow> arr (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
         using arr_char arrow_of_spans_hcomp VV.arr_char by simp
       show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow>
                     dom (fst \<nu>\<mu> \<star> snd \<nu>\<mu>) = fst (VV.dom \<nu>\<mu>) \<star> snd (VV.dom \<nu>\<mu>)"
         using VV.arr_char VV.dom_char dom_hcomp by auto
       show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow> cod (fst \<nu>\<mu> \<star> snd \<nu>\<mu>) = fst (VV.cod \<nu>\<mu>) \<star> snd (VV.cod \<nu>\<mu>)"
         using VV.arr_char VV.cod_char cod_hcomp by auto
       show "\<And>\<nu>\<mu>' \<nu>\<mu>. VV.seq \<nu>\<mu>' \<nu>\<mu> \<Longrightarrow> fst (VV.comp \<nu>\<mu>' \<nu>\<mu>) \<star> snd (VV.comp \<nu>\<mu>' \<nu>\<mu>) =
                                         (fst \<nu>\<mu>' \<star> snd \<nu>\<mu>') \<bullet> (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
       proof -
         fix \<nu>\<mu>' \<nu>\<mu>
         assume 1: "VV.seq \<nu>\<mu>' \<nu>\<mu>"
         have "VV.comp \<nu>\<mu>' \<nu>\<mu> = (fst \<nu>\<mu>' \<bullet> fst \<nu>\<mu>, snd \<nu>\<mu>' \<bullet> snd \<nu>\<mu>)"
-          using 1 VV.comp_char VV.seq_char VxV.comp_char by auto
+          by (metis (no_types, lifting) "1" VV.comp_simp VV.seq_char VxV.comp_char VxV.seqE)
         thus "fst (VV.comp \<nu>\<mu>' \<nu>\<mu>) \<star> snd (VV.comp \<nu>\<mu>' \<nu>\<mu>) =
               (fst \<nu>\<mu>' \<star> snd \<nu>\<mu>') \<bullet> (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
           using 1 hcomp_vcomp VV.seq_char VV.arr_char VV.comp_char
           by (metis (no_types, lifting) fst_conv snd_conv)
       qed
     qed
 
     lemma hcomp_is_functor:
     shows "functor VV.comp vcomp (\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
       ..
 
     lemma ide_hcomp:
     assumes "ide f" and "ide g" and "src f = trg g"
     shows "ide (f \<star> g)"
       using assms VV.ide_char VV.arr_char H.preserves_ide [of "(f, g)"] by auto
 
     sublocale horizontal_composition vcomp hcomp src trg
       using src_hcomp trg_hcomp VV.arr_char not_arr_null hcomp_def null_char
       by (unfold_locales, auto)
 
     lemma has_horizontal_composition:
     shows "horizontal_composition vcomp hcomp src trg"
       ..
 
   end
 
   subsection "The Bicategory Span(C)"
 
   context span_bicategory
   begin
 
     lemma arr_eqI:
     assumes "par \<mu> \<mu>'" and "Chn \<mu> = Chn \<mu>'"
     shows "\<mu> = \<mu>'"
       using assms dom_char cod_char by auto
 
     abbreviation \<l>
     where "\<l> f \<equiv> \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
                   Dom = Dom (L f), Cod = Cod f\<rparr>"
 
     interpretation \<ll>: transformation_by_components vcomp vcomp L map \<l>
     proof
       have *: "\<And>f. ide f \<Longrightarrow> arrow_of_spans C (\<l> f)"
       proof -
         fix f
         assume f: "ide f"
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         interpret \<l>f: arrow_of_spans C \<open>\<l> f\<close>
         proof
           show Dom: "C.span (Leg0 (Dom (\<l> f))) (Leg1 (Dom (\<l> f)))"
             using f
             by (simp add: arrow_of_spans_hcomp arrow_of_spans.axioms(2)
                 span_in_category.is_span)
           interpret Dom: span_in_category C \<open>Dom (\<l> f)\<close>
             using Dom by (unfold_locales, auto)
           show Cod: "C.span (Leg0 (Cod (\<l> f))) (Leg1 (Cod (\<l> f)))"
             using f hcomp_def trg_def src_def ide_mkObj C.pullback_commutes by force
           interpret Cod: span_in_category C \<open>Cod (\<l> f)\<close>
             using Cod by (unfold_locales, auto)
           show "\<guillemotleft>Chn (\<l> f) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
           proof -
             have "C.dom Dom.leg0 = C.cod f.dom.leg1 \<down>\<down> f.dom.leg1"
             proof -
               have "arr (trg f)"
                 using f by simp
               hence "Dom (\<l> f) = \<lparr>Leg0 = f.dom.leg0 \<cdot> \<p>\<^sub>0[C.cod f.dom.leg1, f.dom.leg1],
                                  Leg1 = C.cod f.dom.leg1 \<cdot> \<p>\<^sub>1[C.cod f.dom.leg1, f.dom.leg1]\<rparr>"
                 using f src_def trg_def hcomp_def by simp
               thus ?thesis
                 using f Dom hcomp_def by auto
             qed
             thus ?thesis
               using f ide_char Dom.apex_def Cod.apex_def by simp
           qed
           show "Cod.leg0 \<cdot> Chn (\<l> f) = Dom.leg0"
             using f ide_char hcomp_def src_def trg_def C.comp_arr_ide ide_mkObj by simp
           show "Cod.leg1 \<cdot> Chn (\<l> f) = Dom.leg1"
             using f ide_char hcomp_def src_def trg_def C.pullback_commutes ide_mkObj
                   C.comp_arr_ide
             by (simp add: C.commutative_square_def)
         qed
         show "arrow_of_spans C (\<l> f)" ..
       qed
       show 0: "\<And>f. ide f \<Longrightarrow> \<guillemotleft>\<l> f : L f \<Rightarrow> map f\<guillemotright>"
       proof -
         fix f
         assume f: "ide f"
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         interpret \<l>f: arrow_of_spans C \<open>\<l> f\<close>
           using f * by blast
         show "\<guillemotleft>\<l> f : L f \<Rightarrow> map f\<guillemotright>"
         proof
           show 1: "arr (\<l> f)"
             using f * arr_char by blast
           show "dom (\<l> f) = L f"
             using f 1 dom_char ideD(2) by auto
           show "cod (\<l> f) = map f"
             using f 1 cod_char ideD(3) by auto
          qed
       qed
       show "\<And>\<mu>. arr \<mu> \<Longrightarrow> \<l> (cod \<mu>) \<bullet> L \<mu> = map \<mu> \<bullet> \<l> (dom \<mu>)"
       proof -
         fix \<mu>
         assume \<mu>: "arr \<mu>"
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu> arr_char by auto
         interpret \<l>_dom_\<mu>: arrow_of_spans C \<open>\<l> (dom \<mu>)\<close>
           using \<mu> * [of "dom \<mu>"] by fastforce
         interpret \<l>_cod_\<mu>: arrow_of_spans C \<open>\<l> (cod \<mu>)\<close>
           using \<mu> * [of "cod \<mu>"] by fastforce
         interpret L\<mu>: arrow_of_spans C \<open>L \<mu>\<close>
           using \<mu> arr_char by blast
         show "\<l> (cod \<mu>) \<bullet> L \<mu> = map \<mu> \<bullet> \<l> (dom \<mu>)"
         proof (intro arr_eqI)
           show par: "par (\<l> (cod \<mu>) \<bullet> L \<mu>) (map \<mu> \<bullet> \<l> (dom \<mu>))"
             using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] by fastforce
           show "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) = Chn (map \<mu> \<bullet> \<l> (dom \<mu>))"
           proof -
             have "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) =
                    \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot>
                      \<langle>\<p>\<^sub>1[\<mu>.dtrg, \<mu>.dom.leg1] \<lbrakk>\<mu>.dtrg, \<mu>.cod.leg1\<rbrakk> \<mu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dtrg, \<mu>.dom.leg1]\<rangle>"
             proof -
               have "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) = \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot> Chn (trg \<mu> \<star> \<mu>)"
-              proof -
-                have "Dom (trg \<mu> \<star> cod \<mu>) = Cod (trg \<mu> \<star> \<mu>)"
-                  using \<mu> seq_char by fastforce
-                moreover have "\<p>\<^sub>0[C.cod (Leg1 (Dom (cod \<mu>))), Leg1 (Dom (cod \<mu>))] \<cdot>
-                                 Chn (trg \<mu> \<star> \<mu>) =
-                               \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot> Chn (trg \<mu> \<star> \<mu>)"
-                  by (simp add: \<mu> cod_char)
-                moreover have "arrow_of_spans (\<cdot>)
-                                 \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom (cod \<mu>))), Leg1 (Dom (cod \<mu>))],
-                                  Dom = Cod (trg \<mu> \<star> \<mu>), Cod = Cod (cod \<mu>)\<rparr>"
-                  using \<mu> par seq_char by auto
-                ultimately show ?thesis
-                  using \<mu> vcomp_def L\<mu>.arrow_of_spans_axioms by auto
-              qed
+                using Chn_vcomp \<mu> cod_char par by force
               moreover
               have "Chn (trg \<mu> \<star> \<mu>) = \<langle>\<p>\<^sub>1[\<mu>.dtrg, \<mu>.dom.leg1]
                                         \<lbrakk>\<mu>.dtrg, \<mu>.cod.leg1\<rbrakk>
                                        \<mu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dtrg, \<mu>.dom.leg1]\<rangle>"
                 using \<mu> hcomp_def chine_hcomp_trg_arr by simp
               ultimately show ?thesis
                 using \<mu> by (auto simp add: cod_char)
             qed
             also have "... = \<mu>.chine \<cdot> \<p>\<^sub>0[C.cod \<mu>.dom.leg1, \<mu>.dom.leg1]"
               using \<mu> C.in_homE C.pullback_commutes [of "C.cod \<mu>.dom.leg1" "\<mu>.dom.leg1"]
                     C.comp_reduce ide_char C.prj_tuple(1)
               by auto
             also have "... = Chn (map \<mu> \<bullet> \<l> (dom \<mu>))"
               using \<mu> par seq_char dom_char vcomp_eq map_simp by simp
             finally show ?thesis by blast
           qed
         qed
       qed
     qed
 
     interpretation \<ll>: natural_isomorphism vcomp vcomp L map \<ll>.map
     proof
       fix f
       assume f: "ide f"
       show "iso (\<ll>.map f)"
       proof -
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         have 1: "\<ll>.map f = \<lparr>Chn = \<p>\<^sub>0[f.dtrg, f.leg1], Dom = Dom (trg f \<star> f), Cod = Dom f\<rparr>"
           using f ide_char cod_char by simp
         interpret \<l>f: arrow_of_spans C \<open>\<ll>.map f\<close>
           using f arr_char \<ll>.preserves_reflects_arr by fastforce
         let ?\<l>f' = "\<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> C.dom f.leg1\<rangle>,
                     Dom = Dom f, Cod = Dom (trg f \<star> f)\<rparr>"
         have 2: "C.inverse_arrows \<l>f.chine (Chn ?\<l>f')"
           using 1 C.pullback_arr_cod(2) [of "f.leg1"] by simp
         interpret \<l>f': arrow_of_spans C ?\<l>f'
         proof
           show Dom: "C.span (Leg0 (Dom ?\<l>f')) (Leg1 (Dom ?\<l>f'))"
             using f 1 by auto
           interpret Dom: span_in_category C \<open>Dom ?\<l>f'\<close>
             using Dom by (unfold_locales, auto)
           show Cod: "C.span (Leg0 (Cod ?\<l>f')) (Leg1 (Cod ?\<l>f'))"
             using f 1 \<l>f.dom.is_span by auto
           interpret Cod: span_in_category C \<open>Cod ?\<l>f'\<close>
             using Cod by (unfold_locales, auto)
           show "\<guillemotleft>Chn ?\<l>f' : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
             using f src_def trg_def hcomp_def ide_mkObj Cod.apex_def Dom.apex_def
                   C.comp_arr_dom C.comp_cod_arr
             by auto
           show "Cod.leg0 \<cdot> Chn ?\<l>f' = Dom.leg0"
             using 2 \<l>f.leg0_commutes C.invert_side_of_triangle
             by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<l>f.dom.is_span
                 arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
           show "Cod.leg1 \<cdot> Chn ?\<l>f' = Dom.leg1"
             using 2 \<l>f.leg1_commutes C.invert_side_of_triangle
             by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<l>f.dom.is_span
                 arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
         qed
         have "inverse_arrows (\<ll>.map f) ?\<l>f'"
         proof
           show "ide (?\<l>f' \<bullet> \<ll>.map f)"
           proof -
             have "?\<l>f' \<bullet> \<ll>.map f = dom (\<ll>.map f)"
             proof -
               have "?\<l>f' \<bullet> \<ll>.map f =
                     \<lparr>Chn = f.dtrg \<down>\<down> f.leg1, Dom = Dom (\<ll>.map f), Cod = Dom (\<ll>.map f)\<rparr>"
                 using f 1 2 f.arrow_of_spans_axioms \<l>f.arrow_of_spans_axioms
                       \<l>f'.arrow_of_spans_axioms vcomp_def ide_char arr_char
                 by (simp add: vcomp_def C.comp_inv_arr)
               also have "... = dom (\<ll>.map f)"
-              proof -
-                have "C.cod f.dom.leg1 \<down>\<down> f.dom.leg1 = C.dom (Leg1 (Dom (hcomp (trg f) f)))"
-                  using f f.arrow_of_spans_axioms hcomp_def src_def trg_def ide_mkObj
-                  by auto
-                thus ?thesis
-                  using 1 f.arrow_of_spans_axioms arr_char dom_char \<l>f.dom.is_span
-                        \<l>f.arrow_of_spans_axioms \<l>f'.cod.apex_def
-                  by auto
-              qed
+                by (metis (no_types, lifting) "1" C.pbdom_def \<l>f.chine_simps(2)
+                    \<ll>.preserves_reflects_arr arrow_of_spans_data.select_convs(1)
+                    dom_char f ideD(1))
               finally show ?thesis by blast
             qed
             thus ?thesis
               using \<l>f.arrow_of_spans_axioms arr_char by simp
           qed
           show "ide (\<ll>.map f \<bullet> ?\<l>f')"
           proof -
             have "\<ll>.map f \<bullet> ?\<l>f' = dom ?\<l>f'"
             proof -
               have "\<ll>.map f \<bullet> ?\<l>f' = \<lparr>Chn = Chn f, Dom = Dom ?\<l>f', Cod = Dom ?\<l>f'\<rparr>"
                 using f 1 2 f.arrow_of_spans_axioms \<l>f.arrow_of_spans_axioms
                       \<l>f'.arrow_of_spans_axioms vcomp_def ide_char arr_char
                 by fastforce
               also have "... = dom ?\<l>f'"
                 using 1 \<l>f'.arrow_of_spans_axioms arr_char dom_char by simp
               finally show ?thesis by blast
             qed
             thus ?thesis
               using \<l>f'.arrow_of_spans_axioms arr_char by simp
           qed
         qed
         thus ?thesis by auto
       qed
     qed
 
     lemma \<ll>_is_natural_isomorphism:
     shows "natural_isomorphism vcomp vcomp L map \<ll>.map"
       ..
 
     sublocale L: equivalence_functor vcomp vcomp L
       using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
 
     lemma equivalence_functor_L:
     shows "equivalence_functor vcomp vcomp L"
       ..
 
     abbreviation \<r>
     where "\<r> f \<equiv> \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
                   Dom = Dom (R f), Cod = Cod f\<rparr>"
 
     interpretation \<rho>: transformation_by_components vcomp vcomp R map \<r>
     proof
       have *: "\<And>f. ide f \<Longrightarrow> arrow_of_spans C (\<r> f)"
       proof -
         fix f
         assume f: "ide f"
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         interpret \<r>f: arrow_of_spans C \<open>\<r> f\<close>
         proof
           show Dom: "C.span (Leg0 (Dom (\<r> f))) (Leg1 (Dom (\<r> f)))"
             using f
             by (simp add: arrow_of_spans_hcomp arrow_of_spans.axioms(2)
                 span_in_category.is_span)
           interpret Dom: span_in_category C \<open>Dom (\<r> f)\<close>
             using Dom by (unfold_locales, auto)
           show Cod: "C.span (Leg0 (Cod (\<r> f))) (Leg1 (Cod (\<r> f)))"
             using f hcomp_def trg_def src_def ide_mkObj C.pullback_commutes by force
           interpret Cod: span_in_category C \<open>Cod (\<r> f)\<close>
             using Cod by (unfold_locales, auto)
           show "\<guillemotleft>Chn (\<r> f) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
           proof -
             have "C.dom Dom.leg0 = f.dom.leg0 \<down>\<down> C.cod f.dom.leg0"
             proof -
               have "arr (src f)"
                 using f by simp
               hence "Dom (\<r> f) = \<lparr>Leg0 = C.cod f.dom.leg0 \<cdot> \<p>\<^sub>0[f.dom.leg0, C.cod f.dom.leg0],
                                   Leg1 = f.dom.leg1 \<cdot> \<p>\<^sub>1[f.dom.leg0, C.cod f.dom.leg0]\<rparr>"
                 using f src_def trg_def by (simp add: hcomp_def)
               thus ?thesis
                 using f ide_char Dom.apex_def Cod.apex_def by simp
             qed
             thus ?thesis
               using f ide_char Dom.apex_def Cod.apex_def by simp
           qed
           show "Cod.leg0 \<cdot> Chn (\<r> f) = Dom.leg0"
             using f ide_char hcomp_def src_def trg_def C.pullback_commutes
                   ide_mkObj C.comp_arr_ide
             by (simp add: C.commutative_square_def)
           show "Cod.leg1 \<cdot> Chn (\<r> f) = Dom.leg1"
             using f ide_char hcomp_def src_def trg_def ide_mkObj C.comp_arr_ide
             by (simp add: C.commutative_square_def)
         qed
         show "arrow_of_spans C (\<r> f)" ..
       qed
       show 0: "\<And>f. ide f \<Longrightarrow> \<guillemotleft>\<r> f : R f \<Rightarrow> map f\<guillemotright>"
       proof -
         fix f
         assume f: "ide f"
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         interpret \<r>f: arrow_of_spans C \<open>\<r> f\<close>
           using f * by blast
         show "\<guillemotleft>\<r> f : R f \<Rightarrow> map f\<guillemotright>"
         proof
           show 1: "arr (\<r> f)"
             using f * arr_char by blast
           show "dom (\<r> f) = R f"
             using f 1 dom_char ideD(2) by auto
           show "cod (\<r> f) = map f"
             using f 1 cod_char ideD(3) by auto
          qed
       qed
       show "\<And>\<mu>. arr \<mu> \<Longrightarrow> \<r> (cod \<mu>) \<bullet> R \<mu> = map \<mu> \<bullet> \<r> (dom \<mu>)"
       proof -
         fix \<mu>
         assume \<mu>: "arr \<mu>"
         interpret \<mu>: arrow_of_spans C \<mu>
           using \<mu> arr_char by auto
         interpret \<r>_dom_\<mu>: arrow_of_spans C \<open>\<r> (dom \<mu>)\<close>
           using \<mu> * [of "dom \<mu>"] by fastforce
         interpret \<r>_cod_\<mu>: arrow_of_spans C \<open>\<r> (cod \<mu>)\<close>
           using \<mu> * [of "cod \<mu>"] by fastforce
         interpret R\<mu>: arrow_of_spans C \<open>R \<mu>\<close>
           using \<mu> arr_char by blast
         show "\<r> (cod \<mu>) \<bullet> R \<mu> = map \<mu> \<bullet> \<r> (dom \<mu>)"
         proof (intro arr_eqI)
           show par: "par (\<r> (cod \<mu>) \<bullet> R \<mu>) (map \<mu> \<bullet> \<r> (dom \<mu>))"
             using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] by force
           show "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) = Chn (map \<mu> \<bullet> \<r> (dom \<mu>))"
           proof -
             have "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) =
                   \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.cod.src] \<cdot>
                     \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<mu>.dsrc] \<lbrakk>\<mu>.cod.leg0, \<mu>.cod.src\<rbrakk> \<p>\<^sub>0[\<mu>.dom.leg0, \<mu>.dsrc]\<rangle>"
             proof -
               have "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) = \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.cod.src] \<cdot> Chn (\<mu> \<star> src \<mu>)"
-              proof -
-                have "Dom (cod \<mu> \<star> src \<mu>) = Cod (\<mu> \<star> src \<mu>)"
-                  using \<mu> seq_char by fastforce
-                moreover have "\<p>\<^sub>1[Leg0 (Dom (cod \<mu>)), C.cod (Leg0 (Dom (cod \<mu>)))] \<cdot>
-                                 Chn (\<mu> \<star> src \<mu>) =
-                               \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.dsrc] \<cdot> Chn (\<mu> \<star> src \<mu>)"
-                  by (simp add: \<mu> cod_char)
-                moreover have "arrow_of_spans (\<cdot>)
-                                 \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom (cod \<mu>)), C.cod (Leg0 (Dom (cod \<mu>)))],
-                                  Dom = Cod (\<mu> \<star> src \<mu>), Cod = Cod (cod \<mu>)\<rparr>"
-                  using \<mu> par seq_char by auto
-                ultimately show ?thesis
-                  using \<mu> vcomp_def R\<mu>.arrow_of_spans_axioms by auto
-              qed
+                using Chn_vcomp \<mu> cod_char par by force
               moreover
               have "Chn (\<mu> \<star> src \<mu>) = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<mu>.dsrc]
                                         \<lbrakk>\<mu>.cod.leg0, \<mu>.dsrc\<rbrakk>
                                        \<p>\<^sub>0[\<mu>.dom.leg0, \<mu>.dsrc]\<rangle>"
                 using \<mu> hcomp_def chine_hcomp_arr_src by simp
               ultimately show ?thesis
                 using \<mu> by (auto simp add: cod_char)
             qed
             also have "... = \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, C.cod \<mu>.dom.leg0]"
               using \<mu> ide_char C.prj_tuple(2)
                     C.in_homE C.pullback_commutes [of "\<mu>.dom.leg0" "C.cod \<mu>.dom.leg0"]
                     C.comp_reduce
               by auto
             also have "... = Chn (map \<mu> \<bullet> \<r> (dom \<mu>))"
               using \<mu> par seq_char dom_char vcomp_eq map_simp by simp
             finally show ?thesis by blast
           qed
         qed
       qed
     qed
 
     interpretation \<rho>: natural_isomorphism vcomp vcomp R map \<rho>.map
     proof
       fix f
       assume f: "ide f"
       show "iso (\<rho>.map f)"
       proof -
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         have 1: "\<rho>.map f = \<lparr>Chn = \<p>\<^sub>1[f.leg0, f.dsrc], Dom = Dom (f \<star> src f), Cod = Dom f\<rparr>"
           using f ide_char by auto
         interpret \<rho>f: arrow_of_spans C \<open>\<rho>.map f\<close>
           using f arr_char \<rho>.preserves_reflects_arr by fastforce
         let ?\<rho>f' = "\<lparr>Chn = \<langle>C.dom f.leg0 \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>,
                      Dom = Dom f, Cod = Dom (f \<star> src f)\<rparr>"
         have 2: "C.inverse_arrows (Chn (\<rho>.map f)) (Chn ?\<rho>f')"
           using 1 C.pullback_arr_cod(1) [of "f.dom.leg0"] by simp
         interpret \<rho>f': arrow_of_spans C ?\<rho>f'
         proof
           show Dom: "C.span (Leg0 (Dom ?\<rho>f')) (Leg1 (Dom ?\<rho>f'))"
             using f 1 by auto
           interpret Dom: span_in_category C \<open>Dom ?\<rho>f'\<close>
             using Dom by (unfold_locales, auto)
           show Cod: "C.span (Leg0 (Cod ?\<rho>f')) (Leg1 (Cod ?\<rho>f'))"
             using f 1 \<rho>f.dom.is_span by auto
           interpret Cod: span_in_category C \<open>Cod ?\<rho>f'\<close>
             using Cod by (unfold_locales, auto)
           show "\<guillemotleft>Chn ?\<rho>f' : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
             using f src_def trg_def hcomp_def ide_mkObj Cod.apex_def Dom.apex_def
                   C.comp_arr_dom C.comp_cod_arr
             by auto
           show "Cod.leg0 \<cdot> Chn ?\<rho>f' = Dom.leg0"
             using 2 \<rho>f.leg0_commutes C.invert_side_of_triangle
             by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<rho>f.dom.is_span
                 arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
           show "Cod.leg1 \<cdot> Chn ?\<rho>f' = Dom.leg1"
             using 2 \<rho>f.leg1_commutes C.invert_side_of_triangle
             by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<rho>f.dom.is_span
                 arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
         qed
         have "inverse_arrows (\<rho>.map f) ?\<rho>f'"
         proof
           show "ide (?\<rho>f' \<bullet> \<rho>.map f)"
-          proof -
-            have "?\<rho>f' \<bullet> \<rho>.map f = dom (\<rho>.map f)"
-            proof -
-              have "?\<rho>f' \<bullet> \<rho>.map f =
-                     \<lparr>Chn = f.leg0 \<down>\<down> f.dsrc, Dom = Dom (\<rho>.map f), Cod = Dom (\<rho>.map f)\<rparr>"
-                using f 1 2 f.arrow_of_spans_axioms
-                      \<rho>f.arrow_of_spans_axioms \<rho>f'.arrow_of_spans_axioms
-                      vcomp_def ide_char arr_char C.comp_inv_arr
-                by (simp add: vcomp_def)
-              also have "... = dom (\<rho>.map f)"
-              proof -
-                have "C.dom (Leg0 (Dom (f \<star> src f))) = C.dom (Leg1 (Dom (f \<star> src f)))"
-                  using f f.arrow_of_spans_axioms hcomp_def src_def trg_def ide_mkObj
-                  by auto
-                thus ?thesis
-                  using 1 f.arrow_of_spans_axioms arr_char dom_char \<rho>f.dom.is_span
-                        \<rho>f.arrow_of_spans_axioms \<rho>f'.cod.apex_def \<rho>f.chine_simps(2)
-                  by auto
-              qed
-              finally show ?thesis by blast
-            qed
-            thus ?thesis
-              using \<rho>f.arrow_of_spans_axioms arr_char by simp
-          qed
+            using "2" C.comp_inv_arr \<rho>f'.arrow_of_spans_axioms \<rho>f.arrow_of_spans_axioms
+                  \<rho>f.chine_simps(2) dom_char f ideD(2) vcomp_def
+            by force
           show "ide (\<rho>.map f \<bullet> ?\<rho>f')"
           proof -
             have "\<rho>.map f \<bullet> ?\<rho>f' = dom ?\<rho>f'"
             proof -
               have "\<rho>.map f \<bullet> ?\<rho>f' = \<lparr>Chn = Chn f, Dom = Dom ?\<rho>f', Cod = Dom ?\<rho>f'\<rparr>"
                 using f 1 2 f.arrow_of_spans_axioms
                       \<rho>f.arrow_of_spans_axioms \<rho>f'.arrow_of_spans_axioms
                       vcomp_def ide_char arr_char
                 by fastforce
               also have "... = dom ?\<rho>f'"
                 using 1 \<rho>f'.arrow_of_spans_axioms arr_char dom_char by simp
               finally show ?thesis by blast
             qed
             thus ?thesis
               using \<rho>f'.arrow_of_spans_axioms arr_char by simp
           qed
         qed
         thus ?thesis by auto
       qed
     qed
 
     lemma \<rho>_is_natural_isomorphism:
     shows "natural_isomorphism vcomp vcomp R map \<rho>.map"
       ..
 
     sublocale R: equivalence_functor vcomp vcomp R
       using R.isomorphic_to_identity_is_equivalence \<rho>.natural_isomorphism_axioms by simp
 
     lemma equivalence_functor_R:
     shows "equivalence_functor vcomp vcomp R"
       ..
 
     definition unit  ("\<i>[_]")
     where "\<i>[a] \<equiv> \<lparr>Chn = \<p>\<^sub>0[Chn a, Chn a], Dom = Dom (a \<star> a), Cod = Cod a\<rparr>"
 
     lemma unit_in_hom [intro]:
     assumes "obj a"
     shows "in_hhom \<i>[a] a a"
     and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
     proof -
       show "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
       proof (intro in_homI)
         interpret a: identity_arrow_of_spans C a
           using assms obj_char ide_char' by auto
         have 0: "src a = trg a"
           using assms arr_char obj_char src_def trg_def by (elim objE, auto)
         interpret aa: arrow_of_spans C \<open>a \<star> a\<close>
           using assms 0 a.arrow_of_spans_axioms arrow_of_spans_hcomp by auto
         interpret aa: identity_arrow_of_spans C \<open>a \<star> a\<close>
         proof
           have "ide (a \<star> a)"
             using assms 0 obj_char H.preserves_ide by simp
           thus "C.ide aa.chine" using ide_char by auto
         qed
         have 1: "\<guillemotleft>\<p>\<^sub>0[a.chine, a.chine] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C a.chine\<guillemotright> \<and>
                  \<guillemotleft>\<p>\<^sub>1[a.chine, a.chine] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C a.chine\<guillemotright>"
           by auto
         have 2: "a.dom.leg0 = a.chine \<and> a.dom.leg1 = a.chine \<and>
                  a.cod.leg0 = a.chine \<and> a.cod.leg1 = a.chine"
           using assms obj_char by (cases a, simp_all)
         have 3: "a \<star> a = \<lparr>Chn = a.chine \<down>\<down> a.chine,
                           Dom = \<lparr>Leg0 = \<p>\<^sub>0[a.chine, a.chine], Leg1 = \<p>\<^sub>1[a.chine, a.chine]\<rparr>,
                           Cod = \<lparr>Leg0 = \<p>\<^sub>0[a.chine, a.chine], Leg1 = \<p>\<^sub>1[a.chine, a.chine]\<rparr>\<rparr>"
           using assms 0 1 2 chine_hcomp_ide_ide hcomp_def C.comp_cod_arr
                 a.identity_arrow_of_spans_axioms ide_char'
           by auto
         have "aa.apex = a.chine \<down>\<down> a.chine"
           using 3 aa.chine_eq_apex by auto
         interpret \<i>a: arrow_of_spans C \<open>\<i>[a]\<close>
         proof
           have 4: "Dom \<i>[a] = Dom (a \<star> a)"
             using assms hcomp_def unit_def by simp
           have 5: "Cod \<i>[a] = Cod a"
             using assms unit_def by simp
           show Dom: "C.span (Leg0 (Dom \<i>[a])) (Leg1 (Dom \<i>[a]))"
             using 4 by simp
           interpret Dom: span_in_category C \<open>Dom \<i>[a]\<close>
             using Dom by (unfold_locales, auto)
           show Cod: "C.span (Leg0 (Cod \<i>[a])) (Leg1 (Cod \<i>[a]))"
             using 5 by simp
           interpret Cod: span_in_category C \<open>Cod \<i>[a]\<close>
             using Cod by (unfold_locales, auto)
           show "\<guillemotleft>Chn \<i>[a] : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
-          proof -
-            have "\<guillemotleft>Chn \<i>[a] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C C.dom a.chine\<guillemotright>"
-              using assms obj_char ide_char unit_def by simp
-            moreover have "C.dom (Leg0 (Dom \<i>[a])) = Chn a \<down>\<down> Chn a"
-              using assms 3 unit_def obj_char ide_char by simp
-            moreover have "C.dom a.chine = C.dom Cod.leg0"
-              using unit_def by auto
-            ultimately show ?thesis by simp
-          qed
+            by (simp add: \<open>aa.apex = a.chine \<down>\<down> a.chine\<close> unit_def)
           show "Cod.leg0 \<cdot> Chn \<i>[a] = Dom.leg0"
             unfolding unit_def using 1 2 3 C.comp_cod_arr by auto
           show "Cod.leg1 \<cdot> Chn \<i>[a] = Dom.leg1"
             unfolding unit_def using 1 2 3 C.comp_cod_arr C.pullback_ide_self by auto
         qed
         show "arr \<i>[a]"
           using \<i>a.arrow_of_spans_axioms arr_char by simp
         show "dom \<i>[a] = hcomp a a"
           using 3 unit_def \<i>a.arrow_of_spans_axioms arr_char dom_char \<i>a.dom.apex_def
           by auto
         show "cod \<i>[a] = a"
           using assms 3 obj_char arr_char dom_char cod_char unit_def
                 \<i>a.arrow_of_spans_axioms
           by auto
       qed
       thus "in_hhom \<i>[a] a a"
         using assms
         by (metis arrI in_hhom_def objE vconn_implies_hpar(1) vconn_implies_hpar(2-4))
     qed
 
     lemma unit_simps [simp]:
     assumes "obj a"
     shows "src \<i>[a] = a" and "trg \<i>[a] = a"
     and "dom \<i>[a] = hcomp a a" and "cod \<i>[a] = a"
       using assms unit_in_hom by auto
 
     lemma iso_unit:
     assumes "obj a"
     shows "iso \<i>[a]"
     proof -
       have "Chn \<i>[a] = \<p>\<^sub>0[Chn a, Chn a]"
         unfolding unit_def by simp
       moreover have "C.iso \<p>\<^sub>0[Chn a, Chn a]"
         using assms C.ide_is_iso C.iso_is_arr C.iso_pullback_ide ide_char by blast
       ultimately show ?thesis
         using assms unit_in_hom iso_char by auto
     qed
 
   end
 
   locale two_composable_arrows_of_spans =
     span_bicategory +
   \<mu>: arrow_of_spans C \<mu> +
   \<nu>: arrow_of_spans C \<nu>
   for \<mu> (structure)
   and \<nu> (structure) +
   assumes composable: "src \<mu> = trg \<nu>"
   begin
 
     lemma are_arrows [simp]:
     shows "arr \<mu>" and "arr \<nu>"
       using arr_char \<mu>.arrow_of_spans_axioms \<nu>.arrow_of_spans_axioms by auto
 
     lemma legs_form_cospan:
     shows "C.cospan \<mu>.dom.leg0 \<nu>.dom.leg1" and "C.cospan \<mu>.cod.leg0 \<nu>.cod.leg1"
       using composable src_def trg_def by auto
 
     interpretation \<mu>\<nu>: arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
       using arrow_of_spans_hcomp composable by auto
 
     lemma composite_is_arrow [simp]:
     shows "arr (\<mu> \<star> \<nu>)"
       using \<mu>\<nu>.arrow_of_spans_axioms arr_char by auto
 
     lemma composite_in_hom [intro]:
     shows "\<guillemotleft>\<mu> \<star> \<nu> : dom \<mu> \<star> dom \<nu> \<Rightarrow> cod \<mu> \<star> cod \<nu>\<guillemotright>"
       using composable by auto
 
     lemma composite_simps [simp]:
     shows "src (\<mu> \<star> \<nu>) = src \<nu>" and "trg (\<mu> \<star> \<nu>) = trg \<mu>"
     and "dom (\<mu> \<star> \<nu>) = dom \<mu> \<star> dom \<nu>" and "cod (\<mu> \<star> \<nu>) = cod \<mu> \<star> cod \<nu>"
       by (simp_all add: composable)
 
     lemma chine_composite:
     shows "Chn (\<mu> \<star> \<nu>) = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
                            \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
                           \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle>"
        unfolding hcomp_def chine_hcomp_def using composable by simp
 
     lemma chine_composite_in_hom [intro]:
     shows "\<guillemotleft>Chn (\<mu> \<star> \<nu>) : \<mu>.dom.leg0 \<down>\<down> \<nu>.dom.leg1 \<rightarrow>\<^sub>C \<mu>.cod.leg0 \<down>\<down> \<nu>.cod.leg1\<guillemotright>"
       using hcomp_def chine_hcomp_props(1) composable by auto
 
   end
 
   sublocale two_composable_arrows_of_spans \<subseteq> arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
   proof -
     interpret Dom\<mu>_Dom\<nu>: composite_span C prj0 prj1 \<open>Dom \<mu>\<close> \<open>Dom \<nu>\<close>
       using legs_form_cospan(1) by (unfold_locales, auto)
     interpret Cod\<mu>_Cod\<nu>: composite_span C prj0 prj1 \<open>Cod \<mu>\<close> \<open>Cod \<nu>\<close>
       using legs_form_cospan(1) by (unfold_locales, auto)
     interpret Dom_\<mu>\<nu>: span_in_category C \<open>Dom (\<mu> \<star> \<nu>)\<close>
       apply unfold_locales apply (unfold hcomp_def)
       using Dom\<mu>_Dom\<nu>.apex_def Dom\<mu>_Dom\<nu>.leg_simps(1) are_arrows(1) composable by auto
     interpret Cod_\<mu>\<nu>: span_in_category C \<open>Cod (\<mu> \<star> \<nu>)\<close>
       apply unfold_locales apply (unfold hcomp_def)
       using Cod\<mu>_Cod\<nu>.apex_def Cod\<mu>_Cod\<nu>.leg_simps(1) are_arrows(1) composable by auto
     show "arrow_of_spans C (\<mu> \<star> \<nu>)"
     proof
       show "\<guillemotleft>Chn (hcomp \<mu> \<nu>) : Dom_\<mu>\<nu>.apex \<rightarrow>\<^sub>C Cod_\<mu>\<nu>.apex\<guillemotright>"
         unfolding hcomp_def
         using are_arrows(1) are_arrows(2) arrow_of_spans_hcomp composable hcomp_def
               arrow_of_spans.chine_in_hom Cod\<mu>_Cod\<nu>.leg_simps(4) Dom\<mu>_Dom\<nu>.leg_simps(3)
               Dom\<mu>_Dom\<nu>.leg_simps(4) chine_composite_in_hom
         by auto
       show "Cod_\<mu>\<nu>.leg0 \<cdot> Chn (hcomp \<mu> \<nu>) = Dom_\<mu>\<nu>.leg0"
       proof (unfold hcomp_def)
         have "arrow_of_spans C
                 \<lparr>Chn = chine_hcomp \<mu> \<nu>, Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>"
           using arrow_of_spans_hcomp composable hcomp_def by auto
         thus "Leg0 (Cod (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
                             \<lparr>Chn = chine_hcomp \<mu> \<nu>,
                              Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
                          else null)) \<cdot>
                       Chn (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
                              \<lparr>Chn = chine_hcomp \<mu> \<nu>,
                               Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
                            else null) =
               Leg0 (Dom (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
                             \<lparr>Chn = chine_hcomp \<mu> \<nu>,
                              Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
                          else null))"
           using arrow_of_spans.leg0_commutes composable by fastforce
       qed
       show "Cod_\<mu>\<nu>.leg1 \<cdot> Chn (hcomp \<mu> \<nu>) = Dom_\<mu>\<nu>.leg1"
       proof (unfold hcomp_def)
         have "arrow_of_spans C
                 \<lparr>Chn = chine_hcomp \<mu> \<nu>, Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>"
           using arrow_of_spans_hcomp composable hcomp_def by force
         thus "Leg1 (Cod (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
                            \<lparr>Chn = chine_hcomp \<mu> \<nu>,
                             Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
                          else null)) \<cdot>
                     Chn (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
                            \<lparr>Chn = chine_hcomp \<mu> \<nu>,
                             Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
                          else null) =
               Leg1 (Dom (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
                            \<lparr>Chn = chine_hcomp \<mu> \<nu>,
                             Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
                          else null))"
           using arrow_of_spans.leg1_commutes composable by force
         qed
     qed
   qed
 
   locale two_composable_identity_arrows_of_spans =
      two_composable_arrows_of_spans +
   \<mu>: identity_arrow_of_spans C \<mu> +
   \<nu>: identity_arrow_of_spans C \<nu>
   begin
 
     lemma are_identities [simp]:
     shows "ide \<mu>" and "ide \<nu>"
       using ide_char \<mu>.arrow_of_spans_axioms \<nu>.arrow_of_spans_axioms by auto
 
     interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>\<close>
       using hcomp_is_functor by auto
 
     interpretation \<mu>\<nu>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
-    proof
-      have "VV.ide (\<mu>, \<nu>)"
-        using VV.ide_char composable by auto
-      hence "ide (hcomp \<mu> \<nu>)"
-        using H.preserves_ide [of "(\<mu>, \<nu>)"] by simp
-      thus "C.ide chine"
-        using ide_char by simp
-    qed
+      using are_identities(1-2) composable ide_char' by blast
 
     lemma ide_composite [simp]:
     shows "ide (\<mu> \<star> \<nu>)"
       using \<mu>\<nu>.identity_arrow_of_spans_axioms arrow_of_spans_axioms ide_char by auto
 
     lemma apex_composite:
     shows "\<mu>\<nu>.apex = \<mu>.leg0 \<down>\<down> \<nu>.leg1"
       using dom.apex_def hcomp_def chine_hcomp_ide_ide composable legs_form_cospan
       by simp
 
     lemma leg0_composite:
     shows "\<mu>\<nu>.leg0 = \<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]"
       using dom.apex_def hcomp_def composable legs_form_cospan by simp
 
     lemma leg1_composite:
     shows "\<mu>\<nu>.leg1 = \<mu>.leg1 \<cdot> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1]"
       using dom.apex_def hcomp_def composable legs_form_cospan by simp
 
     lemma chine_composite:
     shows "Chn (\<mu> \<star> \<nu>) = \<mu>.leg0 \<down>\<down> \<nu>.leg1"
        unfolding hcomp_def using chine_hcomp_ide_ide composable by simp
 
     abbreviation prj\<^sub>0
     where "prj\<^sub>0 \<equiv> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]"
 
     abbreviation prj\<^sub>1
     where "prj\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1]"
 
     lemma prj_in_hom [intro]:
     shows "\<guillemotleft>prj\<^sub>1 : \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
     and "\<guillemotleft>prj\<^sub>0 : \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
       using legs_form_cospan by auto
 
     lemma prj_simps [simp]:
     shows "C.arr prj\<^sub>1" and "C.dom prj\<^sub>1 = \<mu>.leg0 \<down>\<down> \<nu>.leg1" and "C.cod prj\<^sub>1 = \<mu>.apex"
     and "C.arr prj\<^sub>0" and "C.dom prj\<^sub>0 = \<mu>.leg0 \<down>\<down> \<nu>.leg1" and "C.cod prj\<^sub>0 = \<nu>.apex"
       using prj_in_hom by auto
 
     sublocale identity_arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
       using apex_composite dom.ide_apex chine_composite by (unfold_locales, auto)
 
   end
 
   locale three_composable_arrows_of_spans =
      span_bicategory +
   \<mu>: arrow_of_spans C \<mu> +
   \<nu>: arrow_of_spans C \<nu> +
   \<pi>: arrow_of_spans C \<pi> +
   \<mu>\<nu>: two_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
   \<nu>\<pi>: two_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi>
   for \<mu> (structure)
   and \<nu> (structure)
   and \<pi> (structure)
   begin
 
     interpretation \<mu>\<nu>\<pi>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
       using \<mu>.arrow_of_spans_axioms \<nu>\<pi>.arrow_of_spans_axioms
             arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
       by force
 
     interpretation \<mu>\<nu>_\<pi>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
       using \<mu>\<nu>.arrow_of_spans_axioms \<pi>.arrow_of_spans_axioms
             arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
       by force
 
     lemma composites_are_arrows [simp]:
     shows "arr (\<mu> \<star> \<nu> \<star> \<pi>)" and "arr ((\<mu> \<star> \<nu>) \<star> \<pi>)"
       using \<mu>\<nu>\<pi>.arrow_of_spans_axioms \<mu>\<nu>_\<pi>.arrow_of_spans_axioms arr_char by auto
 
     lemma composite_in_hom [intro]:
     shows "\<guillemotleft>\<mu> \<star> \<nu> \<star> \<pi> : dom \<mu> \<star> dom \<nu> \<star> dom \<pi> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<pi>\<guillemotright>"
     and "\<guillemotleft>(\<mu> \<star> \<nu>) \<star> \<pi> : (dom \<mu> \<star> dom \<nu>) \<star> dom \<pi> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>\<guillemotright>"
       using \<mu>\<nu>.composable \<nu>\<pi>.composable by auto
 
     lemma composite_simps [simp]:
     shows "src (\<mu> \<star> \<nu> \<star> \<pi>) = src \<pi>"
     and "src ((\<mu> \<star> \<nu>) \<star> \<pi>) = src \<pi>"
     and "trg (\<mu> \<star> \<nu> \<star> \<pi>) = trg \<mu>"
     and "trg ((\<mu> \<star> \<nu>) \<star> \<pi>) = trg \<mu>"
     and "dom (\<mu> \<star> \<nu> \<star> \<pi>) = dom \<mu> \<star> dom \<nu> \<star> dom \<pi>"
     and "dom ((\<mu> \<star> \<nu>) \<star> \<pi>) = (dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>"
     and "cod (\<mu> \<star> \<nu> \<star> \<pi>) = cod \<mu> \<star> cod \<nu> \<star> cod \<pi>"
     and "cod ((\<mu> \<star> \<nu>) \<star> \<pi>) = (cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>"
       by (auto simp add: \<mu>\<nu>.composable \<nu>\<pi>.composable)
 
     lemma chine_composite:
     shows "\<mu>\<nu>\<pi>.chine =
              \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]
                \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
               \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
                 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
                \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle> \<cdot>
                  \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]\<rangle>"
     and "\<mu>\<nu>_\<pi>.chine =
            \<langle>\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
               \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
             \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle> \<cdot>
               \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]
               \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
             \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]\<rangle>"
     proof -
       show "\<mu>\<nu>\<pi>.chine =
              \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]
                \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
               \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
                 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
                \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle> \<cdot>
                  \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]\<rangle>"
        unfolding hcomp_def chine_hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable
        using trg_def \<nu>\<pi>.are_arrows(1-2) \<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow
              \<nu>\<pi>.composite_simps(2) hcomp_def
        by (simp add: chine_hcomp_def)
      show "\<mu>\<nu>_\<pi>.chine =
              \<langle>\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
                 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
               \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle> \<cdot>
                 \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]
                 \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
               \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]\<rangle>"
         unfolding hcomp_def chine_hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable
         using src_def \<mu>\<nu>.are_arrows(1-2) \<mu>\<nu>.composable \<mu>\<nu>.composite_is_arrow
               \<mu>\<nu>.composite_simps(1) hcomp_def \<nu>\<pi>.composable
         by (simp add: chine_hcomp_def)
     qed
 
   end
 
   locale three_composable_identity_arrows_of_spans =
     three_composable_arrows_of_spans +
   \<mu>: identity_arrow_of_spans C \<mu> +
   \<nu>: identity_arrow_of_spans C \<nu> +
   \<pi>: identity_arrow_of_spans C \<pi> +
   \<mu>\<nu>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
   \<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi>
   begin
 
     lemma composites_are_identities [simp]:
     shows "ide (\<mu> \<star> \<nu> \<star> \<pi>)" and "ide ((\<mu> \<star> \<nu>) \<star> \<pi>)"
-    proof -
-      interpret \<mu>_H\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close>
-        using \<mu>\<nu>.composable \<nu>\<pi>.composable
-        by (unfold_locales, simp)
-      show "ide (\<mu> \<star> \<nu> \<star> \<pi>)"
-        by auto
-      interpret H\<mu>\<nu>_\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi>
-        using \<mu>\<nu>.composable \<nu>\<pi>.composable
-        by (unfold_locales, simp)
-      show "ide ((\<mu> \<star> \<nu>) \<star> \<pi>)"
-        by auto
-    qed
+      by (auto simp add: \<mu>\<nu>.composable \<nu>\<pi>.composable)
 
     interpretation \<mu>\<nu>\<pi>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
       using composites_are_identities ide_char' by auto
     interpretation \<mu>\<nu>_\<pi>: identity_arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
       using composites_are_identities ide_char' by auto
 
     abbreviation Prj\<^sub>1\<^sub>1
     where "Prj\<^sub>1\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
     abbreviation Prj\<^sub>0\<^sub>1
     where "Prj\<^sub>0\<^sub>1 \<equiv> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
     abbreviation Prj\<^sub>0
     where "Prj\<^sub>0 \<equiv> \<p>\<^sub>0[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
 
     abbreviation Prj\<^sub>1
     where "Prj\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
     abbreviation Prj\<^sub>1\<^sub>0
     where "Prj\<^sub>1\<^sub>0 \<equiv> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1] \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
     abbreviation Prj\<^sub>0\<^sub>0
     where "Prj\<^sub>0\<^sub>0 \<equiv> \<p>\<^sub>0[\<nu>.leg0, \<pi>.leg1] \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
 
     lemma leg0_composite:
     shows "\<mu>\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0\<^sub>0"
     and "\<mu>\<nu>_\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0"
     proof -
       show "\<mu>\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0\<^sub>0"
         using hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composite_is_arrow \<nu>\<pi>.composite_simps(2)
               C.comp_assoc
         by auto
       show "\<mu>\<nu>_\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0"
         using hcomp_def \<mu>\<nu>.composite_is_arrow \<mu>\<nu>.composite_simps(1) \<nu>\<pi>.composable by auto
     qed
 
     lemma leg1_composite:
     shows "\<mu>\<nu>\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1"
     and "\<mu>\<nu>_\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1\<^sub>1"
     proof -
       show "\<mu>\<nu>\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1"
         using hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composite_is_arrow \<nu>\<pi>.composite_simps(2) by auto
       show "\<mu>\<nu>_\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1\<^sub>1"
         using hcomp_def \<mu>\<nu>.composite_is_arrow \<mu>\<nu>.composite_simps(1) \<nu>\<pi>.composable
               C.comp_assoc
         by auto
     qed
 
     definition chine_assoc
     where "chine_assoc \<equiv>
            \<langle>Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]\<rbrakk> \<langle>Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>.leg1\<rbrakk> Prj\<^sub>0\<rangle>\<rangle>"
 
     definition chine_assoc'
     where "chine_assoc' \<equiv>
            \<langle>\<langle>Prj\<^sub>1 \<lbrakk>\<mu>.leg0, \<nu>.leg1\<rbrakk> Prj\<^sub>1\<^sub>0\<rangle> \<lbrakk>\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1\<rbrakk> Prj\<^sub>0\<^sub>0\<rangle>"
 
     (*
      * Don't be fooled by how short the following proofs look -- there's a heck of a lot
      * going on behind the scenes here!
      *)
     lemma chine_composite:
     shows "\<mu>\<nu>_\<pi>.chine = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<down>\<down> \<pi>.leg1"
     and "\<mu>\<nu>\<pi>.chine = \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1"
     proof -
       show "\<mu>\<nu>_\<pi>.chine = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<down>\<down> \<pi>.leg1"
         using hcomp_def chine_hcomp_arr_ide [of "hcomp \<mu> \<nu>" \<pi>] chine_hcomp_ide_ide
               src_def trg_def \<mu>\<nu>.composable \<nu>\<pi>.composable \<mu>\<nu>.ide_composite
               \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities(2)
         by simp
       show "\<mu>\<nu>\<pi>.chine = \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1"
         using hcomp_def chine_hcomp_ide_arr [of \<mu> "hcomp \<nu> \<pi>"] chine_hcomp_ide_ide
               src_def trg_def \<mu>\<nu>.composable \<nu>\<pi>.composable \<nu>\<pi>.ide_composite
               \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities(2)
         by simp
     qed
 
     lemma prj_in_hom [intro]:
     shows "\<guillemotleft>Prj\<^sub>1\<^sub>1 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
     and "\<guillemotleft>Prj\<^sub>0\<^sub>1 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
     and "\<guillemotleft>Prj\<^sub>0 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<pi>.apex\<guillemotright>"
     and "\<guillemotleft>Prj\<^sub>1 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
     and "\<guillemotleft>Prj\<^sub>1\<^sub>0 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
     and "\<guillemotleft>Prj\<^sub>0\<^sub>0 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<pi>.apex\<guillemotright>"
       using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite by auto
 
     lemma prj_simps [simp]:
     shows "C.arr Prj\<^sub>1\<^sub>1"
     and "C.arr Prj\<^sub>0\<^sub>1"
     and "C.arr Prj\<^sub>0"
     and "C.dom Prj\<^sub>1\<^sub>1 = \<mu>\<nu>_\<pi>.chine"
     and "C.dom Prj\<^sub>0\<^sub>1 = \<mu>\<nu>_\<pi>.chine"
     and "C.dom Prj\<^sub>0 = \<mu>\<nu>_\<pi>.chine"
     and "C.cod Prj\<^sub>1\<^sub>1 = \<mu>.apex"
     and "C.cod Prj\<^sub>0\<^sub>1 = \<nu>.apex"
     and "C.cod Prj\<^sub>0 = \<pi>.apex"
     and "C.arr Prj\<^sub>1"
     and "C.arr Prj\<^sub>1\<^sub>0"
     and "C.arr Prj\<^sub>0\<^sub>0"
     and "C.dom Prj\<^sub>1 = \<mu>\<nu>\<pi>.chine"
     and "C.dom Prj\<^sub>1\<^sub>0 = \<mu>\<nu>\<pi>.chine"
     and "C.dom Prj\<^sub>0\<^sub>0 = \<mu>\<nu>\<pi>.chine"
     and "C.cod Prj\<^sub>1 = \<mu>.apex"
     and "C.cod Prj\<^sub>1\<^sub>0 = \<nu>.apex"
     and "C.cod Prj\<^sub>0\<^sub>0 = \<pi>.apex"
       using prj_in_hom by auto
 
     lemma chine_assoc_props:
     shows "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
     and "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
     and "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
     and "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
     proof -
       have 1: "\<nu>.leg0 \<cdot> Prj\<^sub>0\<^sub>1 = \<pi>.leg1 \<cdot> Prj\<^sub>0"
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
               C.pullback_commutes [of "\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]" \<pi>.leg1] C.comp_assoc
         by auto
       have 2: "\<mu>.leg0 \<cdot> Prj\<^sub>1\<^sub>1 = \<nu>.leg1 \<cdot> Prj\<^sub>0\<^sub>1"
-      proof -
-        have "\<mu>.leg0 \<cdot> Prj\<^sub>1\<^sub>1 = (\<mu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>1) \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1]"
-          using C.comp_assoc by auto
-        also have "... = \<nu>.leg1 \<cdot> Prj\<^sub>0\<^sub>1"
-          using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
-                C.pullback_commutes
-          by (auto simp add: C.commutative_square_def C.comp_assoc)
-        finally show ?thesis by simp
-      qed
+        by (metis C.comp_assoc C.pullback_commutes' \<mu>\<nu>.legs_form_cospan(1))
       show "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
         unfolding chine_assoc_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def chine_composite C.comp_assoc by auto
       show "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
         unfolding chine_assoc_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def C.comp_assoc
         by auto
       show "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
         unfolding chine_assoc_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def C.comp_assoc
         by auto
       show "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
         unfolding chine_assoc_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def C.comp_assoc
         by auto
     qed
 
     lemma chine_assoc_in_hom [intro]:
     shows "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
       using chine_assoc_props(1) by simp
 
     lemma prj_chine_assoc [simp]:
     shows "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
     and "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
     and "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
       using chine_assoc_props(2-4) by auto
 
     lemma chine_assoc'_props:
     shows "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
     and "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
     and "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
     and "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
     proof -
       have 1: "\<mu>.leg0 \<cdot> Prj\<^sub>1 = \<nu>.leg1 \<cdot> Prj\<^sub>1\<^sub>0"
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable
               src_def trg_def C.pullback_commutes [of \<mu>.leg0 "\<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]"]
               C.comp_assoc
         by auto
       have 2: "\<nu>.leg0 \<cdot> Prj\<^sub>1\<^sub>0 = \<pi>.leg1 \<cdot> Prj\<^sub>0\<^sub>0"
-      proof -
-        have "\<nu>.leg0 \<cdot> Prj\<^sub>1\<^sub>0 = (\<nu>.leg0 \<cdot> \<nu>\<pi>.prj\<^sub>1) \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1]"
-          using C.comp_assoc by simp
-        also have "... = \<pi>.leg1 \<cdot> Prj\<^sub>0\<^sub>0"
-          using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
-                C.pullback_commutes
-          by (auto simp add: C.commutative_square_def C.comp_assoc)
-        finally show ?thesis by auto
-      qed
+        by (metis C.comp_assoc C.pullback_commutes' \<nu>\<pi>.legs_form_cospan(1))
       show "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
         unfolding chine_assoc'_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def chine_composite C.comp_assoc
         by auto
       show "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
           unfolding chine_assoc'_def
           using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
                 src_def trg_def C.comp_assoc
           by auto
       show "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
         unfolding chine_assoc'_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def C.comp_assoc
         by auto
       show "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
         unfolding chine_assoc'_def
         using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
               src_def trg_def C.comp_assoc
         by auto
     qed
 
     lemma chine_assoc'_in_hom [intro]:
     shows "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
       using chine_assoc'_props(1) by simp
 
     lemma prj_chine_assoc' [simp]:
     shows "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
     and "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
     and "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
       using chine_assoc'_props(2-4) by auto
 
     lemma prj_joint_monic:
     assumes "\<guillemotleft>h: a \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>" and "\<guillemotleft>h': a \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
     and "Prj\<^sub>1\<^sub>1 \<cdot> h = Prj\<^sub>1\<^sub>1 \<cdot> h'" and "Prj\<^sub>0\<^sub>1 \<cdot> h = Prj\<^sub>0\<^sub>1 \<cdot> h'" and "Prj\<^sub>0 \<cdot> h = Prj\<^sub>0 \<cdot> h'"
     shows "h = h'"
     proof -
       have "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
       proof -
         have "\<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
           using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(1)
                 C.comp_assoc
           by force
         moreover
         have "\<mu>\<nu>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
           using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(1)
                 C.comp_assoc
           by force
         ultimately show ?thesis
           using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
                 chine_composite(1) cod_char
                 C.prj_joint_monic
                   [of \<mu>.leg0 \<nu>.leg1 "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h"
                       "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"]
           by auto
       qed
       moreover have "Prj\<^sub>0 \<cdot> h = Prj\<^sub>0 \<cdot> h'"
         using assms cod_char by simp
       ultimately show ?thesis
         using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
               chine_composite(1) cod_char
               C.prj_joint_monic [of "\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0" \<pi>.leg1 h h']
         by auto
     qed
 
     lemma prj'_joint_monic:
     assumes "\<guillemotleft>h: a \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>" and "\<guillemotleft>h': a \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
     and "Prj\<^sub>1 \<cdot> h = Prj\<^sub>1 \<cdot> h'" and "Prj\<^sub>1\<^sub>0 \<cdot> h = Prj\<^sub>1\<^sub>0 \<cdot> h'" and "Prj\<^sub>0\<^sub>0 \<cdot> h = Prj\<^sub>0\<^sub>0 \<cdot> h'"
     shows "h = h'"
     proof -
       have "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
       proof -
         have "\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
           using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
                 C.comp_assoc
           by force
         moreover
         have "\<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
           using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
                 C.comp_assoc
           by force
         ultimately show ?thesis
           using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
                 chine_composite(2) cod_char
                 C.prj_joint_monic
                   [of \<nu>.leg0 \<pi>.leg1 "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h"
                       "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"]
           by auto
       qed
       moreover have "Prj\<^sub>1 \<cdot> h = Prj\<^sub>1 \<cdot> h'"
         using assms cod_char by simp
       ultimately show ?thesis
         using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
               C.prj_joint_monic [of \<mu>.leg0 "\<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1" h h']
         by auto
     qed
 
     lemma chine_assoc_inverse:
     shows "C.inverse_arrows chine_assoc chine_assoc'"
     proof
       show "C.ide (chine_assoc' \<cdot> chine_assoc)"
       proof -
         have 1: "C.ide \<mu>\<nu>_\<pi>.chine"
           using chine_assoc_props(1) C.ide_dom by fastforce
         have "chine_assoc' \<cdot> chine_assoc = \<mu>\<nu>_\<pi>.chine"
         proof -
           have 2: "C.seq chine_assoc' chine_assoc"
             using chine_assoc_props(1) chine_assoc'_props(1) by auto
           have 3: "C.seq Prj\<^sub>1\<^sub>1 chine_assoc' \<and> C.seq Prj\<^sub>0\<^sub>1 chine_assoc' \<and> C.seq Prj\<^sub>0 chine_assoc'"
             using prj_in_hom chine_assoc'_props(1) by auto
           have "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine"
           proof -
             have "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc') \<cdot> chine_assoc"
               using C.comp_assoc by metis
             thus ?thesis using 1 C.comp_arr_dom by simp
           qed
           moreover have "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine"
           proof -
             have "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc') \<cdot> chine_assoc"
               using C.comp_assoc by metis
             thus ?thesis using 1 C.comp_arr_dom by simp
           qed
           moreover have "Prj\<^sub>0 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.chine"
           proof -
             have "Prj\<^sub>0 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>0 \<cdot> chine_assoc') \<cdot> chine_assoc"
               using C.comp_assoc by metis
             thus ?thesis using 1 C.comp_arr_dom C.comp_arr_ide prj_in_hom(3) by auto
           qed
           moreover have "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
             using chine_assoc_props(1) C.ide_dom [of chine_assoc]
             by (elim C.in_homE, auto)
           ultimately show ?thesis
             using chine_assoc_props(1) chine_assoc'_props(1)
                   prj_joint_monic [of "chine_assoc' \<cdot> chine_assoc" "\<mu>\<nu>_\<pi>.chine" "\<mu>\<nu>_\<pi>.chine"]
             by auto
         qed
         thus ?thesis
           using 1 by simp
       qed
       show "C.ide (chine_assoc \<cdot> chine_assoc')"
        proof -
         have 1: "C.ide \<mu>\<nu>\<pi>.chine"
           using chine_assoc_props(1) C.ide_cod by fastforce
         have "chine_assoc \<cdot> chine_assoc' = \<mu>\<nu>\<pi>.chine"
         proof -
           have 2: "C.seq chine_assoc chine_assoc'"
             using chine_assoc_props(1) chine_assoc'_props(1) by auto
           have 3: "C.seq Prj\<^sub>1 chine_assoc \<and> C.seq Prj\<^sub>1\<^sub>0 chine_assoc \<and> C.seq Prj\<^sub>0\<^sub>0 chine_assoc"
             using prj_in_hom chine_assoc_props(1) by auto
           have "Prj\<^sub>1 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine"
           proof -
             have "Prj\<^sub>1 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>1 \<cdot> chine_assoc) \<cdot> chine_assoc'"
               using C.comp_assoc by metis
             thus ?thesis using 1 C.comp_arr_dom prj_in_hom(4) by auto
           qed
           moreover have "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine"
           proof -
             have "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc) \<cdot> chine_assoc'"
               using C.comp_assoc by metis
             thus ?thesis using 1 C.comp_arr_dom by simp
           qed
           moreover have "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine"
           proof -
             have "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc) \<cdot> chine_assoc'"
               using C.comp_assoc by metis
             thus ?thesis using 1 C.comp_arr_dom by simp
           qed
           moreover have "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
             using chine_assoc'_props(1) C.ide_dom [of chine_assoc']
             by (elim C.in_homE, auto)
           ultimately show ?thesis
             using chine_assoc_props(1) chine_assoc'_props(1)
                   prj'_joint_monic [of "chine_assoc \<cdot> chine_assoc'" "\<mu>\<nu>\<pi>.chine" "\<mu>\<nu>\<pi>.chine"]
             by auto
         qed
         thus ?thesis
           using 1 by simp
       qed
     qed
 
   end
 
   context three_composable_arrows_of_spans
   begin
 
     interpretation V: category vcomp
       using is_category by auto
     interpretation H: horizontal_homs vcomp src trg
       using has_horizontal_homs by auto
 
     interpretation dom_\<mu>: arrow_of_spans C \<open>dom \<mu>\<close>
       using \<mu>.arrow_of_spans_axioms arr_char [of "dom \<mu>"] by auto
     interpretation dom_\<nu>: arrow_of_spans C \<open>dom \<nu>\<close>
       using \<nu>.arrow_of_spans_axioms arr_char [of "dom \<nu>"] by auto
     interpretation dom_\<pi>: arrow_of_spans C \<open>dom \<pi>\<close>
       using \<pi>.arrow_of_spans_axioms arr_char [of "dom \<pi>"] by auto
     interpretation doms: three_composable_identity_arrows_of_spans C prj0 prj1
                            \<open>dom \<mu>\<close> \<open>dom \<nu>\<close> \<open>dom \<pi>\<close>
       using \<mu>\<nu>.composable \<nu>\<pi>.composable ide_char [of "dom \<mu>"] ide_char [of "dom \<nu>"]
             ide_char [of "dom \<pi>"]
       by (unfold_locales, auto)
 
     interpretation cod_\<mu>: arrow_of_spans C \<open>cod \<mu>\<close>
       using \<mu>.arrow_of_spans_axioms arr_char [of "cod \<mu>"] by auto
     interpretation cod_\<nu>: arrow_of_spans C \<open>cod \<nu>\<close>
       using \<nu>.arrow_of_spans_axioms arr_char [of "cod \<nu>"] by auto
     interpretation cod_\<pi>: arrow_of_spans C \<open>cod \<pi>\<close>
       using \<pi>.arrow_of_spans_axioms arr_char [of "cod \<pi>"] by auto
     interpretation cods: three_composable_identity_arrows_of_spans C prj0 prj1
                            \<open>cod \<mu>\<close> \<open>cod \<nu>\<close> \<open>cod \<pi>\<close>
       using \<mu>\<nu>.composable \<nu>\<pi>.composable ide_char [of "cod \<mu>"] ide_char [of "cod \<nu>"]
             ide_char [of "cod \<pi>"]
       by (unfold_locales, auto)
 
     interpretation \<mu>\<nu>\<pi>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
       using \<mu>.arrow_of_spans_axioms \<nu>\<pi>.arrow_of_spans_axioms
             arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
       by force
 
     interpretation \<mu>\<nu>_\<pi>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
       using \<mu>\<nu>.arrow_of_spans_axioms \<pi>.arrow_of_spans_axioms
             arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
       by force
 
     lemma chine_composite':
     shows "\<mu>\<nu>\<pi>.chine = \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1
                          \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
                        \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>\<rangle>"
     and "\<mu>\<nu>_\<pi>.chine = \<langle>\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>
                          \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
                        \<pi>.chine \<cdot> doms.Prj\<^sub>0\<rangle>"
     proof -
       show "\<mu>\<nu>_\<pi>.chine = \<langle>\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>
                            \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
                          \<pi>.chine \<cdot> doms.Prj\<^sub>0\<rangle>"
       proof -
         have "arr (\<mu> \<star> \<nu>)" by simp
         thus ?thesis
            unfolding hcomp_def chine_hcomp_def dom_char
            using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char chine_hcomp_props
                  C.comp_tuple_arr C.pullback_commutes C.comp_assoc
            by auto
       qed
       show "\<mu>\<nu>\<pi>.chine = \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1
                           \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
                         \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>\<rangle>"
       proof -
         have "arr (\<nu> \<star> \<pi>)" by simp
         thus ?thesis
            unfolding hcomp_def chine_hcomp_def dom_char
            using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char chine_hcomp_props
                  C.comp_tuple_arr C.pullback_commutes C.comp_assoc
            by auto
       qed
     qed
 
     lemma chine_composite_in_hom [intro]:
     shows "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn ((cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>)\<guillemotright>"
     and "\<guillemotleft>\<mu>\<nu>\<pi>.chine : Chn (dom \<mu> \<star> dom \<nu> \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
-    proof -
-      interpret \<mu>\<nu>: arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
-        using arrow_of_spans_hcomp \<mu>\<nu>.composable by auto
-      interpret \<nu>\<pi>: arrow_of_spans C \<open>\<nu> \<star> \<pi>\<close>
-        using arrow_of_spans_hcomp \<nu>\<pi>.composable by auto
-      show "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn ((cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>)\<guillemotright>"
-      proof -
-        have "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<mu>\<nu>.dom.leg0 \<down>\<down> \<pi>.dom.leg1 \<rightarrow>\<^sub>C \<mu>\<nu>.cod.leg0 \<down>\<down> \<pi>.cod.leg1\<guillemotright>"
-        proof -
-          have "src (\<mu> \<star> \<nu>) = trg \<pi>"
-            using \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
-          moreover have "arr (\<mu> \<star> \<nu>)"
-            using \<mu>\<nu>.arrow_of_spans_axioms by auto
-          ultimately show ?thesis
-            using hcomp_def chine_hcomp_props(1) [of \<pi> "\<mu> \<star> \<nu>"] by auto
-        qed
-        hence "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1] \<down>\<down> \<pi>.dom.leg1 \<rightarrow>\<^sub>C
-                             \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1] \<down>\<down> \<pi>.cod.leg1\<guillemotright>"
-          unfolding hcomp_def using \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
-        thus ?thesis
-          using doms.chine_composite(1) cods.chine_composite(1) dom_char cod_char
-          by auto
-      qed
-      show "\<guillemotleft>\<mu>\<nu>\<pi>.chine : Chn (dom \<mu> \<star> dom \<nu> \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
-      proof -
-        have "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>.dom.leg0 \<down>\<down> \<nu>\<pi>.dom.leg1 \<rightarrow>\<^sub>C \<mu>.cod.leg0 \<down>\<down> \<nu>\<pi>.cod.leg1\<guillemotright>"
-        proof -
-          have "src \<mu> = trg (\<nu> \<star> \<pi>)"
-            using trg_hcomp \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
-          moreover have "arr (\<nu> \<star> \<pi>)"
-            using \<mu>\<nu>.arrow_of_spans_axioms by auto
-          ultimately show ?thesis
-            using hcomp_def chine_hcomp_props(1) [of "\<nu> \<star> \<pi>" \<mu>] by auto
-        qed
-        hence "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>.dom.leg0 \<down>\<down> \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1] \<rightarrow>\<^sub>C
-                            \<mu>.cod.leg0 \<down>\<down> \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<guillemotright>"
-          unfolding hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
-        thus ?thesis
-          using doms.chine_composite(2) cods.chine_composite(2) dom_char cod_char
-          by auto
-      qed
-    qed
+      using Chn_in_hom by auto
 
     lemma cospan_\<mu>\<nu>:
     shows "C.cospan \<mu>.dom.leg0 \<nu>.dom.leg1"
       using \<mu>\<nu>.legs_form_cospan by simp
 
     lemma cospan_\<nu>\<pi>:
     shows "C.cospan \<nu>.dom.leg0 \<pi>.dom.leg1"
       using \<nu>\<pi>.legs_form_cospan by simp
 
     lemma commutativities:
     shows "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
     and "\<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0 =
          (\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
            \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
     proof -
       have AB: "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>1"
       proof -
         have "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>1 =
               (\<mu>.dom.leg0 \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
                 \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
           using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
           by simp
         also have "... = (\<nu>.dom.leg1 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
                            \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
           using C.pullback_commutes' \<mu>\<nu>.legs_form_cospan by auto
         also have "... = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>1"
           using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
           by simp
         finally show ?thesis by auto
       qed
       have BC: "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>0\<^sub>1 = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0"
       proof -
         have "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>0\<^sub>1 =
               (\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
                 \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
           using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
           by simp
         also have "... = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0"
           using C.pullback_commutes' dom_char cod_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan
           by auto
         finally show ?thesis by simp
       qed                    
       show 1: "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
         using AB C.comp_assoc [of \<mu>.cod.leg0 \<mu>.chine]
               C.comp_assoc [of \<nu>.cod.leg1 \<nu>.chine doms.Prj\<^sub>0\<^sub>1]
         by simp
       show "\<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0 =
             (\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
               \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
       proof -
         have "(\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
                 \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle> =
               \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
                 \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
           using 1 \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc by simp
         also have "... = \<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
           using 1 dom_char \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def by simp
         also have "... = (\<nu>.cod.leg0 \<cdot> \<nu>.chine) \<cdot> doms.Prj\<^sub>0\<^sub>1"
           using C.comp_assoc [of \<nu>.cod.leg0 \<nu>.chine doms.Prj\<^sub>0\<^sub>1] by simp
         also have "... = (\<pi>.cod.leg1 \<cdot> \<pi>.chine) \<cdot> doms.Prj\<^sub>0"
           using BC by simp
         also have "... = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0"
           using C.comp_assoc by blast
         finally show ?thesis by simp
       qed
     qed
 
     lemma prj_chine_composite:
     shows "cods.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine = \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1"
     and "cods.Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine = \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
     and "cods.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.chine = \<pi>.chine \<cdot> doms.Prj\<^sub>0"
       using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char cod_char commutativities
             chine_composite' C.comp_assoc
       by auto
 
     lemma commutativities':
     shows "\<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
     and "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1 =
          (\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
            \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
     proof -
       have AB: "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1 = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>1\<^sub>0"
         using C.pullback_commutes' dom_char cod_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan
               C.comp_assoc
         by auto
       have BC: "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>0"
       proof -
         have "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>0 =
               (\<nu>.dom.leg0 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]) \<cdot>
                  \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]"
           using dom_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan C.comp_assoc by simp
         also have "... = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>0"
           using C.pullback_commutes' dom_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan C.comp_assoc
           by simp
         finally show ?thesis by auto
       qed
       show 1: "\<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
         using BC C.comp_assoc [of \<nu>.cod.leg0 \<nu>.chine doms.Prj\<^sub>1\<^sub>0]
               C.comp_assoc [of \<pi>.cod.leg1 \<pi>.chine doms.Prj\<^sub>0\<^sub>0]
               doms.prj_in_hom(5-6) dom_char
          by force
       show "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1 =
             (\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
               \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
       proof -
         have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
                 \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle> =
               \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1] \<cdot>
                 \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
           using 1 \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc by simp
         also have "... = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0"
           using 1 dom_char \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
           by simp
         also have "... = (\<nu>.cod.leg1 \<cdot> \<nu>.chine) \<cdot> doms.Prj\<^sub>1\<^sub>0"
           using C.comp_assoc [of \<nu>.cod.leg1 \<nu>.chine doms.Prj\<^sub>1\<^sub>0] by auto
         also have "... = (\<mu>.cod.leg0 \<cdot> \<mu>.chine) \<cdot> doms.Prj\<^sub>1"
           using AB by simp
         also have "... = \<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1"
           using C.comp_assoc [of \<mu>.cod.leg0 \<mu>.chine doms.Prj\<^sub>1] doms.prj_in_hom(4) dom_char
           by auto
         finally show ?thesis by simp
       qed
     qed
 
     lemma prj'_chine_composite:
     shows "cods.Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine = \<mu>.chine \<cdot> doms.Prj\<^sub>1"
     and "cods.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine = \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0"
     and "cods.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine = \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
       using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char cod_char commutativities'
             chine_composite' C.comp_assoc
       by auto
 
     lemma chine_assoc_naturality:
     shows "cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine = \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
     proof -
       have "\<guillemotleft>cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine :
                Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
         using cods.chine_assoc_props(1) chine_composite_in_hom(1) by blast
       moreover have "\<guillemotleft>\<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc :
                         Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
         using doms.chine_assoc_props(1) chine_composite_in_hom(2) by blast
       moreover
       have "cods.Prj\<^sub>1 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
             cods.Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
         using C.comp_assoc doms.chine_assoc_props(2) cods.chine_assoc_props(2)
               prj_chine_composite prj'_chine_composite
         by metis
       moreover have "cods.Prj\<^sub>1\<^sub>0 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
                      cods.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
         using C.comp_assoc doms.chine_assoc_props(3) cods.chine_assoc_props(3)
               prj_chine_composite prj'_chine_composite
         by metis
       moreover have "cods.Prj\<^sub>0\<^sub>0 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
                      cods.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
         using C.comp_assoc doms.chine_assoc_props(4) cods.chine_assoc_props(4)
               prj_chine_composite prj'_chine_composite
         by metis
       ultimately show ?thesis
         using cods.prj'_joint_monic by auto
     qed
 
   end
 
   context span_bicategory
   begin
 
     abbreviation (input) assoc\<^sub>S\<^sub>B
     where "assoc\<^sub>S\<^sub>B f g h \<equiv> \<lparr>Chn = three_composable_identity_arrows_of_spans.chine_assoc
                                    C prj0 prj1 f g h,
                             Dom = Dom ((f \<star> g) \<star> h), Cod = Cod (f \<star> g \<star> h)\<rparr>"
 
     abbreviation (input) assoc'\<^sub>S\<^sub>B
     where "assoc'\<^sub>S\<^sub>B f g h \<equiv> \<lparr>Chn = three_composable_identity_arrows_of_spans.chine_assoc'
                                     C prj0 prj1 f g h,
                              Dom = Cod (f \<star> g \<star> h), Cod = Dom ((f \<star> g) \<star> h)\<rparr>"
 
     lemma assoc_props:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "src (assoc\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
     and "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
     and "src (assoc'\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
     and "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
     proof -
       have fgh: "VVV.ide (f, g, h)"
         using assms VVV.ide_char VV.ide_char VVV.arr_char VV.arr_char by simp
       interpret f: arrow_of_spans C f
         using assms arr_char by fastforce
       interpret g: arrow_of_spans C g
         using assms arr_char by fastforce
       interpret h: arrow_of_spans C h
         using assms arr_char by fastforce
       interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
         using assms arr_char by (unfold_locales, auto)
       interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
         using assms ide_char by (unfold_locales, auto)
       interpret HHfgh: arrow_of_spans C \<open>(f \<star> g) \<star> h\<close>
         using assms fgh.composites_are_arrows arrow_of_spans_hcomp by simp
       interpret HfHgh: arrow_of_spans C \<open>f \<star> g \<star> h\<close>
         using assms fgh.composites_are_arrows arrow_of_spans_hcomp by simp
       interpret assoc_fgh: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B f g h\<close>
         apply unfold_locales
             apply simp_all
           apply (metis C.ideD(2) C.ideD(3) HHfgh.chine_simps(2) HfHgh.chine_simps(3)
             fgh.composites_are_identities(1) fgh.composites_are_identities(2)
             fgh.chine_assoc_in_hom ide_char)
-      proof -
-        have 1: "arr (f \<star> g)" using fgh.\<mu>\<nu>.composite_is_arrow by simp
-        have 2: "arr (g \<star> h)" using fgh.\<nu>\<pi>.composite_is_arrow by simp
-        show "HfHgh.cod.leg0 \<cdot> fgh.chine_assoc = HHfgh.dom.leg0"
-          using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
-                fgh.chine_assoc_props(4) C.comp_assoc
-          by simp
-        show "HfHgh.cod.leg1 \<cdot> fgh.chine_assoc = HHfgh.dom.leg1"
-          using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
-                fgh.chine_assoc_props(2) C.comp_assoc
-          by simp
-      qed
+        apply (metis C.comp_assoc fgh.composites_are_identities(1) fgh.leg0_composite(1-2)
+                     fgh.prj_chine_assoc(3) ide_char' identity_arrow_of_spans.cod_simps(2))
+        by (metis C.comp_assoc fgh.composites_are_identities(1) fgh.leg1_composite(1-2)
+            fgh.prj_chine_assoc(1) ide_char' identity_arrow_of_spans.cod_simps(3))
       interpret assoc'_fgh: arrow_of_spans C \<open>assoc'\<^sub>S\<^sub>B f g h\<close>
         apply unfold_locales
             apply simp_all
           apply (metis C.ideD(2) C.ideD(3) HHfgh.chine_simps(2) HfHgh.chine_simps(3)
             fgh.composites_are_identities(1) fgh.composites_are_identities(2)
             fgh.chine_assoc'_in_hom ide_char)
-      proof -
-        have 1: "arr (f \<star> g)" using fgh.\<mu>\<nu>.composite_is_arrow by simp
-        have 2: "arr (g \<star> h)"  using fgh.\<nu>\<pi>.composite_is_arrow by simp
-        show "HHfgh.dom.leg0 \<cdot> fgh.chine_assoc' = HfHgh.cod.leg0"
-          using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
-                C.comp_assoc fgh.chine_assoc'_props(4)
-          by simp
-        show "HHfgh.dom.leg1 \<cdot> fgh.chine_assoc' = HfHgh.cod.leg1"
-          using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
-                C.comp_assoc fgh.chine_assoc'_props(2)
-          by auto
-      qed
+        using C.comp_assoc fgh.composites_are_identities(1) fgh.leg0_composite(1-2)
+              ide_char' identity_arrow_of_spans.cod_simps(2)
+         apply force
+        using C.comp_assoc fgh.composites_are_identities(1) fgh.leg1_composite(1-2)
+              fgh.prj_chine_assoc'(1) ide_char' identity_arrow_of_spans.cod_simps(3)
+        by force
       show 1: "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
       proof
         show 1: "arr (assoc\<^sub>S\<^sub>B f g h)"
           using assoc_fgh.arrow_of_spans_axioms arr_char by blast
         show "dom (assoc\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
           using fgh 1 dom_char fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable ideD(2)
           by auto
         show "cod (assoc\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
           using fgh 1 HoVH_def cod_char fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable ideD(3)
           by auto
       qed
       show 2: "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
       proof
         show 1: "arr (assoc'\<^sub>S\<^sub>B f g h)"
           using assoc'_fgh.arrow_of_spans_axioms arr_char by blast
         show "dom (assoc'\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
           using fgh 1 dom_char cod_char ideD(3) by auto
         show "cod (assoc'\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
           using fgh 1 cod_char dom_char ideD(2) by auto            
       qed
       show 3: "src (assoc\<^sub>S\<^sub>B f g h) = src h"
       proof -
         have 4: "src (assoc\<^sub>S\<^sub>B f g h) =
                  \<lparr>Chn = assoc_fgh.dsrc, Dom = \<lparr>Leg0 = assoc_fgh.dsrc, Leg1 = assoc_fgh.dsrc\<rparr>,
                   Cod = \<lparr>Leg0 = assoc_fgh.dsrc, Leg1 = assoc_fgh.dsrc\<rparr>\<rparr>"
           unfolding src_def using 1 by auto
         also have "... = src h"
           using fgh.composite_simps(2) src_def by auto
         finally show ?thesis by blast
       qed
       show "src (assoc'\<^sub>S\<^sub>B f g h) = src h"
       proof -
         have "src (assoc'\<^sub>S\<^sub>B f g h) =
               \<lparr>Chn = assoc'_fgh.dsrc, Dom = \<lparr>Leg0 = assoc'_fgh.dsrc, Leg1 = assoc'_fgh.dsrc\<rparr>,
                Cod = \<lparr>Leg0 = assoc'_fgh.dsrc, Leg1 = assoc'_fgh.dsrc\<rparr>\<rparr>"
           unfolding src_def using 2 by auto
         also have "... = src h"
           using 1 3 assoc_fgh.cod_src_eq_dom_src arrI src_def by auto
         finally show ?thesis by blast
       qed
       show 4: "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
       proof -
         have 5: "trg (assoc\<^sub>S\<^sub>B f g h) =
               \<lparr>Chn = assoc_fgh.dtrg, Dom = \<lparr>Leg0 = assoc_fgh.dtrg, Leg1 = assoc_fgh.dtrg\<rparr>,
                Cod = \<lparr>Leg0 = assoc_fgh.dtrg, Leg1 = assoc_fgh.dtrg\<rparr>\<rparr>"
           unfolding trg_def using 1 by auto
         also have "... = trg f"
           using fgh.composite_simps(4) trg_def by auto
         finally show ?thesis by blast
       qed
       show "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
       proof -
         have 5: "trg (assoc'\<^sub>S\<^sub>B f g h) =
               \<lparr>Chn = assoc'_fgh.dtrg, Dom = \<lparr>Leg0 = assoc'_fgh.dtrg, Leg1 = assoc'_fgh.dtrg\<rparr>,
                Cod = \<lparr>Leg0 = assoc'_fgh.dtrg, Leg1 = assoc'_fgh.dtrg\<rparr>\<rparr>"
           unfolding trg_def using 2 by auto
         also have "... = trg f"
           using 1 4 assoc_fgh.cod_trg_eq_dom_trg arrI trg_def by auto
         finally show ?thesis by blast
       qed
     qed
 
     lemma assoc_in_hom [intro]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright> "
       using assms assoc_props by auto
 
     lemma assoc'_in_hom [intro]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright> "
       using assms assoc_props by auto
 
     lemma assoc_simps [simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "arr (assoc\<^sub>S\<^sub>B f g h)" and "dom (assoc\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
     and "cod (assoc\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
     and "src (assoc\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
       using assms assoc_props(1-3) by (fast, fast, fast, auto)
 
     lemma assoc'_simps [simp]:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "arr (assoc'\<^sub>S\<^sub>B f g h)" and "dom (assoc'\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
     and "cod (assoc'\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
     and "src (assoc'\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
       using assms assoc_props(4-6) by (fast, fast, fast, auto)
 
     lemma inverse_assoc_assoc':
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "inverse_arrows (assoc\<^sub>S\<^sub>B f g h) (assoc'\<^sub>S\<^sub>B f g h)"
     proof -
       interpret f: arrow_of_spans C f using assms arr_char ideD(1) by simp
       interpret g: arrow_of_spans C g using assms arr_char ideD(1) by simp
       interpret h: arrow_of_spans C h using assms arr_char ideD(1) by simp
       interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
         using assms arr_char by (unfold_locales, auto)
       interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
         using assms ide_char
-        apply unfold_locales
-          apply blast
-         apply blast
-        by blast
+        by unfold_locales blast+
       interpret afgh: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B f g h\<close>
         using assms assoc_props(3) arr_char by blast
       interpret a'fgh: arrow_of_spans C \<open>assoc'\<^sub>S\<^sub>B f g h\<close>
         using assms assoc_props(6) arr_char by blast
       show ?thesis
       proof -
         have "inverse_arrows (assoc\<^sub>S\<^sub>B f g h)
                              \<lparr>Chn = C.inv (Chn (assoc\<^sub>S\<^sub>B f g h)),
                               Dom = Cod (assoc\<^sub>S\<^sub>B f g h), Cod = Dom (assoc\<^sub>S\<^sub>B f g h)\<rparr>"
           using inverse_arrows [of "assoc\<^sub>S\<^sub>B f g h"] afgh.arrow_of_spans_axioms
                 arr_char fgh.chine_assoc_inverse
           by auto
         moreover have "C.inv (Chn (assoc\<^sub>S\<^sub>B f g h)) = fgh.chine_assoc'"
           using fgh.chine_assoc_inverse C.inv_is_inverse C.inverse_arrow_unique by auto
         ultimately show ?thesis by simp
       qed
     qed
 
     interpretation \<alpha>: transformation_by_components VVV.comp vcomp HoHV HoVH
                         \<open>\<lambda>fgh. assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))\<close>
     proof
       show *: "\<And>fgh. VVV.ide fgh \<Longrightarrow> \<guillemotleft>assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)) :
                                          HoHV fgh \<Rightarrow> HoVH fgh\<guillemotright>"
       proof -
         fix fgh
         assume fgh: "VVV.ide fgh"
         show "\<guillemotleft>assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)) : HoHV fgh \<Rightarrow> HoVH fgh\<guillemotright>"
           unfolding HoHV_def HoVH_def
           using fgh assoc_in_hom [of "fst fgh" "fst (snd fgh)" "snd (snd fgh)"]
                 VVV.arr_char VVV.ide_char VV.arr_char
           by simp
       qed
       show "\<And>\<mu>\<nu>\<pi>. VVV.arr \<mu>\<nu>\<pi> \<Longrightarrow>
                      assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
                              (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
                        HoHV \<mu>\<nu>\<pi> =
                      HoVH \<mu>\<nu>\<pi> \<bullet> assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
                                         (snd (snd (VVV.dom \<mu>\<nu>\<pi>)))"
       proof -
         fix \<mu>\<nu>\<pi>
         assume \<mu>\<nu>\<pi>: "VVV.arr \<mu>\<nu>\<pi>"
         interpret \<mu>: arrow_of_spans C \<open>fst \<mu>\<nu>\<pi>\<close>
           using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char arr_char by auto
         interpret \<nu>: arrow_of_spans C \<open>fst (snd \<mu>\<nu>\<pi>)\<close>
           using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
         interpret \<pi>: arrow_of_spans C \<open>snd (snd \<mu>\<nu>\<pi>)\<close>
           using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
         interpret \<mu>\<nu>\<pi>: three_composable_arrows_of_spans C prj0 prj1
                          \<open>fst \<mu>\<nu>\<pi>\<close> \<open>fst (snd \<mu>\<nu>\<pi>)\<close> \<open>snd (snd \<mu>\<nu>\<pi>)\<close>
           using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char
           by (unfold_locales, auto)
 
         interpret HoHV_\<mu>\<nu>\<pi>: arrow_of_spans C \<open>(fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>)) \<star> snd (snd \<mu>\<nu>\<pi>)\<close>
         proof -
           have "arr (HoHV \<mu>\<nu>\<pi>)"
             using \<mu>\<nu>\<pi> by simp
           thus "arrow_of_spans C ((fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>)) \<star> snd (snd \<mu>\<nu>\<pi>))"
             using \<mu>\<nu>\<pi> HoHV_def arr_char by auto
         qed
         interpret HoVH_\<mu>\<nu>\<pi>: arrow_of_spans C \<open>fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>) \<star> snd (snd \<mu>\<nu>\<pi>)\<close>
         proof -
           have "arr (HoVH \<mu>\<nu>\<pi>)"
             using \<mu>\<nu>\<pi> by simp
           thus "arrow_of_spans C (fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>) \<star> snd (snd \<mu>\<nu>\<pi>))"
             using \<mu>\<nu>\<pi> HoVH_def arr_char by auto
         qed
 
         have dom_\<mu>\<nu>\<pi>: "VVV.ide (VVV.dom \<mu>\<nu>\<pi>)"
           using \<mu>\<nu>\<pi> VVV.ide_dom by blast
         interpret dom_\<mu>: identity_arrow_of_spans C \<open>fst (VVV.dom \<mu>\<nu>\<pi>)\<close>
           using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
         interpret dom_\<nu>: identity_arrow_of_spans C \<open>fst (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
           using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
         interpret dom_\<pi>: identity_arrow_of_spans C \<open>snd (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
           using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
         interpret dom_\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1
                              \<open>fst (VVV.dom \<mu>\<nu>\<pi>)\<close> \<open>fst (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
                              \<open>snd (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
           using dom_\<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char
           by (unfold_locales, auto)
         interpret assoc_dom_\<mu>\<nu>\<pi>: arrow_of_spans C
                                   \<open>assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
                                     (snd (snd (VVV.dom \<mu>\<nu>\<pi>)))\<close>
           using \<mu>\<nu>\<pi> VVV.ide_dom * arr_char by fast
 
         have cod_\<mu>\<nu>\<pi>: "VVV.ide (VVV.cod \<mu>\<nu>\<pi>)"
           using \<mu>\<nu>\<pi> VVV.ide_cod by blast
         interpret cod_\<mu>: identity_arrow_of_spans C \<open>fst (VVV.cod \<mu>\<nu>\<pi>)\<close>
           using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
         interpret cod_\<nu>: identity_arrow_of_spans C \<open>fst (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
           using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
         interpret cod_\<pi>: identity_arrow_of_spans C \<open>snd (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
           using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
         interpret cod_\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1
                              \<open>fst (VVV.cod \<mu>\<nu>\<pi>)\<close> \<open>fst (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
                              \<open>snd (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
           using cod_\<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char
           by (unfold_locales, auto)
         interpret assoc_cod_\<mu>\<nu>\<pi>: arrow_of_spans C
                                \<open>assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
                                   (snd (snd (VVV.cod \<mu>\<nu>\<pi>)))\<close>
           using \<mu>\<nu>\<pi> VVV.ide_cod * arr_char by fast
 
         have dom_legs:
                "dom_\<mu>.leg0 = \<mu>.dom.leg0 \<and> dom_\<nu>.leg0 = \<nu>.dom.leg0 \<and> dom_\<pi>.leg0 = \<pi>.dom.leg0 \<and>
                 dom_\<mu>.leg1 = \<mu>.dom.leg1 \<and> dom_\<nu>.leg1 = \<nu>.dom.leg1 \<and> dom_\<pi>.leg1 = \<pi>.dom.leg1"
           using VVV.arr_char VVV.dom_char dom_char \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable
           by auto
         have cod_legs:
                 "cod_\<mu>.leg0 = \<mu>.cod.leg0 \<and> cod_\<nu>.leg0 = \<nu>.cod.leg0 \<and> cod_\<pi>.leg0 = \<pi>.cod.leg0 \<and>
                  cod_\<mu>.leg1 = \<mu>.cod.leg1 \<and> cod_\<nu>.leg1 = \<nu>.cod.leg1 \<and> cod_\<pi>.leg1 = \<pi>.cod.leg1"
           using \<mu>\<nu>\<pi> VVV.cod_char cod_char by auto
 
         have Prj\<^sub>1\<^sub>1_dom: "dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 =
                           \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1] \<cdot>
                             \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
           using dom_legs by argo
         have Prj\<^sub>1\<^sub>1_cod: "cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 =
                           \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
                             \<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
           using cod_legs by argo
         have Prj\<^sub>0_dom: "dom_\<mu>\<nu>\<pi>.Prj\<^sub>0 = \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
           using dom_legs by argo
         have Prj\<^sub>0_cod: "cod_\<mu>\<nu>\<pi>.Prj\<^sub>0 = \<p>\<^sub>0[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
           using cod_legs by argo
 
         have Dom: "Dom ((fst (VVV.dom \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.dom \<mu>\<nu>\<pi>))) \<star>
                          snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
                    \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>"
-        proof -
-            have "arr (dom (fst \<mu>\<nu>\<pi>) \<star> dom (fst (snd \<mu>\<nu>\<pi>)))"
-              using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
-            thus ?thesis
-              using \<mu>\<nu>\<pi> hcomp_def dom_legs ide_dom dom_char
-                apply simp
-              using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
-                    VVV.dom_simp VV.dom_simp
-              by auto
-        qed
+          using dom_\<mu>\<nu>\<pi>.leg0_composite(2) dom_\<mu>\<nu>\<pi>.leg1_composite(2) dom_legs by auto
         have Cod: "Cod (fst (VVV.dom \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.dom \<mu>\<nu>\<pi>)) \<star>
                          snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
                    \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>"
         proof -
             have "arr (dom (fst (snd \<mu>\<nu>\<pi>)) \<star> dom (snd (snd \<mu>\<nu>\<pi>)))"
               using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
             thus ?thesis
               using \<mu>\<nu>\<pi> hcomp_def dom_legs ide_dom dom_char
                 apply simp
               using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
                     VVV.dom_simp VV.dom_simp
               by auto
         qed
         have Dom': "Dom ((fst (VVV.cod \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.cod \<mu>\<nu>\<pi>))) \<star>
                           snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
                     \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>"
-        proof -
-            have "arr (cod (fst \<mu>\<nu>\<pi>) \<star> cod (fst (snd \<mu>\<nu>\<pi>)))"
-              using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
-            moreover have "\<mu>.dsrc = \<nu>.dtrg"
-              using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable src_def trg_def cod_char by simp
-            moreover have "\<nu>.dsrc = \<pi>.dtrg"
-              using \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char by simp
-            ultimately show ?thesis
-              using \<mu>\<nu>\<pi> hcomp_def cod_legs ide_cod cod_char VVV.cod_simp VV.cod_simp
-                apply simp
-              using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char C.comp_assoc
-              by simp
-        qed
+          by (simp add: cod_\<mu>\<nu>\<pi>.leg0_composite(2) cod_\<mu>\<nu>\<pi>.leg1_composite(2) cod_legs)
         have Cod': "Cod (fst (VVV.cod \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.cod \<mu>\<nu>\<pi>)) \<star>
                           snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
                     \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>"
         proof -
             have "arr (cod (fst (snd \<mu>\<nu>\<pi>)) \<star> cod (snd (snd \<mu>\<nu>\<pi>)))"
               using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
             moreover have "\<mu>.dsrc = \<nu>.dtrg"
               using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable src_def trg_def cod_char by simp
             ultimately show ?thesis
               using \<mu>\<nu>\<pi> hcomp_def cod_legs ide_cod cod_char VVV.cod_simp VV.cod_simp
                 apply simp
               using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char C.comp_assoc
               by auto
         qed
 
         have assoc_dom:
              "assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
                       (snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
               \<lparr>Chn = dom_\<mu>\<nu>\<pi>.chine_assoc,
                Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
                Cod = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
           using Dom Cod by simp
         have assoc_cod:
              "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
                      (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
               \<lparr>Chn = cod_\<mu>\<nu>\<pi>.chine_assoc,
                Dom = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
                Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
           using Dom' Cod' by simp
         have HoHV_\<mu>\<nu>\<pi>:
           "HoHV \<mu>\<nu>\<pi> =
            \<lparr>Chn = HoHV_\<mu>\<nu>\<pi>.chine,
             Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
             Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>\<rparr>"
         proof -
           have "arr \<lparr>Chn = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
                               \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
                             \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle>,
                      Dom = \<lparr>Leg0 = \<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1],
                             Leg1 = \<mu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rparr>,
                      Cod = \<lparr>Leg0 = \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1],
                             Leg1 = \<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1]\<rparr>\<rparr>"
             unfolding hcomp_def chine_hcomp_def
             using \<mu>\<nu>\<pi> hcomp_def dom_legs cod_legs ide_dom ide_cod dom_char cod_char
                   \<mu>\<nu>\<pi>.\<mu>\<nu>.composable
             by (metis (no_types, lifting) hseq_char(1) \<mu>\<nu>\<pi>.\<mu>\<nu>.composite_is_arrow chine_hcomp_def)
           moreover have "(\<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
                            \<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1] =
                           \<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
                            \<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
            using C.comp_assoc by simp
           ultimately show ?thesis
             unfolding HoHV_def hcomp_def chine_hcomp_def
             using \<mu>\<nu>\<pi> \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_legs cod_legs
                   C.comp_assoc
             by simp
         qed
         have HoVH_\<mu>\<nu>\<pi>:
           "HoVH \<mu>\<nu>\<pi> =
            \<lparr>Chn = HoVH_\<mu>\<nu>\<pi>.chine,
             Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>,
             Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
         proof -
           have "arr \<lparr>Chn = \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
                              \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
                             \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle>,
                      Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1],
                             Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rparr>,
                      Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1],
                             Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rparr>\<rparr>"
             unfolding hcomp_def chine_hcomp_def
             using \<mu>\<nu>\<pi> hcomp_def dom_legs cod_legs ide_dom ide_cod dom_char cod_char
                   \<mu>\<nu>\<pi>.\<nu>\<pi>.composable
             by (metis (no_types, lifting) hseq_char \<mu>\<nu>\<pi>.\<nu>\<pi>.composite_is_arrow chine_hcomp_def)
          moreover have "(\<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot>
                           \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]] =
                          \<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1] \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot>
                            \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]]"
            using C.comp_assoc by simp
          ultimately show ?thesis
             unfolding HoVH_def hcomp_def chine_hcomp_def
             using \<mu>\<nu>\<pi> \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_legs cod_legs
                   C.comp_assoc
             by simp
        qed
        have "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
                      (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
                HoHV \<mu>\<nu>\<pi> =
              \<lparr>Chn = cod_\<mu>\<nu>\<pi>.chine_assoc \<cdot> HoHV_\<mu>\<nu>\<pi>.chine,
               Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
               Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
         proof -
           have "arr (HoHV \<mu>\<nu>\<pi>)"
             using \<mu>\<nu>\<pi> by simp
           thus ?thesis
             using vcomp_def HoHV_\<mu>\<nu>\<pi> HoHV_\<mu>\<nu>\<pi>.arrow_of_spans_axioms
                   assoc_cod_\<mu>\<nu>\<pi>.arrow_of_spans_axioms assoc_cod dom_legs cod_legs
                   arr_char
             by simp
         qed
         moreover
         have "HoVH \<mu>\<nu>\<pi> \<bullet>
                 assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
                         (snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
               \<lparr>Chn = HoVH_\<mu>\<nu>\<pi>.chine \<cdot> dom_\<mu>\<nu>\<pi>.chine_assoc,
                Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
                Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
         proof -
           have "arr (HoVH \<mu>\<nu>\<pi>)"
             using \<mu>\<nu>\<pi> by simp
           thus ?thesis
             using vcomp_def HoVH_\<mu>\<nu>\<pi> HoVH_\<mu>\<nu>\<pi>.arrow_of_spans_axioms
                   assoc_dom_\<mu>\<nu>\<pi>.arrow_of_spans_axioms assoc_dom dom_legs cod_legs
                   arr_char
             by simp
         qed
         moreover
         have "cod_\<mu>\<nu>\<pi>.chine_assoc \<cdot> HoHV_\<mu>\<nu>\<pi>.chine = HoVH_\<mu>\<nu>\<pi>.chine \<cdot> dom_\<mu>\<nu>\<pi>.chine_assoc"
           using \<mu>\<nu>\<pi> HoHV_def HoVH_def \<mu>\<nu>\<pi>.chine_assoc_naturality
                 VVV.dom_simp VV.dom_simp VVV.cod_simp VV.cod_simp by simp
         ultimately show "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
                                  (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
                            HoHV \<mu>\<nu>\<pi> =
                          HoVH \<mu>\<nu>\<pi> \<bullet>
                            assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
                                    (snd (snd (VVV.dom \<mu>\<nu>\<pi>)))"
           by argo
       qed
     qed
 
     definition assoc  ("\<a>[_, _, _]")
     where "assoc \<equiv> \<lambda>\<mu> \<nu> \<pi>. \<alpha>.map (\<mu>, \<nu>, \<pi>)"
 
     abbreviation (input) \<alpha>\<^sub>S\<^sub>B
     where "\<alpha>\<^sub>S\<^sub>B \<equiv> \<lambda>\<mu>\<nu>\<pi>. assoc (fst \<mu>\<nu>\<pi>) (fst (snd \<mu>\<nu>\<pi>)) (snd (snd \<mu>\<nu>\<pi>))"
 
     lemma \<alpha>_ide:
     assumes "ide f" and "ide g" and "ide h"
     and "src f = trg g" and "src g = trg h"
     shows "\<alpha>\<^sub>S\<^sub>B (f, g, h) = assoc\<^sub>S\<^sub>B f g h"
       using assms assoc_def \<alpha>.map_simp_ide VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
       by simp
 
     lemma natural_transformation_\<alpha>:
     shows "natural_transformation VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B"
       using assoc_def \<alpha>.natural_transformation_axioms by auto
 
     interpretation \<alpha>: natural_transformation VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
       using natural_transformation_\<alpha> by simp
 
     sublocale \<alpha>: natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
     proof
       show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<alpha>\<^sub>S\<^sub>B fgh)"
       proof -
         fix fgh
         assume fgh: "VVV.ide fgh"
         interpret f: arrow_of_spans C \<open>fst fgh\<close>
           using fgh VVV.ide_char VVV.arr_char arr_char by auto
         interpret g: arrow_of_spans C \<open>fst (snd fgh)\<close>
           using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
         interpret h: arrow_of_spans C \<open>snd (snd fgh)\<close>
           using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
         interpret fgh: three_composable_arrows_of_spans C prj0 prj1
                          \<open>fst fgh\<close> \<open>fst (snd fgh)\<close> \<open>snd (snd fgh)\<close>
           using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char
           by (unfold_locales, auto)
         interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1
                          \<open>fst fgh\<close> \<open>fst (snd fgh)\<close> \<open>snd (snd fgh)\<close>
           using fgh VVV.ide_char VV.ide_char ide_char
-          apply unfold_locales
-            apply blast
-           apply blast
-          by blast
+          by unfold_locales blast+
         have 1: "arr (\<alpha>\<^sub>S\<^sub>B fgh)"
           using fgh \<alpha>.preserves_reflects_arr VVV.ideD(1) by blast
         have 2: "\<alpha>\<^sub>S\<^sub>B fgh = assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"
           using fgh assoc_def \<alpha>_ide [of "fst fgh" "fst (snd fgh)" "snd (snd fgh)"]
                 VVV.ide_char VV.ide_char VVV.arr_char VV.arr_char
           by simp
         moreover have "iso ..."
           using 1 2 iso_char [of "assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"]
                 fgh.chine_assoc_inverse by auto
         ultimately show "iso (\<alpha>\<^sub>S\<^sub>B fgh)" by argo
       qed
     qed
 
     lemma natural_isomorphism_\<alpha>:
     shows "natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B"
       ..
 
   end
 
   locale four_composable_arrows_of_spans =
      span_bicategory +
   \<mu>: arrow_of_spans C \<mu> +
   \<nu>: arrow_of_spans C \<nu> +
   \<pi>: arrow_of_spans C \<pi> +
   \<rho>: arrow_of_spans C \<rho> +
   \<mu>\<nu>: two_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
   \<nu>\<pi>: two_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi> +
   \<pi>\<rho>: two_composable_arrows_of_spans C prj0 prj1 \<pi> \<rho> +
   \<mu>\<nu>\<pi>: three_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<pi> +
   \<nu>\<pi>\<rho>: three_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi> \<rho>
   for \<mu> (structure)
   and \<nu> (structure)
   and \<pi> (structure)
   and \<rho> (structure)
 
   locale four_composable_identity_arrows_of_spans =
     four_composable_arrows_of_spans +
   \<mu>: identity_arrow_of_spans C \<mu> +
   \<nu>: identity_arrow_of_spans C \<nu> +
   \<pi>: identity_arrow_of_spans C \<pi> +
   \<rho>: identity_arrow_of_spans C \<rho> +
   \<mu>\<nu>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
   \<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi> +
   \<pi>\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<pi> \<rho> +
   \<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<pi> +
   \<nu>\<pi>\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi> \<rho>
   begin
 
     interpretation H: horizontal_composition vcomp hcomp src trg
       using has_horizontal_composition by auto
 
     text \<open>
       The following interpretations provide us with some systematic names
       for a lot of things.
     \<close>
 
     interpretation H\<mu>H\<nu>\<pi>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
       using \<mu>\<nu>\<pi>.composites_are_identities ide_char' by auto
     interpretation HH\<mu>\<nu>\<pi>: identity_arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
       using \<mu>\<nu>\<pi>.composites_are_identities ide_char' by auto
     interpretation H\<nu>H\<pi>\<rho>: identity_arrow_of_spans C \<open>\<nu> \<star> \<pi> \<star> \<rho>\<close>
       using \<nu>\<pi>\<rho>.composites_are_identities ide_char' by auto
     interpretation HH\<nu>\<pi>\<rho>: identity_arrow_of_spans C \<open>(\<nu> \<star> \<pi>) \<star> \<rho>\<close>
       using \<nu>\<pi>\<rho>.composites_are_identities ide_char' by auto
 
     interpretation H\<mu>H\<nu>H\<pi>\<rho>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<close>
       using arrow_of_spans_hcomp \<mu>\<nu>.composable \<nu>\<pi>\<rho>.composites_are_arrows(1) by auto
     interpretation H\<mu>HH\<nu>\<pi>\<rho>: arrow_of_spans C \<open>\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<close>
       using arrow_of_spans_hcomp \<mu>\<nu>.composable \<nu>\<pi>\<rho>.composites_are_arrows(1) by auto
     interpretation HH\<mu>\<nu>H\<pi>\<rho>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<close>
       using hseq_char' match_4 \<mu>\<nu>\<pi>.composites_are_arrows(2) \<pi>\<rho>.composite_is_arrow arr_char
       by auto
     interpretation HH\<mu>H\<nu>\<pi>\<rho>: arrow_of_spans C \<open>(\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<close>
       using arrow_of_spans_hcomp \<pi>\<rho>.composable \<mu>\<nu>\<pi>.composites_are_arrows(1) by auto
     interpretation HHH\<mu>\<nu>\<pi>\<rho>: arrow_of_spans C \<open>((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho>\<close>
       using arrow_of_spans_hcomp \<pi>\<rho>.composable \<mu>\<nu>\<pi>.composites_are_arrows(2) by auto
 
     interpretation assoc\<mu>\<nu>\<pi>: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>\<close>
       using arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable assoc_simps(1) by auto
     interpretation assoc\<nu>\<pi>\<rho>: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>\<close>
       using arr_char \<nu>\<pi>.composable \<pi>\<rho>.composable assoc_simps(1) by auto
 
     interpretation \<mu>_\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close>
       using \<mu>\<nu>.composable \<nu>\<pi>.composable by (unfold_locales, auto)
     interpretation \<mu>\<nu>_\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi>
       using \<mu>\<nu>.composable \<nu>\<pi>.composable by (unfold_locales, auto)
     interpretation \<nu>_\<pi>\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<open>\<pi> \<star> \<rho>\<close>
       using \<nu>\<pi>.composable \<pi>\<rho>.composable by (unfold_locales, auto)
     interpretation \<nu>\<pi>_\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<nu> \<star> \<pi>\<close> \<rho>
       using \<nu>\<pi>.composable \<pi>\<rho>.composable by (unfold_locales, auto)
     (* The two other cases, \<mu>\<nu>\<pi> and \<nu>\<pi>\<rho>, are part of the locale assumptions. *)
 
     interpretation \<mu>_\<nu>\<pi>_\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close> \<rho> ..
     interpretation \<mu>_\<nu>_\<pi>\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<open>\<pi> \<star> \<rho>\<close> ..
     interpretation \<mu>\<nu>_\<pi>_\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi> \<rho> ..
 
     lemma chines_eq:
     shows "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
     and "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.leg1"
     and "H\<mu>H\<nu>H\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> H\<nu>H\<pi>\<rho>.leg1"
     proof -
       show "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
         using hcomp_def [of \<mu> "hcomp (hcomp \<nu> \<pi>) \<rho>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
         by simp
       show "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.leg1"
-      proof -
-        have "hseq \<nu> \<pi> \<and> arr \<mu> \<and> src \<mu> = trg (hcomp \<nu> \<pi>)"
-          using \<mu>_\<nu>\<pi>.are_arrows(1) \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow by blast
-        then have "assoc\<mu>\<nu>\<pi>.cod.leg0 = \<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0"
-          using \<nu>\<pi>.composable by (simp add: hcomp_def)
-        then show ?thesis
-          by (simp add: \<mu>_\<nu>\<pi>_\<rho>.chine_composite(1))
-      qed
+        by (simp add: \<mu>_\<nu>\<pi>.leg0_composite \<mu>_\<nu>\<pi>_\<rho>.chine_composite(1))
       show "H\<mu>H\<nu>H\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> H\<nu>H\<pi>\<rho>.leg1"
         using hcomp_def [of \<mu> "hcomp \<nu> (hcomp \<pi> \<rho>)"] chine_hcomp_ide_ide \<mu>\<nu>.composable
         by simp
     qed
 
     lemma cospan_\<mu>0_H\<nu>H\<pi>\<rho>1:
     shows "C.cospan \<mu>.leg0 H\<nu>H\<pi>\<rho>.leg1"
-    proof -
-      have "H\<nu>H\<pi>\<rho>.leg1 = \<nu>.leg1 \<cdot> \<nu>\<pi>\<rho>.Prj\<^sub>1"
-        using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable \<pi>\<rho>.composable
-        apply auto
-        by (auto simp add: hcomp_def)
-      thus ?thesis
-        using \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan \<pi>\<rho>.legs_form_cospan by simp
-    qed
+      by (metis C.cod_comp H\<nu>H\<pi>\<rho>.dom.leg_simps(3) \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.leg1_composite(1))
  
     (* TODO: Better name for this. *)
     lemma assoc_in_homs:
     shows "\<guillemotleft>\<mu> \<star> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
     and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> : (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
     and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
     and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) : (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
     and "\<guillemotleft>assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<guillemotright>"
     proof -
       show "\<guillemotleft>\<mu> \<star> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
         using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
       show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> : (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
         using assoc_in_hom \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by simp
       show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
         using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
       show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) : (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
         using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
         by auto
       show "\<guillemotleft>assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<guillemotright>"
         using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
     qed
 
     lemma chine_composites:
     shows "Chn (\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
     and "Chn (assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho>) = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc"
     and "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>) = chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
     and "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>)) = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc"
     and "Chn (assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>) = \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
     proof -
       show "Chn (\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
         using hcomp_def [of \<mu> "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>"] chine_hcomp_def [of \<mu> "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>"]
               \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
         by auto
       show "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>) = chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
         using assoc_in_homs(2-3) hcomp_def
         by (metis arrI arrow_of_spans_data.select_convs(1) hseqE)
       show "Chn (assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho>) = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc"
         using hcomp_def
         by (meson arrow_of_spans_data.select_convs(1))
       show "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>)) = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc"
         using hcomp_def
         by (meson arrow_of_spans_data.select_convs(1))
       show "Chn (assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>) = \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
         using hcomp_def
         by (meson arrow_of_spans_data.select_convs(1))
     qed
 
     lemma prj_in_homs [intro, simp]:
     shows "\<guillemotleft>\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<nu>\<pi>\<rho>.chine\<guillemotright>"
     and "\<guillemotleft>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] : H\<mu>H\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
     and "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
     and "\<guillemotleft>\<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<rho>.chine\<guillemotright>"
     and "\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
     and "\<guillemotleft>\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
     and "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
     and "\<guillemotleft>\<mu>_\<nu>\<pi>.prj\<^sub>0 : H\<mu>H\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>\<pi>.apex\<guillemotright>"
     proof -
       show "\<guillemotleft>\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<nu>\<pi>\<rho>.chine\<guillemotright>"
-      proof
-        show "C.cospan \<mu>.leg0 HH\<nu>\<pi>\<rho>.leg1"
-          using hcomp_def [of "hcomp \<nu> \<pi>" \<rho>] \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu> \<pi>\<rho>.composable \<nu>\<pi>_\<rho>.legs_form_cospan
-          by auto
-        show "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
-          using hcomp_def [of \<mu> "hcomp (hcomp \<nu> \<pi>) \<rho>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
-          by simp
-        show "HH\<nu>\<pi>\<rho>.chine = C.dom HH\<nu>\<pi>\<rho>.leg1"
-          by simp
-      qed
+        by (metis C.dom_comp C.prj0_in_hom' C.prj1_simps_arr HH\<nu>\<pi>\<rho>.chine_eq_apex
+            HH\<nu>\<pi>\<rho>.cod.apex_def HH\<nu>\<pi>\<rho>.cod.is_span HH\<nu>\<pi>\<rho>.cod_simps(1) HH\<nu>\<pi>\<rho>.cod_simps(3)
+            \<mu>_\<nu>\<pi>_\<rho>.prj_simps(10) \<mu>_\<nu>\<pi>_\<rho>.prj_simps(11) \<mu>_\<nu>\<pi>_\<rho>.prj_simps(14) \<nu>\<pi>_\<rho>.leg1_composite)
       show "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
-      proof
-        show "C.cospan assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1"
-          using hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] hcomp_def [of \<nu> \<pi>]
-          by (metis C.cod_comp H\<mu>H\<nu>\<pi>.cod.leg_simps(1) \<nu>\<pi>.cod_simps(2) \<mu>_\<nu>\<pi>.are_arrows(1)
-              \<mu>_\<nu>\<pi>.composable \<mu>_\<nu>\<pi>_\<rho>.cospan_\<nu>\<pi> \<nu>\<pi>.composite_is_arrow \<rho>.cod_simps(3)
-              arrow_of_spans_data.select_convs(3) span_data.select_convs(1))
-        show "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.cod.leg1"
-          using chines_eq(2) by simp
-        show "H\<mu>H\<nu>\<pi>.chine = C.dom assoc\<mu>\<nu>\<pi>.cod.leg0"
-          by auto
-      qed
+        using \<mu>\<nu>\<pi>.leg0_composite(1) \<mu>\<nu>_\<pi>_\<rho>.prj_simps(3) \<mu>_\<nu>\<pi>.leg0_composite 
+              \<mu>_\<nu>\<pi>_\<rho>.prj_simps(6)
+        by auto
       show "\<guillemotleft>\<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<rho>.chine\<guillemotright>"
-      proof
-        show "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
-          using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
-          by simp
-        show "HHH\<mu>\<nu>\<pi>\<rho>.chine = HH\<mu>\<nu>\<pi>.leg0 \<down>\<down> \<rho>.leg1"
-          using chine_hcomp_ide_ide hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] \<pi>\<rho>.composable
-          by simp
-        show "\<rho>.chine = C.dom \<rho>.leg1 " by simp
-      qed
+        by (simp add: \<mu>\<nu>_\<pi>.leg0_composite \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(3))
       show "\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
-      proof
-        show "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
-          using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
-          by simp
-        show "HHH\<mu>\<nu>\<pi>\<rho>.chine = HH\<mu>\<nu>\<pi>.leg0 \<down>\<down> \<rho>.leg1"
-          using chine_hcomp_ide_ide hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] \<pi>\<rho>.composable
-          by simp
-        show "HH\<mu>\<nu>\<pi>.chine = C.dom HH\<mu>\<nu>\<pi>.leg0" by simp
-      qed
+        using \<mu>\<nu>.leg0_composite \<mu>\<nu>_\<pi>.leg0_composite \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(2) by fastforce
       show "\<guillemotleft>\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
-      proof
-        show "C.cospan (\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0) \<rho>.leg1"
-          using \<mu>_\<nu>\<pi>.prj_in_hom(2) C.seqI' \<mu>_\<nu>\<pi>_\<rho>.cospan_\<nu>\<pi> by auto
-        show "HH\<mu>H\<nu>\<pi>\<rho>.chine = \<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<down>\<down> \<rho>.leg1"
-          using chines_eq(2) hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] \<mu>\<nu>.composable by simp
-        show "H\<mu>H\<nu>\<pi>.chine = C.dom (\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0)"
-          using \<mu>_\<nu>\<pi>.prj_in_hom(2) hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
-          by auto
-      qed
+        using \<mu>\<nu>\<pi>.leg0_composite(1) \<mu>_\<nu>\<pi>.leg0_composite \<mu>_\<nu>\<pi>_\<rho>.prj_simps(3)
+              \<mu>_\<nu>\<pi>_\<rho>.prj_simps(6)
+        by force
       show "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
-      proof
-        show "C.cospan assoc\<mu>\<nu>\<pi>.dom.leg0 \<rho>.leg1"
-          using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
-          by simp
-        show "HHH\<mu>\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.dom.leg0 \<down>\<down> \<rho>.leg1"
-          using hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] chine_hcomp_ide_ide \<pi>\<rho>.composable
-          by simp
-        show "HH\<mu>\<nu>\<pi>.chine = C.dom assoc\<mu>\<nu>\<pi>.dom.leg0"
-          using assoc\<mu>\<nu>\<pi>.dom.apex_def assoc\<mu>\<nu>\<pi>.chine_in_hom by fastforce
-      qed
+        using \<open>\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>\<close> by fastforce
       show "\<guillemotleft>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] : H\<mu>H\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
-        using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 chine_hcomp_ide_ide hcomp_def [of \<mu> "hcomp \<nu> (hcomp \<pi> \<rho>)"]
-              \<mu>\<nu>.composable
-        by auto
+        by (simp add: \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(4) \<nu>_\<pi>\<rho>.leg1_composite)
       show "\<guillemotleft>\<mu>_\<nu>\<pi>.prj\<^sub>0 : H\<mu>H\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>\<pi>.apex\<guillemotright>"
-        using \<mu>_\<nu>\<pi>.prj_in_hom(2) chine_hcomp_ide_ide hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] \<mu>\<nu>.composable
-        by simp
+        using \<mu>_\<nu>\<pi>.chine_composite \<mu>_\<nu>\<pi>.prj_in_hom(2) by presburger
     qed
 
     lemma chine_in_homs [intro, simp]:
     shows "\<guillemotleft>assoc\<mu>\<nu>\<pi>.chine : HH\<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
     and "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine : HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
     and "\<guillemotleft>chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
     and "\<guillemotleft>chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>H\<nu>\<pi>\<rho>.chine\<guillemotright>"
     proof -
       show 1: "\<guillemotleft>assoc\<mu>\<nu>\<pi>.chine : HH\<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
         using \<mu>\<nu>\<pi>.chine_assoc_in_hom by simp
       show "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine : HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
         using \<nu>\<pi>\<rho>.chine_assoc_in_hom by simp
       show "\<guillemotleft>chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
         using Chn_in_hom by (metis assoc_in_homs(1) chine_composites(1))
       show "\<guillemotleft>chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>H\<nu>\<pi>\<rho>.chine\<guillemotright>"
         using Chn_in_hom by (metis assoc_in_homs(3) chine_composites(3))
     qed
 
     lemma commutative_squares [intro, simp]:
     shows "C.commutative_square \<nu>\<pi>.leg0 \<rho>.leg1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
     and "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
     and "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
             (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
     and "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
             (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
     and "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
             (assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
             (\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
     and "C.commutative_square \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1
              \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
     and "C.commutative_square \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1
              \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
     proof -
       show 1: "C.commutative_square \<nu>\<pi>.leg0 \<rho>.leg1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
       proof -
         have 1: "C.arr \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 \<and> C.dom \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = HH\<mu>H\<nu>\<pi>\<rho>.chine \<and>
                  C.cod \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = \<rho>.apex"
           by (meson C.in_homE \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(3))
         hence "(\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0) \<cdot> \<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] = \<rho>.leg1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
           by (meson C.prj0_simps_arr C.pullback_commutes')
         thus ?thesis
           using 1 C.comp_assoc \<nu>\<pi>_\<rho>.legs_form_cospan(1) by simp
       qed
       show 2: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
       proof -
         have "\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>\<rho>.leg1] =
               \<pi>\<rho>.leg1 \<cdot> \<p>\<^sub>0[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>\<rho>.leg1]"
           by (metis (no_types) C.category_axioms C.prj0_simps_arr C.pullback_commutes'
               category.comp_reduce \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(3))
         thus ?thesis
           using C.commutative_square_def \<mu>_\<nu>_\<pi>\<rho>.cospan_\<nu>\<pi>
             \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(3) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(5) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(6)
             \<mu>_\<nu>_\<pi>\<rho>.prj_simps(8) \<nu>.dom.apex_def
           by presburger
       qed
       show "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
                   (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
         using assoc_in_homs(1) chine_hcomp_props(4) [of "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>" \<mu>] hseq_char by blast
       show "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
                   (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
         using chine_hcomp_props(3) [of "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>" \<mu>] hseq_char
               \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
         by auto
       show "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
                   (assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
                   (\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
         using assoc_in_homs(3) hseq_char chine_hcomp_props(2) by blast
       show "C.commutative_square \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1
               \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
       proof
         show "C.cospan \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1)"
           using HH\<nu>\<pi>\<rho>.dom.leg_simps(1) \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu> C.arrI by fastforce
         show "C.span \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
           using 1 \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(1) by auto
         show "C.dom \<mu>.leg0 = C.cod \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
           by simp
         show "\<mu>.leg0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 =
               (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
-        proof -
-          have "(\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> =
-                \<nu>\<pi>.leg1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
-            using 1 C.comp_assoc by auto
-          also have "... = \<mu>.leg0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
-            using hcomp_def [of \<nu> \<pi>]
-            by (metis (no_types, lifting) C.comp_assoc C.prj1_simps_arr C.pullback_commutes'
-                \<open>C.span \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>\<close> C.seqE)
-          finally show ?thesis by auto
-        qed
+          by (metis (no_types, lifting) "1" C.comp_assoc C.prj_tuple(2) C.pullback_commutes'
+              \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu>)
       qed
       show "C.commutative_square \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1
                \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
       proof
         show "C.cospan \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1)"
           using C.arrI \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(4) by auto
         show "C.span \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
           using 2 by fastforce
         thus "C.dom \<mu>.leg0 = C.cod \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1"
           using \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> by simp
         show "\<mu>.leg0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 =
               (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-        proof -
-          have "(\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
-                \<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-            using C.comp_assoc by auto
-          also have "... = \<nu>.leg1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1"
-            using 2 by simp
-          also have "... = \<mu>.leg0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1"
-            using C.pullback_commutes [of \<mu>.leg0 \<nu>.leg1]
-            by (metis C.comp_assoc C.pullback_commutes' \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu>)
-          finally show ?thesis by simp
-        qed
+          by (metis (no_types, lifting) "2" C.comp_assoc C.prj_tuple(2) C.pullback_commutes'
+              \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu>)
       qed
-
     qed
 
     lemma chine_pentagon:
     shows "Chn ((\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> \<bullet> (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>)) =
            Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>)"
     proof -
       let ?LHS = "(\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> \<bullet> (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>)"
       let ?RHS = "assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>"
 
       have LHS_in_hom: "\<guillemotleft>?LHS : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
         using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
       have RHS_in_hom: "\<guillemotleft>?RHS : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
         using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
 
-      have "arrow_of_spans (\<cdot>) ?LHS"
+      have 1: "arrow_of_spans (\<cdot>) ?LHS"
         using arr_char assoc_in_homs(1-3) by blast
 
       have L: "Chn ?LHS = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                             chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
-      proof -
-        have "seq (\<mu> \<star> \<lparr>Chn = \<nu>\<pi>\<rho>.chine_assoc, Dom = Dom ((\<nu> \<star> \<pi>) \<star> \<rho>),
-                        Cod = Cod (\<nu> \<star> \<pi> \<star> \<rho>)\<rparr>)
-                  (\<lparr>Chn = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc,
-                    Dom = Dom ((\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>), Cod = Cod (\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>)\<rparr> \<bullet>
-                  (\<lparr>Chn = \<mu>\<nu>\<pi>.chine_assoc,
-                    Dom = Dom ((\<mu> \<star> \<nu>) \<star> \<pi>), Cod = Cod (\<mu> \<star> \<nu> \<star> \<pi>)\<rparr> \<star> \<rho>))"
-          by (meson LHS_in_hom arrI)
-        moreover have "seq \<lparr>Chn = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc,
-                            Dom = Dom ((\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>), Cod = Cod (\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>)\<rparr>
-                       (\<lparr>Chn = \<mu>\<nu>\<pi>.chine_assoc,
-                         Dom = Dom ((\<mu> \<star> \<nu>) \<star> \<pi>), Cod = Cod (\<mu> \<star> \<nu> \<star> \<pi>)\<rparr> \<star> \<rho>)"
-          using assoc_in_homs(2) assoc_in_homs(3) by blast
-        ultimately show ?thesis
-          using Chn_vcomp chine_composites(1) chine_composites(2) chine_composites(3)
-          by presburger
-      qed
+        using Chn_vcomp 1 arr_char chine_composites(1) chine_composites(3) seq_char
+        by fastforce
       have R: "Chn ?RHS = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
         using Chn_vcomp assoc_in_homs(4) assoc_in_homs(5) seqI' by auto
 
       text \<open>
         The outline of the proof is to show that the compositions of \<open>?LHS\<close>
         and \<open>?RHS\<close> with the two projections \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> and
         \<open>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> are equal, and then apply \<open>\<nu>\<pi>\<rho>.prj'_joint_monic\<close>.
       \<close>
 
       text \<open>
         The case for projection \<open>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> does not have subcases,
         so we'll dispatch that one first.
       \<close>
 
       have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS = \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
       proof -
         have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
         proof -
           have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
                 \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                   chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
             using L by simp
           also have "... = \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                              chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
           proof -
             have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) =
                   \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
             proof -
               have "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
                      (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
                 by blast
               thus ?thesis by auto
             qed
             thus ?thesis
             using C.comp_permute [of "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" "chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
                                       \<mu>.chine "\<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
                                      "\<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
               by blast
           qed
           also have "... = \<mu>.chine \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
             using C.comp_reduce [of "\<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
                   \<nu>\<pi>_\<rho>.leg1_composite
             by fastforce
           also have "... = \<mu>.chine \<cdot> \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
           proof -
             have "\<mu>.chine \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                   \<mu>.chine \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using C.comp_assoc by simp
             also have "... = \<mu>.chine \<cdot> (\<mu>_\<nu>\<pi>.prj\<^sub>1 \<cdot> assoc\<mu>\<nu>\<pi>.chine) \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
             proof -
               have "\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                     assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
                 using chine_hcomp_props(6) [of \<rho> "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>"] hcomp_def [of \<mu> "hcomp \<nu> \<pi>"]
                       \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
                       hseq_char assoc_in_homs(3)
                 by auto
               thus ?thesis
                 using C.comp_assoc by auto
             qed
             also have "... = \<mu>.chine \<cdot> \<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
               using \<mu>\<nu>\<pi>.prj_chine_assoc(1) hcomp_def \<nu>\<pi>.composable by auto
             also have "... = \<mu>.chine \<cdot> \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
             proof -
               have "\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
-              proof -
-                have "\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] =
-                      (\<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<mu>\<nu>.leg0, \<pi>.leg1]) \<cdot> \<p>\<^sub>1[\<pi>.leg0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>0, \<rho>.leg1]"
-                proof -
-                  have "\<mu>\<nu>.leg0 = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0"
-                    using hcomp_def \<mu>\<nu>.composable by simp
-                  moreover have "assoc\<mu>\<nu>\<pi>.dom.leg0 = \<pi>.leg0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>0"
-                    using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable by auto
-                  ultimately show ?thesis by simp
-                qed
-                also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
-                  using \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(1) C.comp_assoc by simp
-                finally show ?thesis by blast
-              qed
+                by (simp add: C.comp_assoc \<mu>\<nu>.leg0_composite \<mu>\<nu>_\<pi>.leg0_composite)
               thus ?thesis by simp
             qed
             finally show ?thesis by blast
           qed
           also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
             using \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(1) hcomp_def [of \<mu> \<nu>] chine_hcomp_ide_ide \<mu>\<nu>.cod.apex_def
                   \<mu>\<nu>.composable \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> C.comp_ide_arr
             by auto
           finally show ?thesis by blast
         qed
         also have "... = \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
-        proof -
-          have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS =
-                \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-            using R by simp
-          also have "... = \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-            using C.comp_reduce [of "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" \<mu>_\<nu>_\<pi>\<rho>.chine_assoc]
-                  hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<mu>_\<nu>_\<pi>\<rho>.chine_assoc_def \<nu>\<pi>.composable
-            by fastforce
-          also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
-          proof -
-            have "\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc = (\<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1) \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-              using hcomp_def [of \<mu> \<nu>] hcomp_def [of \<pi> \<rho>] \<mu>\<nu>.composable \<pi>\<rho>.composable
-              by simp
-            also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-              using \<mu>\<nu>.dom.apex_def \<mu>\<nu>.dom.leg_simps(1) hcomp_def \<mu>\<nu>.composable
-                    \<mu>\<nu>.prj_in_hom(1) \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(4) C.comp_assoc
-              by auto
-            also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
-              by simp
-            finally show ?thesis by simp
-          qed
-          finally show ?thesis by simp
-        qed
+          by (metis C.comp_assoc R \<mu>\<nu>.leg0_composite \<mu>\<nu>_\<pi>_\<rho>.prj_chine_assoc(1)
+                    \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(1) \<nu>_\<pi>\<rho>.leg1_composite \<pi>\<rho>.leg1_composite)
         finally show ?thesis by blast
       qed
 
       text \<open>
         Now for the case of \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close>.
         We have to consider three sub-cases, involving the compositions with the projections
         \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<close>, \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0\<close>, and \<open>\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0\<close>.
       \<close>
 
       moreover have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
                      \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
       proof -
         (* Facts common to the three sub-cases. *)
         have A: "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc =
                 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
           using \<mu>_\<nu>\<pi>_\<rho>.chine_assoc_def \<nu>\<pi>_\<rho>.leg1_composite by auto
         have B: "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                  \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
         proof -
           have "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                 (\<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1]) \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
             using \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow hcomp_def by auto
           also have "... = \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] \<cdot>
                              chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
             using C.comp_assoc by simp
           also have "... = \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
           proof -
             have "HH\<mu>\<nu>\<pi>.leg0 = assoc\<mu>\<nu>\<pi>.dom.leg0"
               using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] by simp
             moreover have "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
                                (assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
                                (\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
               by blast
             ultimately show ?thesis
               using chine_hcomp_def [of "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>" \<rho>] by simp
           qed
           finally show ?thesis by blast
         qed
         have *: "assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                    chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                  \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
         proof -
           text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<close>:\<close>
           have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                   chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                 \<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
           proof -
             have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                   \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using \<nu>\<pi>\<rho>.chine_assoc_props(1) C.prj0_in_hom [of \<mu>.leg0 HH\<nu>\<pi>\<rho>.leg1] cospan_\<mu>0_H\<nu>H\<pi>\<rho>1
                     C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1 assoc\<nu>\<pi>\<rho>.chine \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1
                                       "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                                          chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
               by auto
             also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
                               chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
               by fastforce
             also have "... = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
-            proof -
-              have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
-              proof -
-                have "\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> \<nu>\<pi>.prj\<^sub>0"
-                  using hcomp_def \<nu>\<pi>.composable by simp
-                thus ?thesis
-                  using commutative_squares(1) C.arrI \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(2) \<nu>\<pi>\<rho>.prj_in_hom(1)
-                  by (simp add: C.comp_assoc)
-              qed
-              moreover have "C.seq \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
-                using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
-                      \<pi>\<rho>.composable \<nu>\<pi>\<rho>.prj_in_hom(1)
-                by auto
-              moreover have "C.seq \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>
-                                   (chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
-                by fastforce
-              ultimately show ?thesis
-                using C.comp_permute by blast
-            qed
+              by (metis A C.comp_assoc \<mu>_\<nu>\<pi>_\<rho>.prj_chine_assoc(2) \<nu>\<pi>.leg0_composite
+                        \<nu>\<pi>_\<rho>.leg1_composite)
             also have "... = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
               using B by simp
             also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
               using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable C.comp_assoc
                     C.comp_reduce [of \<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>0 \<mu>\<nu>\<pi>.chine_assoc \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 "\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
                     \<mu>\<nu>\<pi>.prj_in_hom(5) \<mu>\<nu>\<pi>.prj_chine_assoc(2)
               by auto
             also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot>
                              \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-            proof -
-              have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-                by blast
-              hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
-                           HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
-                using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
-              have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
-                     \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-                using 1 2 \<pi>\<rho>.composable hcomp_def [of \<pi> \<rho>]
-                      C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1 "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-                                        \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
-                by fastforce
-              also have "... = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
-              proof -
-                have "\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1"
-                  using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable by simp
-                thus ?thesis
-                  using C.comp_reduce C.comp_assoc by auto
-              qed
-              also have "... = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-                using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable by simp
-              also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-              proof -
-                have 1: "\<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>1 = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1"
-                  using hcomp_def \<mu>\<nu>.composable by simp
-                moreover have 2: "C.seq \<mu>\<nu>.prj\<^sub>0 \<mu>\<nu>_\<pi>.prj\<^sub>1"
-                  using 1 by fastforce
-                moreover have "C.seq \<mu>\<nu>_\<pi>.prj\<^sub>1 \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-                  by (metis 1 2 C.match_1 C.seqI' \<mu>\<nu>\<pi>.prj_in_hom(2) prj_in_homs(5))
-                ultimately show ?thesis
-                  using C.comp_reduce by simp
-              qed
-              finally show ?thesis by simp
-            qed
+              by (metis (no_types, lifting) C.comp_assoc C.prj_tuple(2) \<mu>\<nu>.leg0_composite
+                  \<mu>\<nu>\<pi>.leg0_composite(2) \<mu>\<nu>_\<pi>_\<rho>.prj_chine_assoc(1) \<pi>\<rho>.leg1_composite
+                  commutative_squares(2))
             finally show ?thesis by simp
           qed
           moreover
           text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0\<close>:\<close>
           have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                   chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                 \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
           proof -
             have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                   \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 "assoc\<nu>\<pi>\<rho>.chine" \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1
                                       "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                                          chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
               by auto
             also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
                               chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
               by fastforce
             also have "... = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
-            proof -
-              have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> =
-                    \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
-                using commutative_squares(1) C.arrI \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(2) \<nu>\<pi>\<rho>.prj_in_hom(2)
-                      C.comp_assoc \<nu>\<pi>.leg0_composite
-                by auto
-              moreover have "C.seq \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
-                using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
-                      \<pi>\<rho>.composable \<nu>\<pi>\<rho>.prj_in_hom(2)
-                by auto
-              moreover have "C.seq \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>
-                                   (chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
-                by fastforce
-              ultimately show ?thesis
-                using C.comp_permute by blast
-            qed
+              by (metis A C.comp_assoc \<mu>_\<nu>\<pi>_\<rho>.prj_chine_assoc(2) \<nu>\<pi>.leg0_composite
+                        \<nu>\<pi>_\<rho>.leg1_composite)
             also have "... = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
               using B by simp
             also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
               using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable \<mu>\<nu>\<pi>.prj_in_hom(6)
                     C.comp_reduce [of \<nu>\<pi>.prj\<^sub>0 \<mu>_\<nu>\<pi>.prj\<^sub>0 \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0
                                       "\<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
                     C.comp_reduce [of \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0 \<mu>\<nu>\<pi>.chine_assoc \<mu>\<nu>\<pi>.Prj\<^sub>0
                                       "\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
               by fastforce
             also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot>
                              \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-            proof -
-              have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-                by blast
-              hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
-                            HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
-                using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
-              have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> = \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-              proof -
-                have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
-                      \<pi>\<rho>.prj\<^sub>1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-                proof -
-                  have "\<pi>\<rho>.prj\<^sub>1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0"
-                    using hcomp_def [of \<pi> \<rho>] \<pi>\<rho>.composable by simp
-                  moreover have "C.seq \<pi>\<rho>.prj\<^sub>1
-                                       (\<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>)"
-                    using 2 hcomp_def [of \<pi> \<rho>] \<nu>\<pi>\<rho>.chine_composite(2) \<nu>\<pi>\<rho>.prj_in_hom(5)
-                          \<pi>\<rho>.composable
-                    by auto
-                  ultimately show ?thesis
-                    using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>1 \<nu>_\<pi>\<rho>.prj\<^sub>0 \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0
-                                              "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"]
-                    by auto
-                qed
-                also have "... = \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-                  using 1 by simp
-                finally show ?thesis by blast
-              qed
-              hence "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot>
-                       \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
-                     \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-                using 2 C.comp_permute by blast
-              also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-             proof -
-                have "\<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0"
-                  using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable by simp
-                thus ?thesis
-                  using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
-                  by auto
-              qed
-              also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
-                by simp
-              also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-                using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] hcomp_def [of \<mu> \<nu>] \<mu>\<nu>.composite_is_arrow
-                      \<mu>\<nu>_\<pi>.composable
-                by auto
-              finally show ?thesis by simp
-            qed
+              by (metis C.comp_assoc C.tuple_prj \<mu>\<nu>.leg0_composite \<mu>\<nu>_\<pi>.leg0_composite
+                        \<mu>\<nu>_\<pi>_\<rho>.prj_chine_assoc(2) \<mu>_\<nu>_\<pi>\<rho>.cospan_\<nu>\<pi> \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(2)
+                        \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(3) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<pi>\<rho>.leg1_composite)
             finally show ?thesis by blast
           qed
           moreover
           text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0\<close>:\<close>
           have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                   chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                 \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
           proof -
             have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
                   \<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                     chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 assoc\<nu>\<pi>\<rho>.chine \<nu>\<pi>\<rho>.Prj\<^sub>0
                                       "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                                          chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
               by fastforce
             also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
                               chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
               using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
               by fastforce
             also have "... = \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
-            proof -
-              have "\<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> = \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
-              proof -
-                have "\<nu>\<pi>\<rho>.Prj\<^sub>0 = \<nu>\<pi>_\<rho>.prj\<^sub>0"
-                  using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable by simp
-                thus ?thesis by simp
-              qed
-              thus ?thesis
-                using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
-                      \<pi>\<rho>.composable \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(3) calculation
-                      C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>0 "\<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
-                                        \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 "chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
-                by fastforce
-            qed
+              by (metis A C.comp_assoc \<mu>_\<nu>\<pi>_\<rho>.prj_chine_assoc(3) \<nu>\<pi>.leg0_composite
+                        \<nu>\<pi>_\<rho>.leg1_composite)
             also have "... = \<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
             proof -
               have "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1]"
                 using \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow hcomp_def by auto
               thus ?thesis
                 using chine_hcomp_props(5) [of \<rho> "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>"]
                       \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
                 by simp
             qed
             also have "... = \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-            proof -
-              have "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
-                using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable prj_in_homs(5) by blast
-              hence "\<rho>.chine = C.cod \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-                using C.prj0_simps [of HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1] by simp
-              thus ?thesis
-                using C.comp_cod_arr hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable
-                      HH\<mu>\<nu>\<pi>.dom.leg_simps(1) \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
-                by simp
-            qed
+              by (metis C.comp_cod_arr C.in_homE arrow_of_spans_data.select_convs(2)
+                        prj_in_homs(4))
             also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot>
                              \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-            proof -
-              have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-                by blast
-              hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
-                           HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
-                using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
-              have
-                "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
-                 \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-              proof -
-                have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
-                      \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-                proof -
-                  have
-                    "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
-                     \<pi>\<rho>.prj\<^sub>0 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-                  proof -
-                    have 3: "\<pi>\<rho>.prj\<^sub>0 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0"
-                      using hcomp_def [of \<pi> \<rho>] \<pi>\<rho>.composable by simp
-                    moreover have "C.seq \<pi>\<rho>.prj\<^sub>0
-                                         (\<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>)"
-                      using 1 2 3 hcomp_def [of \<pi> \<rho>] \<nu>\<pi>\<rho>.chine_composite(2)
-                            \<pi>\<rho>.composable
-                      by (metis C.arrI C.match_4 C.prj_tuple(1) \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(3)
-                          \<nu>\<pi>\<rho>.prj_in_hom(6))
-                    ultimately show ?thesis
-                      using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>0 \<nu>_\<pi>\<rho>.prj\<^sub>0 \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0
-                                                "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"]
-                      by auto
-                  qed
-                  also have "... = \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
-                    using 1 by simp
-                  finally show ?thesis by blast
-                qed
-                thus ?thesis
-                  using 2 C.comp_permute [of \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-                                             \<pi>\<rho>.prj\<^sub>0 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
-                  by blast
-              qed
-              also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-                using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable C.comp_assoc \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
-                      C.comp_reduce [of \<pi>\<rho>.prj\<^sub>0 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
-                by auto
-              also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0"
-                by simp
-              also have "... = \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
-                using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] hcomp_def [of \<mu> \<nu>]
-                      \<mu>\<nu>.composite_is_arrow \<mu>\<nu>_\<pi>.composable
-                by auto
-              finally show ?thesis by simp
-            qed
+              by (metis C.comp_assoc C.tuple_prj \<mu>\<nu>.leg0_composite \<mu>\<nu>_\<pi>.leg0_composite
+                        \<mu>\<nu>_\<pi>_\<rho>.prj_chine_assoc(3) \<mu>_\<nu>_\<pi>\<rho>.cospan_\<nu>\<pi> \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(2)
+                        \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(3) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<pi>\<rho>.leg1_composite)
             finally show ?thesis by blast
           qed
           moreover have "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                             chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
             using \<nu>\<pi>\<rho>.chine_assoc_props(1) by fast
           moreover have "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc :
                             HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
           proof -
             have "\<guillemotleft>\<mu>\<nu>_\<pi>_\<rho>.chine_assoc : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>H\<pi>\<rho>.chine\<guillemotright>"
               using \<mu>\<nu>_\<pi>_\<rho>.chine_assoc_props(1) by blast
             moreover have "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
                               HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
               using chine_hcomp_ide_ide hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable by auto
             ultimately show ?thesis by blast
           qed
           ultimately show ?thesis
             using \<nu>\<pi>\<rho>.prj'_joint_monic
                     [of "assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                            chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
                         HHH\<mu>\<nu>\<pi>\<rho>.chine
                         "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"]
             by simp
         qed
 
         text \<open>
           Now use fact \<open>*\<close> to finish off the \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> case.
         \<close>
         have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
               assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                 chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
         proof -
           have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
                 \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                   chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
             using L by simp
           also have "... = assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
                              chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
           proof -
             have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) =
                   assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
             proof -
               have "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
                       (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
                 by blast
               thus ?thesis
                 using \<nu>\<pi>\<rho>.chine_assoc_props(1) by auto
             qed
             moreover have "C.seq \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>))"
               using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 prj_in_homs(2) by fastforce
             moreover have "C.seq (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>))
                                  (\<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
               by blast
             ultimately show ?thesis
               using chine_hcomp_props(4) C.comp_permute by auto
           qed
           finally show ?thesis by blast
         qed
         also have "... = \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
           using * by simp
         also have "... = \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
-        proof -
-          have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS =
-                \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-            using R by simp
-          also have "... = \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
-          proof -
-            have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc =
-                  \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-              using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable \<mu>_\<nu>_\<pi>\<rho>.chine_assoc_def by auto
-            thus ?thesis
-              using C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" \<mu>_\<nu>_\<pi>\<rho>.chine_assoc
-                                      "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
-                                      \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
-              by fastforce
-          qed
-          finally show ?thesis by simp
-        qed
+          by (metis C.comp_assoc C.tuple_prj R \<mu>_\<nu>_\<pi>\<rho>.cospan_\<nu>\<pi> \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(2)
+                    \<mu>_\<nu>_\<pi>\<rho>.prj_chine_assoc(3) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<nu>_\<pi>\<rho>.leg1_composite)
         finally show ?thesis by blast
       qed
       moreover have "C.seq \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (Chn ?LHS)"
         using LHS_in_hom Chn_in_hom by blast
       moreover have "C.seq \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (Chn ?RHS)"
         using RHS_in_hom Chn_in_hom by blast
       ultimately show "Chn ?LHS = Chn ?RHS"
         using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 C.prj_joint_monic by blast
     qed
 
   end
 
   context span_bicategory
   begin
 
     lemma pentagon:
     assumes "ide f" and "ide g" and "ide h" and "ide k"
     and "src f = trg g" and "src g = trg h" and "src h = trg k"
     shows "(f \<star> \<alpha>\<^sub>S\<^sub>B (g, h, k)) \<bullet> \<alpha>\<^sub>S\<^sub>B (f, g \<star> h, k) \<bullet> (\<alpha>\<^sub>S\<^sub>B (f, g, h) \<star> k) =
            \<alpha>\<^sub>S\<^sub>B (f, g, h \<star> k) \<bullet> \<alpha>\<^sub>S\<^sub>B (f \<star> g, h, k)"
     proof -
       interpret f: identity_arrow_of_spans C f
         using assms ide_char' by auto
       interpret g: identity_arrow_of_spans C g
         using assms ide_char' by auto
       interpret h: identity_arrow_of_spans C h
         using assms ide_char' by auto
       interpret k: identity_arrow_of_spans C k
         using assms ide_char' by auto
 
       interpret fghk: four_composable_identity_arrows_of_spans C prj0 prj1 f g h k
         using assms by (unfold_locales, auto)
 
       let ?LHS = "(f \<star> assoc\<^sub>S\<^sub>B g h k) \<bullet> (assoc\<^sub>S\<^sub>B f (g \<star> h) k) \<bullet> (assoc\<^sub>S\<^sub>B f g h \<star> k)"
       let ?RHS = "assoc\<^sub>S\<^sub>B f g (h \<star> k) \<bullet> assoc\<^sub>S\<^sub>B (f \<star> g) h k"
 
       have "(f \<star> \<alpha>\<^sub>S\<^sub>B (g, h, k)) \<bullet> \<alpha>\<^sub>S\<^sub>B (f, g \<star> h, k) \<bullet> (\<alpha>\<^sub>S\<^sub>B (f, g, h) \<star> k) = ?LHS"
         using assms \<alpha>_ide ide_hcomp src_hcomp trg_hcomp by simp
       also have "... = ?RHS"
         using fghk.\<mu>\<nu>.composable fghk.\<nu>\<pi>.composable fghk.\<pi>\<rho>.composable fghk.chine_pentagon
         by (intro arr_eqI, auto)
       also have "... = \<alpha>\<^sub>S\<^sub>B (f, g, h \<star> k) \<bullet> \<alpha>\<^sub>S\<^sub>B (f \<star> g, h, k)"
         using assms \<alpha>_ide ide_hcomp src_hcomp trg_hcomp by simp
       finally show ?thesis by blast
     qed
 
     lemma extends_to_bicategory:
     shows "bicategory vcomp hcomp assoc unit src trg"
       using unit_in_hom obj_char iso_unit assoc_def pentagon
       apply unfold_locales by auto
 
     sublocale bicategory vcomp hcomp assoc unit src trg
       using extends_to_bicategory by auto
 
-  end
-
   subsection "Miscellaneous Formulas"
 
-  context span_bicategory
-  begin
-
     no_notation in_hom    ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation in_hom       ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
 
     notation lunit        ("\<l>[_]")
     notation runit        ("\<r>[_]")
     notation lunit'       ("\<l>\<^sup>-\<^sup>1[_]")
     notation runit'       ("\<r>\<^sup>-\<^sup>1[_]")
     notation assoc        ("\<a>[_, _, _]")
     notation \<a>'           ("\<a>\<^sup>-\<^sup>1[_, _, _]")
 
     lemma \<alpha>'_ide:
     assumes "ide f" and "ide g" and "ide h"
     and "src f = trg g" and "src g = trg h"
     shows "\<alpha>' (f, g, h) = assoc'\<^sub>S\<^sub>B f g h"
     proof -
       have fgh: "VVV.ide (f, g, h)"
         using assms VVV.ide_char VVV.arr_char VV.arr_char by simp
       interpret f: arrow_of_spans C f
         using assms arr_char [of f] by auto
       interpret g: arrow_of_spans C g
         using assms arr_char [of g] by auto
       interpret h: arrow_of_spans C h
         using assms arr_char [of h] by auto
       interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
         using assms by (unfold_locales, auto)
       interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
         using assms ide_char by (unfold_locales, auto)
       have "\<alpha>' (f, g, h) = inv (\<alpha> (f, g, h))"
         using fgh \<alpha>'.inverts_components
         by (simp add: \<alpha>_def)
       moreover have "inv (\<alpha> (f, g, h)) = \<lparr>Chn = C.inv (Chn (\<alpha> (f, g, h))),
                                           Dom = Cod (\<alpha> (f, g, h)),
                                           Cod = Dom (\<alpha> (f, g, h))\<rparr>"
         using fgh \<alpha>.components_are_iso inv_eq
         by (simp add: \<alpha>_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable)
       moreover have "... = assoc'\<^sub>S\<^sub>B f g h"
         using assms fgh \<alpha>_ide [of f g h] fgh.chine_assoc_inverse C.inverse_unique
         by (simp add: \<alpha>_def)
       ultimately show ?thesis by simp
     qed
 
     text \<open>
       The following give explicit expressions for the unitors,
       derived from their characterizing properties and the definition of the associators.
     \<close>
 
     lemma runit_ide_eq:
     assumes "ide f"
     shows "\<r>[f] = \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
                    Dom = \<lparr>Leg0 = \<p>\<^sub>0[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
                           Leg1 = Leg1 (Dom f) \<cdot> \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))]\<rparr>,
                    Cod = Cod f\<rparr>"
     proof -
       interpret f: identity_arrow_of_spans C f
         using assms ide_char' by auto
       interpret src: identity_arrow_of_spans C \<open>src f\<close>
         using assms ide_char' ide_src by auto
       interpret f_src: two_composable_identity_arrows_of_spans C prj0 prj1 f \<open>src f\<close>
         using assms by (unfold_locales, simp)
       interpret src_src: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>src f\<close> \<open>src f\<close>
         by (unfold_locales, simp)
       interpret f_src_src: three_composable_identity_arrows_of_spans C prj0 prj1 f \<open>src f\<close> \<open>src f\<close>
         ..
 
       let ?rf = "\<lparr>Chn = \<p>\<^sub>1[f.leg0, f.dsrc],
                   Dom = \<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>,
                   Cod = Cod f\<rparr>"
       have "?rf = \<r>[f]"
       proof (intro runit_eqI)
         show "ide f" by fact
         interpret rf: arrow_of_spans C ?rf
         proof -
           interpret dom_rf: span_in_category C
                               \<open>\<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>\<close>
             by (unfold_locales, simp_all)
           show "arrow_of_spans C ?rf"
             using dom_rf.apex_def C.comp_cod_arr C.pullback_commutes [of f.leg0 f.dsrc]
             apply unfold_locales by auto
         qed
         show rf_in_hom: "\<guillemotleft>?rf : f \<star> src f \<Rightarrow> f\<guillemotright>"
         proof
           show "arr ?rf"
             using rf.arrow_of_spans_axioms arr_char by simp
           show "cod ?rf = f"
             using cod_char rf.arrow_of_spans_axioms arr_char by simp
           show "dom ?rf = f \<star> src f"
             using dom_char rf.arrow_of_spans_axioms src.arrow_of_spans_axioms arr_char hcomp_def
                   f.arrow_of_spans_axioms f_src.composable chine_hcomp_ide_ide src_def ide_char
                   C.comp_cod_arr rf.dom.apex_def
             by simp
         qed
         show "?rf \<star> src f = (f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]"
         proof (intro arr_eqI)
           show par: "par (?rf \<star> src f) ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
           proof -
             have "\<guillemotleft>?rf \<star> src f : (f \<star> src f) \<star> src f \<Rightarrow> f \<star> src f\<guillemotright>"
-            proof -
-              have "?rf \<star> src f = R ?rf"
-                using assms rf_in_hom src_def trg_def arr_char rf.arrow_of_spans_axioms
-                      f.arrow_of_spans_axioms
-                by simp
-              moreover have "\<guillemotleft>R ?rf : (f \<star> src f) \<star> src f \<Rightarrow> f \<star> src f\<guillemotright>"
-                using rf_in_hom R.preserves_hom [of ?rf "f \<star> src f" f] by simp
-              ultimately show ?thesis by auto
-            qed
+              using f_src_src.composites_are_arrows(2) rf_in_hom src_src.are_identities(1)
+              by blast
             thus ?thesis by auto
           qed
           show "Chn (?rf \<star> src f) = Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
           proof -
             have "Chn (?rf \<star> src f) = \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>0\<^sub>1\<rangle>"
             proof -
               have "Chn (?rf \<star> src f) =
                     \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> \<p>\<^sub>0[f_src.prj\<^sub>0, src.leg1]\<rangle>"
                 using assms src_def trg_def hcomp_def arr_char ide_char
                       rf.arrow_of_spans_axioms src.identity_arrow_of_spans_axioms
                       chine_hcomp_arr_ide C.comp_cod_arr
                 by (simp add: f.arrow_of_spans_axioms identity_arrow_of_spans_def)
               moreover have "\<p>\<^sub>0[f_src.prj\<^sub>0, src.leg1] = f_src_src.Prj\<^sub>0\<^sub>1"
               proof -
                 have "src f = \<lparr>Chn = f.dsrc,
                                Dom = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>,
                                Cod = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<rparr>"
                   using assms src_def by simp
                 thus ?thesis
                   by (simp add: C.comp_cod_arr C.pullback_commutes')
               qed
               ultimately show ?thesis by auto
             qed
             also have "... = Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
             proof -
               have "Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]) =
                     \<langle>f_src_src.Prj\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>1\<^sub>0\<rangle> \<cdot> f_src_src.chine_assoc"
               proof -
                 have "Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]) =
                       Chn (f \<star> \<i>[src f]) \<cdot> Chn \<a>[f, src f, src f]"
                   using par vcomp_eq [of "f \<star> \<i>[src f]" "\<a>[f, src f, src f]"]
                   by simp
                 moreover have "Chn (f \<star> \<i>[src f]) =
                                \<langle>f_src_src.Prj\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>1\<^sub>0\<rangle>"
                 proof -
                   have "\<i>[src f] = \<lparr>Chn = \<p>\<^sub>1[f.dsrc, f.dsrc],
                                    Dom = \<lparr>Leg0 = \<p>\<^sub>1[f.dsrc, f.dsrc], Leg1 = \<p>\<^sub>1[f.dsrc, f.dsrc]\<rparr>,
                                    Cod = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<rparr>"
                     using unit_def src_def trg_def hcomp_def src.arrow_of_spans_axioms arr_char
                           f.arrow_of_spans_axioms C.comp_cod_arr
                     by simp
                   moreover have "arrow_of_spans C \<i>[src f]"
                     using assms arr_char [of "\<i>[src f]"] by simp
                   ultimately show ?thesis
                     using assms unit_def hcomp_def chine_hcomp_ide_arr
                           rf.arrow_of_spans_axioms src.arrow_of_spans_axioms
                           f.arrow_of_spans_axioms arr_char C.comp_cod_arr
                           src_def trg_def
                     by simp
                 qed
                 ultimately show ?thesis
                   using \<alpha>_ide by simp
               qed
               also have "... = \<langle>f_src_src.Prj\<^sub>1 \<cdot> f_src_src.chine_assoc
                                   \<lbrakk>f.leg0, src.leg1\<rbrakk>
                                 f_src_src.Prj\<^sub>1\<^sub>0 \<cdot> f_src_src.chine_assoc\<rangle>"
-              proof -
-                have "C.commutative_square f.leg0 src.leg1 f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0"
-                proof
-                  show "C.cospan f.leg0 src.leg1"
-                    using f_src.legs_form_cospan(1) by auto
-                  show "C.span f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0"
-                    using f_src_src.prj_in_hom(5) by auto
-                  show "C.dom f.leg0 = C.cod f_src_src.Prj\<^sub>1"
-                    by simp
-                  show "f.leg0 \<cdot> f_src_src.Prj\<^sub>1 = src.leg1 \<cdot> f_src_src.Prj\<^sub>1\<^sub>0"
-                    using C.pullback_commutes' \<open>C.span f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0\<close>
-                          C.comp_assoc
-                    by auto
-                qed
-                moreover have "C.seq f_src_src.Prj\<^sub>1 f_src_src.chine_assoc"
-                  by blast
-                ultimately show ?thesis
-                  using C.comp_tuple_arr by auto
-              qed
+                using C.comp_assoc C.comp_tuple_arr C.pullback_commutes'
+                      f_src_src.cospan_\<mu>\<nu> f_src_src.cospan_\<nu>\<pi>
+                by simp
               also have "... = \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>0\<^sub>1\<rangle>"
                 by simp
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
         qed
       qed
       thus ?thesis by simp
     qed
 
     lemma lunit_ide_eq:
     assumes "ide f"
     shows "\<l>[f] = \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
                    Dom = \<lparr>Leg0 = Leg0 (Dom f) \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
                           Leg1 = \<p>\<^sub>1[C.cod (Leg1 (Dom f)), Leg1 (Dom f)]\<rparr>,
                    Cod = Cod f\<rparr>"
     proof -
       interpret f: identity_arrow_of_spans C f
         using assms ide_char' by auto
       interpret trg: identity_arrow_of_spans C \<open>trg f\<close>
         using assms ide_char' ide_trg by auto
       interpret trg_f: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> f
         using assms by (unfold_locales, simp)
       interpret trg_trg: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> \<open>trg f\<close>
         by (unfold_locales, simp)
       interpret trg_trg_f: three_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> \<open>trg f\<close> f
         ..
 
       let ?lf = "\<lparr>Chn = \<p>\<^sub>0[f.dtrg, f.leg1],
                   Dom = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>,
                   Cod = Cod f\<rparr>"
       have "?lf = \<l>[f]"
       proof (intro lunit_eqI)
         show "ide f" by fact
         interpret lf: arrow_of_spans C ?lf
         proof -
           interpret dom_lf: span_in_category C
                               \<open>\<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>\<close>
             by (unfold_locales, simp_all)
           show "arrow_of_spans C ?lf"
             using dom_lf.apex_def C.comp_cod_arr C.pullback_commutes [of f.dtrg f.leg1]
             apply unfold_locales by auto
         qed
         show lf_in_hom: "\<guillemotleft>?lf : trg f \<star> f \<Rightarrow> f\<guillemotright>"
         proof
           show "arr ?lf"
             using lf.arrow_of_spans_axioms arr_char by simp
           show "cod ?lf = f"
             using cod_char lf.arrow_of_spans_axioms arr_char by simp
           show "dom ?lf = trg f \<star> f"
             using dom_char lf.arrow_of_spans_axioms trg.arrow_of_spans_axioms arr_char hcomp_def
                   f.arrow_of_spans_axioms trg_f.composable chine_hcomp_ide_ide trg_def ide_char
                   C.comp_cod_arr lf.dom.apex_def
             by simp
         qed
         show "trg f \<star> ?lf = (\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
         proof (intro arr_eqI)
           show par: "par (trg f \<star> ?lf) ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
           proof -
             have "\<guillemotleft>trg f \<star> ?lf : trg f \<star> (trg f \<star> f) \<Rightarrow> trg f \<star> f\<guillemotright>"
             proof -
               have "trg f \<star> ?lf = L ?lf"
                 using assms lf_in_hom src_def trg_def arr_char lf.arrow_of_spans_axioms
                       f.arrow_of_spans_axioms
                 by simp
               moreover have "\<guillemotleft>L ?lf : trg f \<star> (trg f \<star> f) \<Rightarrow> trg f \<star> f\<guillemotright>"
                 using lf_in_hom L.preserves_hom [of ?lf "trg f \<star> f" f] by simp
               ultimately show ?thesis by auto
             qed
             thus ?thesis by auto
           qed
           show "Chn (trg f \<star> ?lf) = Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
           proof -
             have "Chn (trg f \<star> ?lf) = \<langle>trg_trg_f.Prj\<^sub>1\<^sub>0 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
             proof -
               have "Chn (trg f \<star> ?lf) =
                     \<langle>\<p>\<^sub>1[trg.leg0, trg_f.prj\<^sub>1] \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
                 using assms src_def trg_def hcomp_def arr_char ide_char
                       lf.arrow_of_spans_axioms trg.identity_arrow_of_spans_axioms
                       chine_hcomp_ide_arr C.comp_cod_arr
                 by (simp add: f.arrow_of_spans_axioms identity_arrow_of_spans_def)
               moreover have "\<p>\<^sub>1[trg.leg0, trg_f.prj\<^sub>1] = trg_trg_f.Prj\<^sub>1\<^sub>0"
               proof -
                 have "trg f = \<lparr>Chn = f.dtrg,
                                Dom = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>,
                                Cod = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<rparr>"
                   using assms trg_def by simp
                 thus ?thesis
                   apply (simp add: C.comp_cod_arr C.pullback_commutes')
                   by (metis C.comp_cod_arr C.pullback_commutes' select_convs(1) select_convs(2)
                       select_convs(3) f.cod_simps(3) lf.cod_trg_eq_dom_trg lf.dom.leg_simps(3)
                       span_data.select_convs(1) span_data.select_convs(2) trg.chine_eq_apex
                       trg_trg_f.cospan_\<nu>\<pi> trg_trg_f.prj_simps(10) trg_trg_f.prj_simps(16))
               qed
               ultimately show ?thesis by auto
             qed
             also have "... = Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
             proof -
               have "Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]) =
                     \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<rangle> \<cdot> trg_trg_f.chine_assoc'"
               proof -
                 have "Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]) =
                       Chn (\<i>[trg f] \<star> f) \<cdot> Chn \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
                   using par vcomp_eq [of "\<i>[trg f] \<star> f" "\<a>\<^sup>-\<^sup>1[trg f, trg f, f]"]
                   by simp
                 moreover have "Chn (\<i>[trg f] \<star> f) =
                                \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<rangle>"
                 proof -
                   have "\<i>[trg f] = \<lparr>Chn = \<p>\<^sub>1[f.dtrg, f.dtrg],
                                    Dom = \<lparr>Leg0 = \<p>\<^sub>1[f.dtrg, f.dtrg], Leg1 = \<p>\<^sub>1[f.dtrg, f.dtrg]\<rparr>,
                                    Cod = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<rparr>"
                     using unit_def src_def trg_def hcomp_def trg.arrow_of_spans_axioms arr_char
                           f.arrow_of_spans_axioms C.comp_cod_arr
                     by simp
                   moreover have "arrow_of_spans C \<i>[trg f]"
                     using assms arr_char [of "\<i>[trg f]"] by simp
                   ultimately show ?thesis
                     using assms unit_def hcomp_def chine_hcomp_arr_ide
                           lf.arrow_of_spans_axioms trg.arrow_of_spans_axioms
                           f.arrow_of_spans_axioms arr_char C.comp_cod_arr
                           src_def trg_def
                     by simp
                 qed
                 moreover have "Chn \<a>\<^sup>-\<^sup>1[trg f, trg f, f] = trg_trg_f.chine_assoc'"
                 proof -
                   have "iso (\<alpha> (trg f, trg f, f))"
-                  proof -
-                    have "VVV.ide (trg f, trg f, f)"
-                      using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
-                      by auto
-                    thus ?thesis
-                      using \<alpha>_def \<alpha>.components_are_iso [of "(trg f, trg f, f)"] by simp
-                  qed
+                    by (simp add: \<alpha>_def)
                   moreover have "C.inv trg_trg_f.chine_assoc = trg_trg_f.chine_assoc'"
                     using trg_trg_f.chine_assoc_inverse C.inv_is_inverse C.inverse_arrow_unique
                     by auto
                   ultimately show ?thesis
                     using assms by (simp add: \<a>'_def \<alpha>'_ide)
                 qed
                 ultimately show ?thesis
                   by simp
               qed
               also have "... = \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<cdot> trg_trg_f.chine_assoc'
                                   \<lbrakk>trg.leg0, f.leg1\<rbrakk>
                                 trg_trg_f.Prj\<^sub>0 \<cdot> trg_trg_f.chine_assoc'\<rangle>"
               proof -
                 have "C.commutative_square trg.leg0 f.leg1 trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0"
                 proof
                   show "C.cospan trg.leg0 f.leg1"
                     using trg_f.legs_form_cospan(1) by auto
                   show "C.span trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0"
                     using trg_trg_f.prj_in_hom by auto
                   show "C.dom trg.leg0 = C.cod trg_trg_f.Prj\<^sub>0\<^sub>1"
                     by simp
                   show "trg.leg0 \<cdot> trg_trg_f.Prj\<^sub>0\<^sub>1 = f.leg1 \<cdot> trg_trg_f.Prj\<^sub>0"
                     by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
                         \<open>C.span trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0\<close>)
                 qed
                 moreover have "C.seq trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.chine_assoc'"
                   by blast
                 ultimately show ?thesis
                   using C.comp_tuple_arr [of trg.leg0 f.leg1 trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0
                                              trg_trg_f.chine_assoc']
                   by auto
               qed
               also have "... = \<langle>trg_trg_f.Prj\<^sub>1\<^sub>0 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
                 by simp
               finally show ?thesis by simp
             qed
             finally show ?thesis by blast
           qed
         qed
       qed
       thus ?thesis by simp
     qed
 
     lemma runit'_ide_eq:
     assumes "ide f"
     shows "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>Chn f \<lbrakk>Leg0 (Dom f), C.cod (Leg0 (Dom f))\<rbrakk> Leg0 (Dom f)\<rangle>,
                     Dom = Cod f,
                     Cod = \<lparr>Leg0 = \<p>\<^sub>0[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
                            Leg1 = Leg1 (Dom f) \<cdot> \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))]\<rparr>\<rparr>"
     proof -
       interpret f: identity_arrow_of_spans C f
         using assms ide_char' by auto
       show "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>, Dom = Cod f,
                      Cod = \<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>\<rparr>"
       proof -
         have "C.inverse_arrows \<p>\<^sub>1[f.leg0, f.dsrc] \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
-        proof
-          show "C.ide (\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc])"
-          proof -
-            have "\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] =
-                  \<langle>f.chine \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rangle>"
-              using assms C.comp_tuple_arr [of f.leg0 f.dsrc f.chine f.leg0 "\<p>\<^sub>1[f.leg0, f.dsrc]"]
-                    C.comp_arr_dom C.comp_cod_arr
-              by simp
-            also have "... = \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, f.dsrc\<rbrakk> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
-              using C.pullback_commutes [of f.leg0 f.dsrc] C.comp_cod_arr by auto
-            also have "... = f.leg0 \<down>\<down> f.dsrc"
-              by simp
-            finally have "\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = f.leg0 \<down>\<down> f.dsrc"
-              by blast
-            thus ?thesis by simp
-          qed
-          show "C.ide (\<p>\<^sub>1[f.leg0, f.dsrc] \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
-            using assms C.comp_arr_dom C.comp_cod_arr by auto
-        qed
+          using C.pullback_arr_cod(1) f.chine_eq_apex f.dom.apex_def f.dom.leg_simps(1)
+          by presburger
         hence "C.inv \<p>\<^sub>1[f.leg0, f.dsrc] = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
           using C.inv_is_inverse C.inverse_arrow_unique by auto
         hence "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>,
                         Dom = Cod \<r>[f], Cod = Dom \<r>[f]\<rparr>"
           using assms runit_ide_eq inv_eq [of "\<r>[f]"] iso_runit by simp
         thus ?thesis
           using assms runit_ide_eq by simp
       qed
     qed
 
     lemma lunit'_ide_eq:
     assumes "ide f"
     shows "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>Leg1 (Dom f) \<lbrakk>C.cod (Leg1 (Dom f)), Leg1 (Dom f)\<rbrakk> Chn f\<rangle>,
                     Dom = Cod f,
                     Cod = \<lparr>Leg0 = Leg0 (Dom f) \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
                            Leg1 = \<p>\<^sub>1[C.cod (Leg1 (Dom f)), Leg1 (Dom f)]\<rparr>\<rparr>"
     proof -
       interpret f: identity_arrow_of_spans C f
         using assms ide_char' by auto
       show "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>, Dom = Cod f,
                      Cod = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>\<rparr>"
       proof -
         have "C.inverse_arrows \<p>\<^sub>0[f.dtrg, f.leg1] \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>"
-        proof
-          show "C.ide (\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1])"
-          proof -
-            have "\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] =
-                  \<langle>f.leg1 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1]\<rangle>"
-              using assms C.comp_tuple_arr C.comp_arr_dom C.comp_cod_arr
-              by simp
-            also have "... = \<langle>\<p>\<^sub>1[f.dtrg, f.leg1] \<lbrakk>f.dtrg, f.leg1\<rbrakk> \<p>\<^sub>0[f.dtrg, f.leg1]\<rangle>"
-            proof -
-              have "f.leg1 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] = \<p>\<^sub>1[f.dtrg, f.leg1]"
-                using C.pullback_commutes [of f.dtrg f.leg1] C.comp_cod_arr by auto
-              thus ?thesis
-                using C.comp_cod_arr by simp
-            qed
-            also have "... = f.dtrg \<down>\<down> f.leg1"
-              by simp
-            finally have "\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] = f.dtrg \<down>\<down> f.leg1"
-              by blast
-            thus ?thesis by simp
-          qed
-          show "C.ide (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>)"
-            using assms C.comp_arr_dom C.comp_cod_arr by auto
-        qed
+          using C.pullback_arr_cod(2) f.chine_eq_apex f.dom.apex_def f.dom.is_span
+          by presburger
         hence "C.inv \<p>\<^sub>0[f.dtrg, f.leg1] = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>"
           using C.inv_is_inverse C.inverse_arrow_unique by auto
         hence "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>,
                         Dom = Cod \<l>[f], Cod = Dom \<l>[f]\<rparr>"
           using assms lunit_ide_eq inv_eq [of "\<l>[f]"] iso_lunit by simp
         thus ?thesis
           using assms lunit_ide_eq by simp
       qed
     qed
 
   end
 
   locale adjunction_data_in_span_bicategory =
      span_bicategory C prj0 prj1 +
      adjunction_data_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
   for C :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"         (infixr "\<cdot>" 55)
   and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<p>\<^sub>0[_, _]")
   and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<p>\<^sub>1[_, _]")
   and f :: "'a arrow_of_spans_data"
   and g :: "'a arrow_of_spans_data"
   and \<eta> :: "'a arrow_of_spans_data"
   and \<epsilon> :: "'a arrow_of_spans_data"
   begin
 
     interpretation f: identity_arrow_of_spans C f
       using ide_char' [of f] by auto
     interpretation g: identity_arrow_of_spans C g
       using ide_char' [of g] by auto
 
     interpretation gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
       using antipar by (unfold_locales, auto)
     interpretation fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
       using antipar by (unfold_locales, auto)
 
     interpretation fgf: three_composable_identity_arrows_of_spans C prj0 prj1 f g f ..
     interpretation gfg: three_composable_identity_arrows_of_spans C prj0 prj1 g f g ..
 
     interpretation \<eta>: arrow_of_spans C \<eta>
       using arr_char unit_in_hom by auto
     interpretation \<epsilon>: arrow_of_spans C \<epsilon>
       using arr_char counit_in_hom by auto
 
     lemma chine_unit_in_hom:
     shows "\<guillemotleft>\<eta>.chine : f.dsrc \<rightarrow>\<^sub>C g.leg0 \<down>\<down> f.leg1\<guillemotright>"
     proof -
       have "\<guillemotleft>\<eta>.chine : \<eta>.dom.apex \<rightarrow>\<^sub>C \<eta>.cod.apex\<guillemotright>"
         using \<eta>.chine_in_hom by simp
       moreover have "\<eta>.dom.apex = f.dsrc"
         using \<eta>.dom.apex_def dom_char unit_simps src_def by auto
       moreover have "\<eta>.cod.apex = g.leg0 \<down>\<down> f.leg1"
-      proof -
-        have "\<eta>.cod.apex = C.dom \<eta>.cod.leg0" by simp
-        also have "... = C.dom (f.leg0 \<cdot> \<p>\<^sub>0[g.leg0, f.leg1])"
-          using cod_char unit_simps hcomp_def gf.composable by simp
-        also have "... = g.leg0 \<down>\<down> f.leg1"
-          using fgf.cospan_\<nu>\<pi> by simp
-        finally show ?thesis by blast
-      qed
+        by (metis arrow_of_spans_data.select_convs(1) cod_char gf.chine_composite
+                  unit_simps(1,3))
       ultimately show ?thesis by simp
     qed
 
     lemma chine_counit_in_hom:
     shows "\<guillemotleft>\<epsilon>.chine : f.leg0 \<down>\<down> g.leg1 \<rightarrow>\<^sub>C f.dtrg\<guillemotright>"
     proof -
       have "\<guillemotleft>\<epsilon>.chine : \<epsilon>.dom.apex \<rightarrow>\<^sub>C \<epsilon>.cod.apex\<guillemotright>"
         using \<epsilon>.chine_in_hom by simp
       moreover have "\<epsilon>.cod.apex = f.dtrg"
         using \<epsilon>.cod.apex_def cod_char counit_simps trg_def gf.composable by auto
       moreover have "\<epsilon>.dom.apex = f.leg0 \<down>\<down> g.leg1"
-      proof -
-        have "\<epsilon>.dom.apex = C.dom \<epsilon>.dom.leg0" by simp
-        also have "... = C.dom (g.leg0 \<cdot> fg.prj\<^sub>0)"
-          using dom_char counit_simps hcomp_def fg.composable by simp
-        also have "... = f.leg0 \<down>\<down> g.leg1"
-          using fg.prj_in_hom(2) by auto
-        finally show ?thesis by blast
-      qed
+        by (metis Chn_in_hom \<epsilon>.chine_simps(2) category.in_homE counit_in_hom(2)
+                  fg.chine_composite span_vertical_category_axioms span_vertical_category_def)
       ultimately show ?thesis by simp
     qed
 
     lemma \<eta>_leg_simps:
     shows "\<eta>.dom.leg0 = f.dsrc" and "\<eta>.dom.leg1 = f.dsrc"
     and "\<eta>.cod.leg0 = gf.leg0" and "\<eta>.cod.leg1 = gf.leg1"
     proof -
       show "\<eta>.dom.leg0 = f.dsrc"
         using dom_char unit_simps(2) src_def by auto
       show "\<eta>.dom.leg1 = f.dsrc"
         using dom_char unit_simps(2) src_def by auto
       show "\<eta>.cod.leg0 = gf.leg0"
         using cod_char unit_simps(1,3)
         by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
       show "\<eta>.cod.leg1 = gf.leg1"
         using cod_char unit_simps(1,3)
         by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
     qed
 
     lemma \<epsilon>_leg_simps:
     shows "\<epsilon>.cod.leg0 = f.dtrg" and "\<epsilon>.cod.leg1 = f.dtrg"
     and "\<epsilon>.dom.leg0 = fg.leg0" and "\<epsilon>.dom.leg1 = fg.leg1"
     proof -
       show "\<epsilon>.cod.leg0 = f.dtrg"
         using cod_char counit_simps(3) trg_def gf.composable by auto
       show "\<epsilon>.cod.leg1 = f.dtrg"
         using cod_char counit_simps(3) trg_def gf.composable by auto
       show "\<epsilon>.dom.leg0 = fg.leg0"
         using dom_char counit_simps hcomp_def fg.composable by simp
       show "\<epsilon>.dom.leg1 = fg.leg1"
         using dom_char counit_simps hcomp_def fg.composable by simp
     qed
 
     lemma Chn_triangle_eq:
     shows "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
     and "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
     proof -
-      have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
-            \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
-              \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
+      have 1: "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
+               \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
+                 \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
       proof -
         have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
               Chn \<l>[f] \<cdot> Chn (\<epsilon> \<star> f) \<cdot> Chn \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> Chn (f \<star> \<eta>) \<cdot> Chn \<r>\<^sup>-\<^sup>1[f]"
           using antipar Chn_vcomp by auto
         also have "... = \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
                            chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
           using \<alpha>_ide fg.composable gf.composable fgf.chine_assoc_inverse
                 C.inverse_unique inv_eq iso_assoc lunit_ide_eq hcomp_def [of \<epsilon> f]
                 gf.composable hcomp_def [of f \<eta>] fg.composable runit'_ide_eq
           by simp
         finally show ?thesis by blast
       qed
       moreover have "C.arr (Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]))"
-      proof -
-        have "\<guillemotleft>\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f\<guillemotright>"
-          using ide_left ide_right antipar triangle_in_hom(1) by blast
-        thus ?thesis
-          using Chn_in_hom by blast
-      qed
-      ultimately have *: "C.arr (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
+        by (meson arrI arrow_of_spans.chine_simps(1) arr_char triangle_in_hom(3))
+      ultimately have 2: "C.arr (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
                                    chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
         by simp
 
       have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
                \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
                  \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
-        by fact
+        using 1 by simp
       also have
-        1: "... = fgf.Prj\<^sub>0 \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
-      proof -
-        have "\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f = \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
-        proof -
-          have "chine_hcomp \<epsilon> f = \<langle>\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]
-                                   \<lbrakk>\<epsilon>.cod.leg0, f.leg1\<rbrakk>
-                                 \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]\<rangle>"
-            using chine_hcomp_arr_ide gf.composable by simp
-          moreover have 1: "f.dtrg = \<epsilon>.cod.leg0"
-            using cod_char trg_def counit_simps gf.composable by simp
-          moreover have "C.commutative_square f.dtrg f.leg1
-                           (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]) \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
-          proof
-            show "C.cospan f.dtrg f.leg1" by simp
-            show 2: "C.span (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]) \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
-              using 1 \<open>C.cospan f.dtrg f.leg1\<close> chine_counit_in_hom by simp
-            show 3: "C.dom f.dtrg = C.cod (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1])"
-              using 1 2 dom_char counit_simps by simp
-            show "f.dtrg \<cdot> \<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1] = f.leg1 \<cdot> \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
-              using 1 2 3 C.comp_cod_arr dom_char counit_simps C.pullback_commutes'
-              by (metis (no_types, lifting) C.prj1_simps_arr C.seqE \<epsilon>.leg0_commutes)
-          qed
-          ultimately show ?thesis by simp
-        qed
-        also have "... = fgf.Prj\<^sub>0"
-          using dom_char counit_simps hcomp_def fg.composable by simp
-        finally have "\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f = fgf.Prj\<^sub>0"
-          by simp
-        moreover have "C.seq \<p>\<^sub>0[f.dtrg, f.leg1] (chine_hcomp \<epsilon> f)"
-          using chine_hcomp_props(1) fg.composable calculation(1) fgf.prj_in_hom(3)
-          by auto
-        moreover have "C.seq (chine_hcomp \<epsilon> f)
-                             (fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
-                                \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
-          using chine_hcomp_props(1) fg.composable by (metis "*" C.seqE)
-        ultimately show ?thesis
-          using C.comp_reduce by simp
-      qed
-      also have 3: "... = fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
+        3: "... = fgf.Prj\<^sub>0 \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
+        by (metis (no_types, lifting) C.comp_assoc C.comp_cod_arr \<epsilon>_leg_simps(1,3)
+            chine_hcomp_props(5) counit_simps(1,4) f.chine_eq_apex f.cod_simps(3)
+            fg.composite_is_arrow fg.leg0_composite fgf.prj_simps(3,9) hseqE)
+      also have 4: "... = fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
         using C.comp_reduce [of fgf.Prj\<^sub>0 fgf.chine_assoc' fgf.Prj\<^sub>0\<^sub>0
                                 "chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"]
-              * fgf.prj_chine_assoc'(3)
+              2 fgf.prj_chine_assoc'(3)
         by blast
-      also have 4: "... = (gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]) \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
+      also have "... = (gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]) \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
       proof -
         have "fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
         proof -
           have "fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> =
                 (gf.prj\<^sub>0 \<cdot> \<p>\<^sub>0[f.leg0, gf.leg1]) \<cdot>
                    \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, gf.leg1\<rbrakk> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
             using hcomp_def fg.composable gf.composable chine_hcomp_ide_arr \<eta>_leg_simps by auto
           also have "... = gf.prj\<^sub>0 \<cdot> \<p>\<^sub>0[f.leg0, gf.leg1] \<cdot>
                              \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, gf.leg1\<rbrakk> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
             using C.comp_assoc by simp
           also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
           proof -
             have "C.commutative_square f.leg0 gf.leg1 \<p>\<^sub>1[f.leg0, f.dsrc] (\<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc])"
             proof
               show "C.cospan f.leg0 gf.leg1"
                 using hcomp_def gf.composable fgf.prj_in_hom(5) by auto
               show "C.span \<p>\<^sub>1[f.leg0, f.dsrc] (\<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc])"
                 using chine_unit_in_hom by auto
               show "C.dom f.leg0 = C.cod \<p>\<^sub>1[f.leg0, f.dsrc]" by simp
               show "f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = gf.leg1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
-              proof -
-                have "f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = \<p>\<^sub>0[f.leg0, f.dsrc]"
-                  using C.comp_cod_arr C.pullback_commutes [of f.leg0 f.dsrc] by auto
-                also have "... = gf.leg1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
-                  using unit_simps cod_char hcomp_def gf.composable \<eta>.leg1_commutes \<eta>_leg_simps
-                        C.comp_cod_arr chine_unit_in_hom C.comp_reduce
-                  by auto
-                finally show ?thesis by blast
-              qed
+                by (metis C.comp_assoc C.pullback_commutes' \<eta>.cod_trg_eq_dom_trg
+                    \<eta>.dom.leg_simps(1) \<eta>.leg1_commutes \<eta>_leg_simps(1-2,4)
+                    \<open>C.cospan f.leg0 gf.leg1\<close>)
             qed
             thus ?thesis by simp
           qed
           finally show ?thesis by simp
         qed
         moreover have "C.seq fgf.Prj\<^sub>0\<^sub>0 (chine_hcomp f \<eta>)"
-          using chine_hcomp_props(1) by (metis "*" 1 3 C.match_2 C.seqE)
+          using chine_hcomp_props(1) by (metis 2 3 4 C.match_2 C.seqE)
         moreover have "C.seq (chine_hcomp f \<eta>) \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
-          using chine_hcomp_props(1) by (metis "*" C.seqE)
+          using chine_hcomp_props(1) by (metis 2 C.seqE)
         ultimately show ?thesis
           using C.comp_reduce by simp
       qed
       also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc] \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
         using C.comp_assoc by simp
       also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
         using C.comp_cod_arr f.leg0_commutes by simp
       finally show "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
         by simp
 
-      have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
-            \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
-              \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
+      have 1: "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
+               \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
+                 \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
       proof -
         have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
               Chn \<r>[g] \<cdot> Chn (g \<star> \<epsilon>) \<cdot> Chn \<a>[g, f, g] \<cdot> Chn (\<eta> \<star> g) \<cdot> Chn \<l>\<^sup>-\<^sup>1[g]"
           using antipar Chn_vcomp by auto
         also have "... = \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
                            \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
           using \<alpha>_ide gf.composable fg.composable runit_ide_eq hcomp_def [of g \<epsilon>]
                 fg.composable hcomp_def [of \<eta> g] gf.composable lunit'_ide_eq
           by simp
         finally show ?thesis by blast
       qed
-      moreover have "C.arr (Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]))"
-      proof -
-        have "\<guillemotleft>\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g\<guillemotright>"
-          using ide_left ide_right antipar triangle_in_hom(2) by blast
-        thus ?thesis
-          using Chn_in_hom by blast
-      qed
-      ultimately have *: "C.arr (\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
-                                   \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
-        by simp
+      hence 2: "C.arr (\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot>
+                       chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
+        by (metis arrI arr_char arrow_of_spans.chine_simps(1) triangle_in_hom(4))
 
       have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
             \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
               \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
-        by fact
+        using 1 by simp
       also have
-        1: "... = gfg.Prj\<^sub>1 \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
+        "... = gfg.Prj\<^sub>1 \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
       proof -
         have "\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> = \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]"
-        proof -
-          have "chine_hcomp g \<epsilon> = \<langle>\<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]
-                                   \<lbrakk>g.leg0, \<epsilon>.cod.leg1\<rbrakk>
-                                 \<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1]\<rangle>"
-            using chine_hcomp_ide_arr gf.composable by simp
-          moreover have 1: "g.dsrc = \<epsilon>.cod.leg1"
-            using gfg.cospan_\<mu>\<nu> by (simp add: \<epsilon>_leg_simps(2))
-          moreover have "C.commutative_square g.leg0 g.dsrc \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]
-                             (\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1])"
-          proof
-            show "C.cospan g.leg0 g.dsrc" by simp
-            show 2: "C.span \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1] (\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1])"
-              using 1 \<open>C.cospan g.leg0 g.dsrc\<close> chine_counit_in_hom by simp
-            show 3: "C.dom g.leg0 = C.cod \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]"
-              using 1 2 dom_char counit_simps by simp
-            show "g.leg0 \<cdot> \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1] = g.dsrc \<cdot> \<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1]"
-              using 1 2 3 C.comp_cod_arr dom_char counit_simps C.pullback_commutes'
-              by (metis (no_types, lifting) C.cod_comp C.prj0_simps_arr C.seqE \<epsilon>.leg1_commutes)
-          qed
-          ultimately show ?thesis by simp
-        qed
+          by (metis C.comp_cod_arr \<epsilon>_leg_simps(2) \<epsilon>_leg_simps(4) arrI chine_hcomp_props(6)
+                    fg.leg1_composite g.cod_simps(2) g.identity_arrow_of_spans_axioms
+                    gfg.cospan_\<mu>\<nu> gfg.prj_simps(10) gfg.prj_simps(16) hseqE
+                    identity_arrow_of_spans.chine_eq_apex seqE triangle_in_hom(4))
         also have "... = gfg.Prj\<^sub>1"
           using dom_char counit_simps hcomp_def fg.composable by simp
         finally have "\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> = gfg.Prj\<^sub>1"
           by simp
         moreover have "C.seq \<p>\<^sub>1[g.leg0, g.dsrc] (chine_hcomp g \<epsilon>)"
           using chine_hcomp_props(1) [of g \<epsilon>] gf.composable calculation gfg.prj_in_hom(4)
           by auto
         moreover have "C.seq (chine_hcomp g \<epsilon>)
                              (gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
-          using chine_hcomp_props(1) gf.composable * by (metis C.seqE)
+          using chine_hcomp_props(1) gf.composable 2 by (metis C.seqE)
         ultimately show ?thesis
           using C.comp_reduce by simp
       qed
-      also have 3: "... = gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
+      also have "... = gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
         using C.comp_reduce [of gfg.Prj\<^sub>1 gfg.chine_assoc gfg.Prj\<^sub>1\<^sub>1
                                 "chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"]
-              * gfg.prj_chine_assoc(1)
+              2 gfg.prj_chine_assoc(1)
         by blast
-      also have 4: "... = (gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
-      proof -
-        have "gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
-        proof -
-          have "gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g =
-                (gf.prj\<^sub>1 \<cdot> \<p>\<^sub>1[gf.leg0, g.leg1]) \<cdot>
-                   \<langle>\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<lbrakk>gf.leg0, g.leg1\<rbrakk> \<p>\<^sub>0[g.dtrg, g.leg1]\<rangle>"
-            using hcomp_def fg.composable gf.composable chine_hcomp_arr_ide trg_def unit_simps(5)
-                  \<eta>_leg_simps
-            by auto
-          also have "... = gf.prj\<^sub>1 \<cdot> \<p>\<^sub>1[gf.leg0, g.leg1] \<cdot>
-                             \<langle>\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<lbrakk>gf.leg0, g.leg1\<rbrakk> \<p>\<^sub>0[g.dtrg, g.leg1]\<rangle>"
-            using C.comp_assoc by simp
-          also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
-          proof -
-            have "C.commutative_square gf.leg0 g.leg1 (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]"
-            proof
-              show "C.cospan gf.leg0 g.leg1"
-                using hcomp_def [of g f] gf.composable gfg.prj_in_hom(3) by auto
-              show "C.span (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]"
-                using chine_unit_in_hom fg.composable src_def trg_def by auto
-              show "C.dom gf.leg0 = C.cod (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1])"
-                using chine_unit_in_hom \<eta>_leg_simps
-                by (simp add: \<eta>.cod.apex_def
-                    \<open>C.span (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]\<close>)
-              show "gf.leg0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] = g.leg1 \<cdot> \<p>\<^sub>0[g.dtrg, g.leg1]"
-              proof -
-                have "g.leg1 \<cdot> \<p>\<^sub>0[g.dtrg, g.leg1] = \<p>\<^sub>1[g.dtrg, g.leg1]"
-                  using C.comp_cod_arr C.pullback_commutes [of g.dtrg g.leg1] by auto
-                also have "... = gf.leg0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
-                proof -
-                  have "gf.leg0 \<cdot> \<eta>.chine = g.dtrg"
-                    using unit_simps cod_char hcomp_def gf.composable \<eta>.leg0_commutes
-                          dom_char trg_def fg.composable
-                    by simp
-                  moreover have "C.seq \<eta>.chine \<p>\<^sub>1[g.dtrg, g.leg1]"
-                    using chine_unit_in_hom fg.composable src_def trg_def by auto
-                  ultimately show ?thesis
-                    using C.comp_cod_arr C.comp_reduce by auto
-                qed
-                finally show ?thesis by simp
-              qed
-            qed
-            thus ?thesis by simp
-          qed
-          finally show ?thesis by simp
-        qed
-        moreover have "C.seq gfg.Prj\<^sub>1\<^sub>1 (chine_hcomp \<eta> g)"
-          using chine_hcomp_props(1) [of \<eta> g] by (metis "*" 1 "3" C.match_2 C.seqE)
-        moreover have "C.seq (chine_hcomp \<eta> g) \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
-          using chine_hcomp_props(1) by (metis "*" C.seqE)
-        ultimately show ?thesis
-          using C.comp_reduce by simp
-      qed
+      also have "... = (gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
+        by (metis C.comp_assoc \<eta>_leg_simps(1) \<eta>_leg_simps(3) arrI chine_hcomp_props(6)
+                  g.cod_simps(3) gf.leg0_composite gfg.cospan_\<nu>\<pi> hseqE seqE triangle_in_hom(4))
       also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
         using C.comp_assoc by simp
       also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
         using C.comp_cod_arr g.leg1_commutes by simp
       finally show "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
         by simp
     qed
 
   end
 
   subsection "Maps in Span(C)"
 
   text \<open>
     In this section, we chararacterize the maps (\emph{i.e}~the left adjoints)
     in a span bicategory.  This is Proposition 2 of \cite{carboni-et-al}.
   \<close>
 
   context span_bicategory
   begin
 
     abbreviation adjoint_of_map
     where "adjoint_of_map f \<equiv> \<lparr>Chn = Chn f,
                                Dom = \<lparr>Leg0 = Leg1 (Dom f), Leg1 = Leg0 (Dom f)\<rparr>,
                                Cod = \<lparr>Leg0 = Leg1 (Dom f), Leg1 = Leg0 (Dom f)\<rparr>\<rparr>"
 
     abbreviation unit_for_map
     where "unit_for_map f \<equiv> \<lparr>Chn = \<langle>C.inv (Leg0 (Dom f))
                                       \<lbrakk>Leg1 (Dom f), Leg1 (Dom f)\<rbrakk>
                                     C.inv (Leg0 (Dom f))\<rangle>,
                              Dom = Dom (src f),
                              Cod = Dom (hcomp (adjoint_of_map f) f)\<rparr>"
 
     abbreviation counit_for_map
     where "counit_for_map f \<equiv> \<lparr>Chn = Leg1 (Dom f) \<cdot> \<p>\<^sub>0[Leg0 (Dom f), Leg0 (Dom f)],
                                Dom = Dom (hcomp f (adjoint_of_map f)),
                                Cod = Dom (trg f)\<rparr>"
 
     lemma is_left_adjoint_char:
     shows "is_left_adjoint f \<longleftrightarrow> ide f \<and> C.iso (Leg0 (Dom f))"
     and "is_left_adjoint f \<Longrightarrow>
            adjunction_in_bicategory vcomp hcomp assoc unit src trg f
               (adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
     proof
       show 1: "is_left_adjoint f \<Longrightarrow> ide f \<and> C.iso (Leg0 (Dom f))"
       proof
         assume f: "is_left_adjoint f"
         obtain g \<eta> \<epsilon> where adj: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>"
           using f adjoint_pair_def by blast
         interpret adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
           using adj by auto
         show "ide f" by simp
 
         interpret f: identity_arrow_of_spans C f
           using ide_char' [of f] by auto
         interpret g: identity_arrow_of_spans C g
           using ide_char' [of g] by auto
 
         interpret gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
           using antipar by (unfold_locales, auto)
         interpret fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
           using antipar by (unfold_locales, auto)
 
         interpret fgf: three_composable_identity_arrows_of_spans C prj0 prj1 f g f ..
 
         interpret src_f: arrow_of_spans C \<open>src f\<close>
           using arr_char gf.are_arrows(2) by blast
         interpret src_f: identity_arrow_of_spans C \<open>src f\<close>
           using ide_char ide_src src_def by (unfold_locales, simp)
 
         interpret \<eta>: arrow_of_spans C \<eta>
           using arr_char unit_in_hom by auto
         interpret \<epsilon>: arrow_of_spans C \<epsilon>
           using arr_char counit_in_hom by auto
 
         interpret adjunction_data_in_span_bicategory C prj0 prj1 f g \<eta> \<epsilon>
           ..
         show "C.iso f.leg0"
         proof -
           have "C.section f.leg0"
           proof -
             have "f.chine = (gf.prj\<^sub>0 \<cdot> \<eta>.chine) \<cdot> f.leg0"
               using triangle_left' Chn_triangle_eq(1) C.comp_assoc by simp
             thus ?thesis
               using f.chine_is_identity by auto
           qed
           moreover have "C.retraction f.leg0"
             using C.retractionI [of f.leg0 "gf.prj\<^sub>0 \<cdot> \<eta>.chine"] hcomp_def C.comp_assoc
                   \<eta>.leg0_commutes gf.leg0_composite \<eta>_leg_simps
             by auto
           ultimately show ?thesis
             by (simp add: C.iso_iff_section_and_retraction)
         qed
       qed
       have 2: "ide f \<and> C.iso (Leg0 (Dom f)) \<Longrightarrow>
                  adjunction_in_bicategory vcomp hcomp assoc unit src trg f
                    (adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
 
         text \<open>
           The right adjoint \<open>g\<close> is obtained by exchanging the legs of \<open>f\<close>.
           The unit is obtained by tupling \<open>C.inv f.leg0\<close> with itself,
           via the pullback of \<open>f.leg1\<close> with itself.
           The counit is given by the legs of \<open>f \<star> g\<close>, which are equal,
           because the two legs of a pullback of the isomorphism \<open>f.leg0\<close>
           with itself must be equal.
           It then remains to verify the triangle identities.
       \<close>
 
       proof -
         assume f: "ide f \<and> C.iso (Leg0 (Dom f))"
         interpret f: identity_arrow_of_spans C f
           using f ide_char' by auto
         interpret Dom_src: span_in_category C \<open>\<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<close>
           using f by (unfold_locales, auto)
         interpret Dom_trg: span_in_category C \<open>\<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<close>
           using f by (unfold_locales, auto)
 
         define g where "g = adjoint_of_map f"
         interpret Dom_g: span_in_category C \<open>\<lparr>Leg0 = f.leg1, Leg1 = f.leg0\<rparr>\<close>
           by (unfold_locales, simp)
         interpret g: arrow_of_spans C g
           unfolding g_def
           using Dom_g.apex_def f.leg0_commutes f.leg1_commutes
           by (unfold_locales, auto)
         interpret g: identity_arrow_of_spans C g
           using g_def
           by (unfold_locales, auto)
         have ide_g: "ide g"
           using f ide_char g.arrow_of_spans_axioms by simp
 
         interpret fg: two_composable_arrows_of_spans C prj0 prj1 f g
           apply unfold_locales
           using g_def src_def trg_def arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms
           by auto
         interpret fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
           ..
         interpret gf: two_composable_arrows_of_spans C prj0 prj1 g f
           apply unfold_locales
           using g_def src_def trg_def arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms
           by auto
         interpret gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
           ..
         have hcomp_fg_eq: "hcomp f g = \<lparr>Chn = f.leg0 \<down>\<down> f.leg0,
                                          Dom = \<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
                                                 Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>,
                                          Cod = \<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
                                                 Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>\<rparr>"
           using f g_def hcomp_def fg.composable src_def trg_def arr_char f.arrow_of_spans_axioms
                 g.arrow_of_spans_axioms chine_hcomp_def gf.are_identities(1) chine_hcomp_ide_ide
                 C.pullback_iso_self
           by auto
         have hcomp_gf_eq: "hcomp g f = \<lparr>Chn = f.leg1 \<down>\<down> f.leg1,
                                          Dom = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
                                                 Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>,
                                          Cod = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
                                                 Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>\<rparr>"
           using g_def hcomp_def gf.composable src_def trg_def chine_hcomp_ide_ide
                 arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms ide_char
           by simp
 
         define \<eta> where "\<eta> = unit_for_map f"
         interpret Dom_gf: span_in_category C \<open>\<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
                                                Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>\<close>
           by (unfold_locales, simp_all)
         interpret \<eta>: arrow_of_spans C \<eta>
           using f g_def \<eta>_def hcomp_def src_def trg_def f.arrow_of_spans_axioms
                 g.arrow_of_spans_axioms arr_char C.comp_arr_inv'
                 C.tuple_in_hom [of f.leg1 f.leg1 "C.inv f.leg0" "C.inv f.leg0"]
                 Dom_src.apex_def Dom_gf.apex_def
           apply unfold_locales by (simp_all add: C.comp_assoc)
         have unit_in_hom: "\<guillemotleft>\<eta> : src f \<Rightarrow> hcomp g f\<guillemotright>"
         proof
           show 1: "arr \<eta>"
             using arr_char \<eta>.arrow_of_spans_axioms by simp
           show "dom \<eta> = src f"
             using 1 \<eta>_def dom_char src_def Dom_src.apex_def by simp
           show "cod \<eta> = hcomp g f"
             using 1 \<eta>_def g_def cod_char hcomp_gf_eq Dom_gf.apex_def by simp
         qed
 
         define \<epsilon> where "\<epsilon> = counit_for_map f"
         interpret Dom_fg: span_in_category C \<open>\<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
                                                Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>\<close>
           by (unfold_locales, simp_all)
         interpret \<epsilon>: arrow_of_spans C \<epsilon>
           using f g_def \<epsilon>_def hcomp_def src_def trg_def f.arrow_of_spans_axioms
                 g.arrow_of_spans_axioms arr_char C.comp_cod_arr C.pullback_iso_self
                 Dom_trg.apex_def Dom_fg.apex_def
           apply unfold_locales by auto
         have counit_in_hom: "\<guillemotleft>\<epsilon> : hcomp f g \<Rightarrow> trg f\<guillemotright>"
         proof
           show 1: "arr \<epsilon>"
             using arr_char \<epsilon>.arrow_of_spans_axioms by simp
           show "cod \<epsilon> = trg f"
             using 1 \<epsilon>_def cod_char trg_def Dom_trg.apex_def by simp
           show "dom \<epsilon> = hcomp f g"
             using 1 g_def \<epsilon>_def dom_char hcomp_fg_eq Dom_fg.apex_def by simp
         qed
         interpret adj: adjunction_data_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
           using f ide_g unit_in_hom counit_in_hom gf.composable
           by (unfold_locales, simp_all)
         interpret adjunction_data_in_span_bicategory C prj0 prj1 f g \<eta> \<epsilon>
           ..
         have triangle_left: "(\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<bullet> \<r>[f]"
         proof -
           have "\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f] = f"
           proof (intro arr_eqI)
             show "par (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) f"
               using f ide_in_hom [of f] adj.triangle_in_hom(3)
               by (metis (no_types, lifting) in_homE)
             show "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = f.chine"
               using f g_def \<eta>_def Chn_triangle_eq(1) C.comp_tuple_arr C.comp_inv_arr' by simp
           qed
           thus ?thesis
             using adj.triangle_equiv_form by simp
         qed
         have triangle_right: "(g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<bullet> \<l>[g]"
         proof -
           have "\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g] = g"
           proof (intro arr_eqI)
             show "par (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) g"
               using adj.ide_right ide_in_hom [of g] adj.triangle_in_hom(4)
               by (metis (no_types, lifting) in_homE)
             show "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = g.chine"
               using f g_def \<eta>_def Chn_triangle_eq(2) C.comp_tuple_arr C.comp_inv_arr' by simp
           qed
           thus ?thesis
             using adj.triangle_equiv_form by simp
         qed
         interpret adj: adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
           using triangle_left triangle_right by (unfold_locales, simp_all)
         show "adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>" ..
       qed
       show "ide f \<and> C.iso (Leg0 (Dom f)) \<Longrightarrow> is_left_adjoint f"
         using 2 adjoint_pair_def by blast
       show "is_left_adjoint f \<Longrightarrow> adjunction_in_bicategory vcomp hcomp assoc unit src trg f
               (adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
         using 1 2 by blast
     qed
 
   end
 
 end
diff --git a/thys/Bicategory/Subbicategory.thy b/thys/Bicategory/Subbicategory.thy
--- a/thys/Bicategory/Subbicategory.thy
+++ b/thys/Bicategory/Subbicategory.thy
@@ -1,1492 +1,1490 @@
 (*  Title:       Subbicategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Sub-Bicategories"
 
 text \<open>
   In this section we give a construction of a sub-bicategory in terms of a predicate
   on the arrows of an ambient bicategory that has certain closure properties with respect
   to that bicategory.  While the construction given here is likely to be of general use,
   it is not the most general sub-bicategory construction that one could imagine,
   because it requires that the sub-bicategory actually contain the unit and associativity
   isomorphisms of the ambient bicategory.  Our main motivation for including this construction
   here is to apply it to exploit the fact that the sub-bicategory of endo-arrows of a fixed
   object is a monoidal category, which will enable us to transfer to bicategories a result
   about unit isomorphisms in monoidal categories.  
 \<close>
 
 theory Subbicategory
 imports Bicategory
 begin
 
   subsection "Construction"
 
   locale subbicategory =
     B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
     subcategory V Arr
   for V :: "'a comp"                 (infixr "\<cdot>\<^sub>B" 55)
   and H :: "'a comp"                 (infixr "\<star>\<^sub>B" 55)
   and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"    ("\<a>\<^sub>B[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src\<^sub>B :: "'a \<Rightarrow> 'a"
   and trg\<^sub>B :: "'a \<Rightarrow> 'a"
   and Arr :: "'a \<Rightarrow> bool" +
   assumes src_closed: "Arr f \<Longrightarrow> Arr (src\<^sub>B f)"
   and trg_closed: "Arr f \<Longrightarrow> Arr (trg\<^sub>B f)"
   and hcomp_closed: "\<lbrakk> Arr f; Arr g; trg\<^sub>B f = src\<^sub>B g \<rbrakk> \<Longrightarrow> Arr (g \<star>\<^sub>B f)"
   and assoc_closed: "\<lbrakk> Arr f \<and> B.ide f; Arr g \<and> B.ide g; Arr h \<and> B.ide h;
                        src\<^sub>B f = trg\<^sub>B g; src\<^sub>B g = trg\<^sub>B h \<rbrakk> \<Longrightarrow> Arr (\<a>\<^sub>B f g h)"
   and assoc'_closed: "\<lbrakk> Arr f \<and> B.ide f; Arr g \<and> B.ide g; Arr h \<and> B.ide h;
                        src\<^sub>B f = trg\<^sub>B g; src\<^sub>B g = trg\<^sub>B h \<rbrakk> \<Longrightarrow> Arr (B.inv (\<a>\<^sub>B f g h))"
   and lunit_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.\<ll> f)"
   and lunit'_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.inv (B.\<ll> f))"
   and runit_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.\<rr> f)"
   and runit'_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.inv (B.\<rr> f))"
   begin
 
     notation B.in_hom           ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
 
     notation comp               (infixr "\<cdot>" 55)
 
     definition hcomp            (infixr "\<star>" 53)
     where "g \<star> f = (if arr f \<and> arr g \<and> trg\<^sub>B f = src\<^sub>B g then g \<star>\<^sub>B f else null)"
 
     definition src
     where "src \<mu> = (if arr \<mu> then src\<^sub>B \<mu> else null)"
 
     definition trg
     where "trg \<mu> = (if arr \<mu> then trg\<^sub>B \<mu> else null)"
 
     interpretation src: endofunctor \<open>(\<cdot>)\<close> src
       using src_def null_char inclusion arr_char src_closed trg_closed dom_closed cod_closed
             dom_simp cod_simp
       apply unfold_locales
           apply auto[4]
       by (metis B.src.as_nat_trans.preserves_comp_2 comp_char seq_char)
 
     interpretation trg: endofunctor \<open>(\<cdot>)\<close> trg
       using trg_def null_char inclusion arr_char src_closed trg_closed dom_closed cod_closed
             dom_simp cod_simp
       apply unfold_locales
           apply auto[4]
       by (metis B.trg.as_nat_trans.preserves_comp_2 comp_char seq_char)
 
     interpretation horizontal_homs \<open>(\<cdot>)\<close> src trg
       using src_def trg_def src.preserves_arr trg.preserves_arr null_char ide_char arr_char
             inclusion
       by (unfold_locales, simp_all)
 
     interpretation "functor" VV.comp \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
       using hcomp_def VV.arr_char src_def trg_def arr_char hcomp_closed dom_char cod_char
             VV.dom_char VV.cod_char
       apply unfold_locales
           apply auto[2]
     proof -
       fix f
       assume f: "VV.arr f"
       show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
       proof -
         have "dom (fst f \<star> snd f) = B.dom (fst f) \<star>\<^sub>B B.dom (snd f)"
         proof -
           have "dom (fst f \<star> snd f) = B.dom (fst f \<star> snd f)"
             using f dom_char
             by (simp add: arr_char hcomp_closed hcomp_def)
           also have "... = B.dom (fst f) \<star>\<^sub>B B.dom (snd f)"
             using f
             by (metis (no_types, lifting) B.hcomp_simps(3) B.hseqI' VV.arrE arrE hcomp_def
                 inclusion src_def trg_def)
           finally show ?thesis by blast
         qed
         also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
            using f VV.arr_char VV.dom_char arr_char hcomp_def B.seq_if_composable dom_closed
            apply simp
            by (metis (no_types, lifting) dom_char)
         finally show ?thesis by simp
       qed
       show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
       proof -
         have "cod (fst f \<star> snd f) = B.cod (fst f) \<star>\<^sub>B B.cod (snd f)"
           using f VV.arr_char arr_char cod_char hcomp_def src_def trg_def
                 src_closed trg_closed hcomp_closed inclusion B.hseq_char arrE
           by auto
         also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
            using f VV.arr_char VV.cod_char arr_char hcomp_def B.seq_if_composable cod_closed
            apply simp
            by (metis (no_types, lifting) cod_char)
         finally show ?thesis by simp
       qed
       next
       fix f g
       assume fg: "VV.seq g f"
       show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
       proof -
         have "fst (VV.comp g f) \<star> snd (VV.comp g f) = fst g \<cdot> fst f \<star> snd g \<cdot> snd f"
           using fg VV.seq_char VV.comp_char VxV.comp_char VxV.not_Arr_Null
           by (metis (no_types, lifting) VxV.seqE prod.sel(1) prod.sel(2))
         also have "... = (fst g \<cdot>\<^sub>B fst f) \<star>\<^sub>B (snd g \<cdot>\<^sub>B snd f)"
           using fg comp_char hcomp_def VV.seq_char inclusion arr_char seq_char B.hseq_char
           by (metis (no_types, lifting) B.hseq_char' VxV.seq_char null_char)
         also have 1: "... = (fst g \<star>\<^sub>B snd g) \<cdot>\<^sub>B (fst f \<star>\<^sub>B snd f)"
         proof -
           have "src\<^sub>B (fst g) = trg\<^sub>B (snd g)"
             by (metis (no_types, lifting) VV.arrE VV.seq_char fg src_def trg_def)
           thus ?thesis
             using fg VV.seq_char VV.arr_char arr_char seq_char inclusion B.interchange
             by (meson VxV.seqE)
         qed
         also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
           using fg comp_char hcomp_def VV.seq_char VV.arr_char arr_char seq_char inclusion
                 B.hseq_char' hcomp_closed src_def trg_def
           by (metis (no_types, lifting) 1)
         finally show ?thesis by auto
       qed
     qed
 
     interpretation horizontal_composition \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> src trg
       using arr_char src_def trg_def src_closed trg_closed
       apply (unfold_locales)
       using hcomp_def inclusion not_arr_null by auto
 
     abbreviation \<a>
     where "\<a> \<mu> \<nu> \<tau> \<equiv> if VVV.arr (\<mu>, \<nu>, \<tau>) then \<a>\<^sub>B \<mu> \<nu> \<tau> else null"
 
     abbreviation (input) \<alpha>\<^sub>S\<^sub>B
     where "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> \<equiv> \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
 
     lemma assoc_closed':
     assumes "VVV.arr \<mu>\<nu>\<tau>"
     shows "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>)"
     proof -
       have 1: "B.VVV.arr \<mu>\<nu>\<tau>"
         using assms VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char arr_char
               src_def trg_def inclusion
         by auto
       show "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>)"
       proof -
         have "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) =
               Arr ((fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B \<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>))"
           using assms 1 B.\<alpha>_def B.assoc_is_natural_1 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
                 VV.arr_char VVV.arr_char B.VVV.arr_char B.VV.arr_char B.VVV.dom_char B.VV.dom_char
           apply simp
           by (metis (no_types, lifting) arr_char dom_char dom_closed src.preserves_dom
               trg.preserves_dom)
         also have "..."
         proof (intro comp_closed)
           show "Arr (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))"
             using assms 1 B.VVV.arr_char B.VV.arr_char hcomp_closed
             by (metis (no_types, lifting) B.H.preserves_reflects_arr B.trg_hcomp
                 VV.arr_char VVV.arrE arr_char)
           show "B.cod (\<a> (fst (B.VVV.dom \<mu>\<nu>\<tau>)) (fst (snd (B.VVV.dom \<mu>\<nu>\<tau>)))
                       (snd (snd (B.VVV.dom \<mu>\<nu>\<tau>)))) =
                 B.dom (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))"
             using assms 1 VVV.arr_char VV.arr_char B.VxVxV.dom_char
                   B.VVV.dom_simp B.VVV.cod_simp
             apply simp
             by (metis (no_types, lifting) B.VV.arr_char B.VVV.arrE B.\<alpha>.preserves_reflects_arr
                 B.assoc_is_natural_1 B.seqE arr_dom dom_char src_dom trg_dom)
           show "Arr (\<a> (fst (B.VVV.dom \<mu>\<nu>\<tau>)) (fst (snd (B.VVV.dom \<mu>\<nu>\<tau>)))
                     (snd (snd (B.VVV.dom \<mu>\<nu>\<tau>))))"
           proof -
             have "VVV.arr (B.VVV.dom \<mu>\<nu>\<tau>)"
               using 1 B.VVV.dom_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
               apply simp
               by (metis (no_types, lifting) VVV.arrE arr_dom assms dom_simp src_dom trg_dom)
             moreover have "Arr (\<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>)))
                                (B.dom (snd (snd \<mu>\<nu>\<tau>))))"
             proof -
               have "B.VVV.ide (B.VVV.dom \<mu>\<nu>\<tau>)"
                 using 1 B.VVV.ide_dom by blast
               thus ?thesis
                 using assms B.\<alpha>_def B.VVV.arr_char B.VV.arr_char B.VVV.ide_char B.VV.ide_char
                       dom_closed assoc_closed
                 by (metis (no_types, lifting) "1" B.ide_dom B.src_dom B.trg_dom VV.arr_char
                     VVV.arrE arr_char)
             qed
             ultimately show ?thesis
               using 1 B.VVV.ide_dom assoc_closed B.VVV.dom_char
               apply simp
               by (metis (no_types, lifting) B.VV.arr_char B.VVV.arrE B.VVV.inclusion
                   B.VxV.dom_char B.VxVxV.arrE B.VxVxV.dom_char prod.sel(1) prod.sel(2))
           qed
         qed
         finally show ?thesis by blast
       qed
     qed
 
     lemma lunit_closed':
     assumes "Arr f"
     shows "Arr (B.\<ll> f)"
     proof -
       have 1: "arr f \<and> arr (B.\<ll> (B.dom f))"
         using assms arr_char lunit_closed dom_closed B.ide_dom inclusion by simp
       moreover have "B.dom f = B.cod (B.\<ll> (B.dom f))"
         using 1 arr_char B.\<ll>.preserves_cod inclusion by simp
       moreover have "B.\<ll> f = f \<cdot> B.\<ll> (B.dom f)"
         using assms 1 B.\<ll>.is_natural_1 inclusion comp_char arr_char by simp
       ultimately show ?thesis
         using arr_char comp_closed cod_char seqI dom_simp by auto
     qed
       
     lemma runit_closed':
     assumes "Arr f"
     shows "Arr (B.\<rr> f)"
     proof -
       have 1: "arr f \<and> arr (B.\<rr> (B.dom f))"
         using assms arr_char runit_closed dom_closed B.ide_dom inclusion
         by simp
       moreover have "B.dom f = B.cod (B.\<rr> (B.dom f))"
         using 1 arr_char B.\<ll>.preserves_cod inclusion by simp
       moreover have "B.\<rr> f = f \<cdot> B.\<rr> (B.dom f)"
         using assms 1 B.\<rr>.is_natural_1 inclusion comp_char arr_char by simp
       ultimately show ?thesis
         using arr_char comp_closed cod_char seqI dom_simp by auto
     qed
 
     interpretation natural_isomorphism VVV.comp \<open>(\<cdot>)\<close> HoHV HoVH \<alpha>\<^sub>S\<^sub>B
     proof
       fix \<mu>\<nu>\<tau>
       show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> = null"
         by simp
       assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
       have 1: "B.VVV.arr \<mu>\<nu>\<tau>"
         using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char arr_char
               src_def trg_def inclusion
         by auto
       show "dom (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
       proof -
         have "dom (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = B.HoHV (B.VVV.dom \<mu>\<nu>\<tau>)"
           using \<mu>\<nu>\<tau> 1 arr_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
                 B.\<alpha>_def assoc_closed' dom_simp
           by simp
         also have "... = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
         proof -
           have "HoHV (VVV.dom \<mu>\<nu>\<tau>) = HoHV (VxVxV.dom \<mu>\<nu>\<tau>)"
             using \<mu>\<nu>\<tau> VVV.dom_char VV.arr_char src_def trg_def VVV.arr_char by auto
           also have "... = B.HoHV (B.VVV.dom \<mu>\<nu>\<tau>)"
              using \<mu>\<nu>\<tau> VVV.dom_char VVV.arr_char VV.arr_char src_def trg_def
                    HoHV_def B.HoHV_def arr_char B.VVV.arr_char B.VVV.dom_char B.VV.arr_char
                    dom_closed hcomp_closed hcomp_def inclusion dom_simp
              by auto
           finally show ?thesis by simp
         qed
         finally show ?thesis by simp
       qed
       show "cod (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
       proof -
         have "cod (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = B.HoVH (B.VVV.cod \<mu>\<nu>\<tau>)"
           using \<mu>\<nu>\<tau> 1 arr_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
                 B.\<alpha>_def assoc_closed' cod_simp
           by simp
         also have "... = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
         proof -
           have "HoVH (VVV.cod \<mu>\<nu>\<tau>) = HoVH (VxVxV.cod \<mu>\<nu>\<tau>)"
             using \<mu>\<nu>\<tau> VVV.cod_char VV.arr_char src_def trg_def VVV.arr_char by auto
           also have "... = B.HoVH (B.VVV.cod \<mu>\<nu>\<tau>)"
             using \<mu>\<nu>\<tau> VVV.cod_char VV.arr_char src_def trg_def VVV.arr_char
                   HoVH_def B.HoVH_def arr_char B.VVV.arr_char B.VVV.cod_char B.VV.arr_char
                   cod_closed hcomp_closed hcomp_def inclusion cod_simp
             by simp
           finally show ?thesis by simp
         qed
         finally show ?thesis by simp
       qed
       have 3: "Arr (fst \<mu>\<nu>\<tau>) \<and> Arr (fst (snd \<mu>\<nu>\<tau>)) \<and> Arr (snd (snd \<mu>\<nu>\<tau>)) \<and>
                src\<^sub>B (fst \<mu>\<nu>\<tau>) = trg\<^sub>B (fst (snd \<mu>\<nu>\<tau>)) \<and>
                src\<^sub>B (fst (snd \<mu>\<nu>\<tau>)) = trg\<^sub>B (snd (snd \<mu>\<nu>\<tau>))"
         using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char src_def trg_def arr_char by auto
       show "HoVH \<mu>\<nu>\<tau> \<cdot> \<alpha>\<^sub>S\<^sub>B (VVV.dom \<mu>\<nu>\<tau>) = \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>"
       proof -
         have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> = (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B
                            \<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>))) (B.dom (snd (snd \<mu>\<nu>\<tau>)))"
           using 3 inclusion B.assoc_is_natural_1 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
           by (simp add: \<mu>\<nu>\<tau>)
         also have "... = (fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>) \<star> snd (snd \<mu>\<nu>\<tau>)) \<cdot>
                            \<a>\<^sub>B (dom (fst \<mu>\<nu>\<tau>)) (dom (fst (snd \<mu>\<nu>\<tau>))) (dom (snd (snd \<mu>\<nu>\<tau>)))"
           using 1 3 \<mu>\<nu>\<tau> hcomp_closed assoc_closed dom_closed hcomp_def comp_def inclusion
             comp_char dom_char VVV.arr_char VV.arr_char
           apply simp
           using B.hcomp_simps(2-3) arr_char by presburger
         also have "... = HoVH \<mu>\<nu>\<tau> \<cdot> \<alpha>\<^sub>S\<^sub>B (VVV.dom \<mu>\<nu>\<tau>)"
           using \<mu>\<nu>\<tau> B.\<alpha>_def HoVH_def VVV.dom_char VV.dom_char VxVxV.dom_char
           apply simp
           by (metis (no_types, lifting) VV.arr_char VVV.arrE VVV.arr_dom VxV.dom_char
               dom_simp)
         finally show ?thesis by argo
       qed
       show "\<alpha>\<^sub>S\<^sub>B (VVV.cod \<mu>\<nu>\<tau>) \<cdot> HoHV \<mu>\<nu>\<tau> = \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>"
       proof -
         have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> =
               \<a>\<^sub>B (B.cod (fst \<mu>\<nu>\<tau>)) (B.cod (fst (snd \<mu>\<nu>\<tau>))) (B.cod (snd (snd \<mu>\<nu>\<tau>))) \<cdot>\<^sub>B
                 (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>)) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)"
           using 3 inclusion B.assoc_is_natural_2 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
           by (simp add: \<mu>\<nu>\<tau>)
         also have "... = \<a>\<^sub>B (cod (fst \<mu>\<nu>\<tau>)) (cod (fst (snd \<mu>\<nu>\<tau>))) (cod (snd (snd \<mu>\<nu>\<tau>))) \<cdot>
                            ((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
-          using 1 3 \<mu>\<nu>\<tau> hcomp_closed assoc_closed cod_closed hcomp_def comp_def inclusion
-            comp_char cod_char VVV.arr_char VV.arr_char
-          by auto
+          by (simp add: "3" arrI assoc_closed cod_char cod_closed hcomp_closed hcomp_def
+              inclusion comp_def)
         also have "... = \<alpha>\<^sub>S\<^sub>B (VVV.cod \<mu>\<nu>\<tau>) \<cdot> HoHV \<mu>\<nu>\<tau>"
           using \<mu>\<nu>\<tau> B.\<alpha>_def HoHV_def VVV.cod_char VV.cod_char VxVxV.cod_char
                 VVV.arr_char VV.arr_char arr_cod src_cod trg_cod
           by simp
         finally show ?thesis by argo
       qed
       next
       fix fgh
       assume fgh: "VVV.ide fgh"
       show "iso (\<alpha>\<^sub>S\<^sub>B fgh)"
       proof -
         have 1: "B.arr (fst (snd fgh)) \<and> B.arr (snd (snd fgh)) \<and>
                    src\<^sub>B (fst (snd fgh)) = trg\<^sub>B (snd (snd fgh)) \<and>
                    src\<^sub>B (fst fgh) = trg\<^sub>B (fst (snd fgh))"
           using fgh VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
                 arr_char inclusion
           by auto
         have 2: "B.ide (fst fgh) \<and> B.ide (fst (snd fgh)) \<and> B.ide (snd (snd fgh))"
           using fgh VVV.ide_char ide_char by blast
         have "\<alpha>\<^sub>S\<^sub>B fgh = \<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"
           using fgh B.\<alpha>_def by simp
         moreover have "B.VVV.ide fgh"
           using fgh 1 2 VVV.ide_char B.VVV.ide_char VVV.arr_char B.VVV.arr_char
                 src_def trg_def inclusion arr_char B.VV.arr_char
           by simp
         moreover have "Arr (\<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
           using fgh 1 VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
                 arr_char assoc_closed' B.\<alpha>_def
           by simp
         moreover have "Arr (B.inv (\<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))))"
           using fgh 1 VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
                 arr_char assoc'_closed
           by (simp add: VVV.arr_char "2" B.VVV.ide_char calculation(2))
         ultimately show ?thesis
           using fgh iso_char B.\<alpha>.components_are_iso by auto
       qed
     qed
 
     interpretation L: endofunctor \<open>(\<cdot>)\<close> L
       using endofunctor_L by auto
     interpretation R: endofunctor \<open>(\<cdot>)\<close> R
       using endofunctor_R by auto
 
     interpretation L: faithful_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> L
     proof
       fix f f'
       assume par: "par f f'"
       assume eq: "L f = L f'"
       have "B.par f f'"
         using par inclusion arr_char dom_simp cod_simp by fastforce
       moreover have "B.L f = B.L f'"
       proof -
         have "\<forall>a. Arr a \<longrightarrow> B.arr a"
           by (simp add: inclusion)
         moreover have 1: "\<forall>a. arr a \<longrightarrow> (if arr a then hseq (trg a) a else arr null)"
           using L.preserves_arr by presburger
         moreover have "Arr f \<and> Arr (trg f) \<and> trg\<^sub>B f = src\<^sub>B (trg f)"
           by (simp add: \<open>B.par f f'\<close> arrE par trg_closed trg_def)
         ultimately show ?thesis
           by (metis \<open>B.par f f'\<close> eq hcomp_def hseq_char' par trg_def)
       qed
       ultimately show "f = f'"
         using B.L.is_faithful by blast
     qed
     interpretation L: full_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> L
     proof
       fix f f' \<nu>
       assume f: "ide f" and f': "ide f'" and \<nu>: "\<guillemotleft>\<nu> : L f \<Rightarrow> L f'\<guillemotright>"
       have 1: "L f = trg\<^sub>B f \<star>\<^sub>B f \<and> L f' = trg\<^sub>B f' \<star>\<^sub>B f'"
         using f f' hcomp_def trg_def arr_char ide_char trg_closed by simp
       have 2: "\<guillemotleft>\<nu> : trg\<^sub>B f \<star>\<^sub>B f \<Rightarrow>\<^sub>B trg\<^sub>B f' \<star>\<^sub>B f'\<guillemotright>"
         using 1 f f' \<nu> hcomp_def trg_def src_def inclusion
               dom_char cod_char hseq_char' arr_char ide_char trg_closed null_char
         by (simp add: arr_char in_hom_char)
       show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> L \<mu> = \<nu>"
       proof -
         let ?\<mu> = "B.\<ll> f' \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B B.inv (B.\<ll> f)"
         have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
         proof -
           have "\<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
             using f f' \<nu> 2 B.\<ll>_ide_simp lunit'_closed lunit_closed' ide_char by auto
           thus ?thesis
             using f f' \<nu> in_hom_char arr_char comp_closed ide_char
                   lunit'_closed lunit_closed
             by (metis (no_types, lifting) B.arrI B.seqE in_homE)
         qed
         have \<mu>_eq: "?\<mu> = B.\<ll> f' \<cdot> \<nu> \<cdot> B.inv (B.\<ll> f)"
         proof -
           have "?\<mu> = B.\<ll> f' \<cdot> \<nu> \<cdot>\<^sub>B B.inv (B.\<ll> f)"
-            using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
-                 lunit'_closed lunit_closed
-            by (metis (no_types, lifting) B.seqE in_homE)
+            by (metis (no_types, lifting) B.arrI B.seqE \<mu> \<nu> arrE comp_closed f f'
+                ide_char in_hom_char local.comp_def lunit'_closed lunit_closed)
           also have "... = B.\<ll> f' \<cdot> \<nu> \<cdot> B.inv (B.\<ll> f)"
             using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
                   lunit'_closed lunit_closed
             by (metis (no_types, lifting) B.seqE in_homE)
           finally show ?thesis by simp
         qed
         have "L ?\<mu> = \<nu>"
         proof -
           have "L ?\<mu> = trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>"
             using \<mu> \<mu>_eq hcomp_def trg_def inclusion arr_char trg_closed by auto
           also have "... = (trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) \<cdot>\<^sub>B (B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f)"
           proof -
             have "B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f = trg\<^sub>B f \<star>\<^sub>B f"
               using f ide_char B.comp_inv_arr B.inv_is_inverse by auto
             moreover have "B.dom (trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) = trg\<^sub>B f \<star>\<^sub>B f"
             proof -
               have "B.dom (trg\<^sub>B ?\<mu>) = trg\<^sub>B f"
                 using f \<mu> B.vconn_implies_hpar(2) by force
               moreover have "B.dom ?\<mu> = f"
                 using \<mu> by blast
               ultimately show ?thesis
                 using B.hcomp_simps [of "trg\<^sub>B ?\<mu>" ?\<mu>]
                 by (metis (no_types, lifting) B.hseqI' B.ideD(1) B.src_trg
                     B.trg.preserves_reflects_arr B.trg_dom f ide_char)
             qed
             ultimately show ?thesis
               using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char by auto
           qed
           also have "... = ((trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.inv (B.\<ll> f)) \<cdot>\<^sub>B B.\<ll> f"
             using B.comp_assoc by simp
           also have "... = (B.inv (B.\<ll> f') \<cdot>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.\<ll> f"
             using \<mu> \<mu>_eq B.\<ll>'.naturality [of ?\<mu>] by auto
           also have "... = (B.inv (B.\<ll> f') \<cdot>\<^sub>B B.\<ll> f') \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B (B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f)"
             using \<mu> \<mu>_eq arr_char arrI comp_simp B.comp_assoc by metis
           also have "... = \<nu>"
             using f f' \<nu> 2 B.comp_arr_dom B.comp_cod_arr ide_char
                   B.\<ll>.components_are_iso B.\<ll>_ide_simp B.comp_inv_arr'
             by auto
           finally show ?thesis by blast
         qed
         thus ?thesis
           using \<mu> by auto
       qed
     qed
 
     interpretation R: faithful_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> R
     proof
       fix f f'
       assume par: "par f f'"
       assume eq: "R f = R f'"
       have "B.par f f'"
         using par inclusion arr_char dom_simp cod_simp by fastforce
       moreover have "B.R f = B.R f'"
       proof -
         have "\<forall>a. Arr a \<longrightarrow> B.arr a"
           by (simp add: inclusion)
         moreover have 1: "\<forall>a. arr a \<longrightarrow> (if arr a then hseq a (src a) else arr null)"
           using R.preserves_arr by presburger
         moreover have "arr f \<and> arr (src f) \<and> trg\<^sub>B (src f) = src\<^sub>B f"
           by (meson 1 hcomp_def hseq_char' par)
         ultimately show ?thesis
           by (metis \<open>B.par f f'\<close> eq hcomp_def hseq_char' src_def)
       qed
       ultimately show "f = f'"
         using B.R.is_faithful by blast
     qed
     interpretation R: full_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> R
     proof
       fix f f' \<nu>
       assume f: "ide f" and f': "ide f'" and \<nu>: "\<guillemotleft>\<nu> : R f \<Rightarrow> R f'\<guillemotright>"
       have 1: "R f = f \<star>\<^sub>B src\<^sub>B f \<and> R f' = f' \<star>\<^sub>B src\<^sub>B f'"
         using f f' hcomp_def src_def arr_char ide_char src_closed by simp
       have 2: "\<guillemotleft>\<nu> : f \<star>\<^sub>B src\<^sub>B f \<Rightarrow>\<^sub>B f' \<star>\<^sub>B src\<^sub>B f'\<guillemotright>"
         using 1 f f' \<nu> hcomp_def trg_def src_def inclusion
               dom_char cod_char hseq_char' arr_char ide_char trg_closed null_char
         by (simp add: arr_char in_hom_char)
       show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> R \<mu> = \<nu>"
       proof -
         let ?\<mu> = "B.\<rr> f' \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B B.inv (B.\<rr> f)"
         have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
         proof -
           have "\<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
             using f f' \<nu> 2 B.\<rr>_ide_simp runit'_closed runit_closed' ide_char by auto
           thus ?thesis
             by (metis (no_types, lifting) B.arrI B.seqE \<nu> arrE arrI comp_closed f f'
                 ide_char in_hom_char runit'_closed runit_closed')
         qed
         have \<mu>_eq: "?\<mu> = B.\<rr> f' \<cdot> \<nu> \<cdot> B.inv (B.\<rr> f)"
         proof -
           have "?\<mu> = B.\<rr> f' \<cdot> \<nu> \<cdot>\<^sub>B B.inv (B.\<rr> f)"
             using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
                  runit'_closed runit_closed
             by (metis (no_types, lifting) B.seqE in_homE)
           also have "... = B.\<rr> f' \<cdot> \<nu> \<cdot> B.inv (B.\<rr> f)"
             using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
                   runit'_closed runit_closed
             by (metis (no_types, lifting) B.arrI B.comp_in_homE in_hom_char)
           finally show ?thesis by simp
         qed
         have "R ?\<mu> = \<nu>"
         proof -
           have "R ?\<mu> = ?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>"
             using \<mu> \<mu>_eq hcomp_def src_def inclusion arr_char src_closed by auto
           also have "... = (?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) \<cdot>\<^sub>B (B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f)"
           proof -
             have "B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f = f \<star>\<^sub>B src\<^sub>B f"
               using f ide_char B.comp_inv_arr B.inv_is_inverse by auto
             moreover have "B.dom (?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) = f \<star>\<^sub>B src\<^sub>B f"
               using f \<mu> \<mu>_eq ide_char arr_char B.src_dom [of ?\<mu>]
               by (metis (no_types, lifting) B.R.as_nat_trans.preserves_comp_2 B.R.preserves_seq
                   B.dom_src B.hcomp_simps(3) B.in_homE)
             ultimately show ?thesis
               using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char by auto
           qed
           also have "... = ((?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.inv (B.\<rr> f)) \<cdot>\<^sub>B B.\<rr> f"
             using B.comp_assoc by simp
           also have "... = (B.inv (B.\<rr> f') \<cdot>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.\<rr> f"
             using \<mu> \<mu>_eq B.\<rr>'.naturality [of ?\<mu>] by auto
           also have "... = (B.inv (B.\<rr> f') \<cdot>\<^sub>B B.\<rr> f') \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B (B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f)"
             using \<mu> \<mu>_eq arr_char arrI comp_simp B.comp_assoc by metis
           also have "... = \<nu>"
             using f f' \<nu> 2 B.comp_arr_dom B.comp_cod_arr ide_char
                   B.\<ll>.components_are_iso B.\<ll>_ide_simp B.comp_inv_arr'
             by auto
           finally show ?thesis by blast
         qed
         thus ?thesis
           using \<mu> by blast
       qed
     qed
 
     interpretation bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
     proof
       show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
       proof (intro in_homI)
         fix a
         assume a: "obj a"
         have 1: "Arr (\<i> a)"
           using a obj_def src_def trg_def in_hom_char B.unit_in_hom
                 arr_char hcomp_def B.obj_def ide_char objE hcomp_closed
           by (metis (no_types, lifting) B.\<ll>_ide_simp B.unitor_coincidence(1) inclusion lunit_closed)
         show 2: "arr \<i>[a]"
           using 1 arr_char by simp
         show "dom \<i>[a] = a \<star> a"
           using a 2 dom_char
           by (metis (full_types) B.objI_trg B.unit_simps(4) R.preserves_reflects_arr
               hcomp_def hseq_char' inclusion objE obj_simps(1)
               subcategory.arrE subcategory_axioms trg_def)
         show "cod \<i>[a] = a"
           using a 2 cod_char
           by (metis B.obj_def' B.unit_simps(5) inclusion objE obj_simps(1)
               subcategory.arrE subcategory_axioms trg_def)
       qed
       show "\<And>a. obj a \<Longrightarrow> iso (\<i> a)"
       proof -
         fix a
         assume a: "obj a"
         have 1: "trg\<^sub>B a = src\<^sub>B a"
           using a obj_def src_def trg_def B.obj_def arr_char
           by (metis horizontal_homs.objE horizontal_homs_axioms)
         have 2: "Arr (\<i> a)"
           using a 1 obj_def src_def trg_def in_hom_char B.unit_in_hom
                 arr_char hcomp_def B.obj_def ide_char objE hcomp_closed
           by (metis (no_types, lifting) B.\<ll>_ide_simp B.unitor_coincidence(1) inclusion lunit_closed)
         have "iso (B.\<ll> a)"
           using a 2 obj_def B.iso_unit iso_char arr_char lunit_closed lunit'_closed B.iso_lunit
           apply simp
           by (metis (no_types, lifting) B.\<ll>.components_are_iso B.ide_src inclusion src_def)
         thus "iso (\<i> a)"
           using a 2 obj_def B.iso_unit iso_char arr_char B.unitor_coincidence
           apply simp
           by (metis (no_types, lifting) B.\<ll>_ide_simp B.ide_src B.obj_src inclusion src_def)
       qed
       show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k;
                         src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
                            (f \<star> \<a> g h k) \<cdot> \<a> f (g \<star> h) k \<cdot> (\<a> f g h \<star> k) =
                            \<a> f g (h \<star> k) \<cdot> \<a> (f \<star> g) h k"
         using B.pentagon VVV.arr_char VV.arr_char hcomp_def assoc_closed arr_char comp_char
               hcomp_closed comp_closed ide_char inclusion src_def trg_def
         by simp       
     qed
 
     proposition is_bicategory:
     shows "bicategory (\<cdot>) (\<star>) \<a> \<i> src trg"
       ..
 
     lemma obj_char:
     shows "obj a \<longleftrightarrow> arr a \<and> B.obj a"
     proof
       assume a: "obj a"
       show "arr a \<and> B.obj a"
         using a obj_def B.obj_def src_def arr_char inclusion by metis
       next
       assume a: "arr a \<and> B.obj a"
       have "src a = a"
         using a src_def by auto
       thus "obj a"
         using a obj_def by simp
     qed
 
     lemma hcomp_char:
     shows "hcomp = (\<lambda>f g. if arr f \<and> arr g \<and> src f = trg g then f \<star>\<^sub>B g else null)"
       using hcomp_def src_def trg_def by metis
 
     lemma assoc_simp:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "\<a> f g h = \<a>\<^sub>B f g h"
       using assms VVV.arr_char VV.arr_char by auto
 
     lemma assoc'_simp:
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "\<a>' f g h = B.\<a>' f g h"
     proof -
       have "\<a>' f g h = B.inv (\<a>\<^sub>B f g h)"
         using assms inv_char by fastforce
       also have "... = B.\<a>' f g h"
         using assms ide_char src_def trg_def
               B.VVV.ide_char B.VVV.arr_char B.VV.arr_char
         by force
       finally show ?thesis by blast
     qed
 
     lemma lunit_simp:
     assumes "ide f"
     shows "lunit f = B.lunit f"
     proof -
       have "B.lunit f = lunit f"
       proof (intro lunit_eqI)
         show "ide f" by fact
         show 1: "\<guillemotleft>B.lunit f : trg f \<star> f \<Rightarrow> f\<guillemotright>"
         proof
           show 2: "arr (B.lunit f)"
             using assms arr_char lunit_closed
             by (simp add: arr_char B.\<ll>_ide_simp ide_char)
           show "dom (B.lunit f) = trg f \<star> f"
             using assms 2 dom_char hcomp_char ide_char src_trg trg.preserves_arr trg_def
             by auto
           show "cod (B.lunit f) = f"
             using assms 2 in_hom_char
             by (simp add: cod_simp ide_char)
         qed
         show "trg f \<star> B.lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>' (trg f) (trg f) f"
         proof -
           have "trg f \<star> B.lunit f = trg\<^sub>B f \<star>\<^sub>B B.lunit f"
             using assms 1 arr_char hcomp_char
             by (metis (no_types, lifting) ideD(1) src_trg trg.preserves_reflects_arr
                 trg_def vconn_implies_hpar(2,4))
           also have "... = (\<i>[trg f] \<star>\<^sub>B f) \<cdot>\<^sub>B B.\<a>' (trg f) (trg f) f"
             using assms ide_char B.lunit_char(2) trg_def by simp
           also have "... = (\<i>[trg f] \<star>\<^sub>B f) \<cdot>\<^sub>B \<a>' (trg f) (trg f) f"
             using assms assoc'_simp [of "trg f" "trg f" f] by simp
           also have "... = (\<i>[trg f] \<star> f) \<cdot>\<^sub>B \<a>' (trg f) (trg f) f"
             using assms hcomp_char by simp
           also have "... = (\<i>[trg f] \<star> f) \<cdot> \<a>' (trg f) (trg f) f"
             using assms seq_char [of "\<i>[trg f] \<star> f" "\<a>' (trg f) (trg f) f"]
                   comp_char [of "\<i>[trg f] \<star> f" "\<a>' (trg f) (trg f) f"]
             by simp
           finally show ?thesis by blast
         qed
       qed
       thus ?thesis by simp
     qed
 
     lemma lunit'_simp:
     assumes "ide f"
     shows "lunit' f = B.lunit' f"
       using assms inv_char [of "lunit f"] lunit_simp by fastforce
 
     lemma runit_simp:
     assumes "ide f"
     shows "runit f = B.runit f"
     proof -
       have "B.runit f = runit f"
       proof (intro runit_eqI)
         show "ide f" by fact
         show 1: "\<guillemotleft>B.runit f : f \<star> src f \<Rightarrow> f\<guillemotright>"
         proof
           show 2: "arr (B.runit f)"
             using assms arr_char runit_closed
             by (simp add: arr_char B.\<rr>_ide_simp ide_char)
           show "dom (B.runit f) = f \<star> src f"
             using assms 2 dom_char hcomp_char
             by (metis (no_types, lifting) B.runit_simps(4) ide_char src.preserves_reflects_arr
                 src_def trg_src)
           show "cod (B.runit f) = f"
             using assms 2 in_hom_char
             by (simp add: cod_simp ide_char)
         qed
         show "B.runit f \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a> f (src f) (src f)"
         proof -
           have "B.runit f \<star> src f = B.runit f \<star>\<^sub>B src\<^sub>B f"
             using assms 1 arr_char hcomp_char
             by (metis (no_types, lifting) ideD(1) src.preserves_reflects_arr src_def
                 trg_src vconn_implies_hpar(1,3))
           also have "... = (f \<star>\<^sub>B \<i>[src f]) \<cdot>\<^sub>B \<a>\<^sub>B f (src f) (src f)"
             using assms ide_char B.runit_char(2) src_def by simp
           also have "... = (f \<star>\<^sub>B \<i>[src f]) \<cdot>\<^sub>B \<a> f (src f) (src f)"
             using assms assoc_simp by simp
           also have "... = (f \<star> \<i>[src f]) \<cdot>\<^sub>B \<a> f (src f) (src f)"
             using assms 1 hcomp_char by simp
           also have "... = (f \<star> \<i>[src f]) \<cdot> \<a> f (src f) (src f)"
           proof -
             have "B.seq (f \<star> \<i>[src f]) (\<a> f (src f) (src f))"
               using assms seq_char [of "f \<star> \<i>[src f]" "\<a> f (src f) (src f)"] by simp
             thus ?thesis
               using assms comp_char [of "f \<star> \<i>[src f]" "\<a> f (src f) (src f)"] by simp
           qed
           finally show ?thesis by blast
         qed
       qed
       thus ?thesis by simp
     qed
 
     lemma runit'_simp:
     assumes "ide f"
     shows "runit' f = B.runit' f"
       using assms inv_char [of "runit f"] runit_simp by fastforce
 
     lemma comp_eqI [intro]:
     assumes "seq f g" and "f = f'" and "g = g'"
     shows "f \<cdot> g = f' \<cdot>\<^sub>B g'"
       using assms comp_char ext ext not_arr_null by auto
 
     lemma comp_eqI' [intro]:
     assumes "seq f g" and "f = f'" and "g = g'"
     shows "f \<cdot>\<^sub>B g = f' \<cdot> g'"
       using assms comp_char ext ext not_arr_null by auto
 
     lemma hcomp_eqI [intro]:
     assumes "hseq f g" and "f = f'" and "g = g'"
     shows "f \<star> g = f' \<star>\<^sub>B g'"
       using assms hcomp_char not_arr_null by auto
 
     lemma hcomp_eqI' [intro]:
     assumes "hseq f g" and "f = f'" and "g = g'"
     shows "f \<star>\<^sub>B g = f' \<star> g'"
       using assms hcomp_char not_arr_null by auto
 
     lemma arr_compI:
     assumes "seq f g"
     shows "arr (f \<cdot>\<^sub>B g)"
       using assms seq_char dom_char cod_char
       by (metis (no_types, lifting) comp_simp)
 
     lemma arr_hcompI:
     assumes "hseq f g"
     shows "arr (f \<star>\<^sub>B g)"
       using assms hseq_char src_def trg_def hcomp_eqI' by auto
 
   end
 
   sublocale subbicategory \<subseteq> bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
     using is_bicategory by auto
 
   subsection "The Sub-bicategory of Endo-arrows of an Object"
 
   text \<open>
     We now consider the sub-bicategory consisting of all arrows having the same
     object \<open>a\<close> both as their source and their target and we show that the resulting structure
     is a monoidal category.  We actually prove a slightly more general result,
     in which the unit of the monoidal category is taken to be an arbitrary isomorphism
     \<open>\<guillemotleft>\<omega> : w \<star>\<^sub>B w \<Rightarrow> w\<guillemotright>\<close> with \<open>w\<close> isomorphic to \<open>a\<close>, rather than the particular choice
     \<open>\<guillemotleft>\<i>[a] : a \<star>\<^sub>B a \<Rightarrow> a\<guillemotright>\<close> made by the ambient bicategory.
   \<close>
 
   locale subbicategory_at_object =
     B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
     subbicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B \<open>\<lambda>\<mu>. B.arr \<mu> \<and> src\<^sub>B \<mu> = a \<and> trg\<^sub>B \<mu> = a\<close>
   for V :: "'a comp"                 (infixr "\<cdot>\<^sub>B" 55)
   and H :: "'a comp"                 (infixr "\<star>\<^sub>B" 55)
   and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"    ("\<a>\<^sub>B[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"                 ("\<i>[_]")
   and src\<^sub>B :: "'a \<Rightarrow> 'a"
   and trg\<^sub>B :: "'a \<Rightarrow> 'a"
   and a :: "'a"
   and w :: "'a"
   and \<omega> :: "'a" +
   assumes obj_a: "B.obj a"
   and isomorphic_a_w: "B.isomorphic a w"
   and \<omega>_in_vhom: "\<guillemotleft>\<omega> : w \<star>\<^sub>B w \<Rightarrow> w\<guillemotright>"
   and \<omega>_is_iso: "B.iso \<omega>"
   begin
 
     notation hcomp  (infixr "\<star>" 53)
 
     lemma arr_simps:
     assumes "arr \<mu>"
     shows "src \<mu> = a" and "trg \<mu> = a"
       apply (metis (no_types, lifting) arrE assms src_def)
       by (metis (no_types, lifting) arrE assms trg_def)
 
     lemma \<omega>_simps [simp]:
     shows "arr \<omega>"
     and "src \<omega> = a" and "trg \<omega> = a"
     and "dom \<omega> = w \<star>\<^sub>B w" and "cod \<omega> = w"
       using isomorphic_a_w \<omega>_in_vhom in_hom_char arr_simps by auto
 
     lemma ide_w:
     shows "B.ide w"
       using isomorphic_a_w B.isomorphic_def by auto
 
     lemma w_simps [simp]:
     shows "ide w" and "B.ide w"
     and "src w = a" and "trg w = a" and "src\<^sub>B w = a" and "trg\<^sub>B w = a"
     and "dom w = w" and "cod w = w"
     proof -
       show w: "ide w"
         using \<omega>_in_vhom ide_cod by blast
       show "B.ide w"
         using w ide_char by simp
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : a \<Rightarrow>\<^sub>B w\<guillemotright> \<and> B.iso \<phi>"
         using isomorphic_a_w B.isomorphic_def by auto
       show "src\<^sub>B w = a"
         using obj_a w \<phi> B.src_cod by force
       show "trg\<^sub>B w = a"
         using obj_a w \<phi> B.src_cod by force
       show "src w = a"
         using \<open>src\<^sub>B w = a\<close> w ide_w src_def by simp
       show "trg w = a"
         using \<open>src\<^sub>B w = a\<close> w ide_w trg_def
         by (simp add: \<open>trg\<^sub>B w = a\<close>)
       show "dom w = w"
         using w by simp
       show "cod w = w"
         using w by simp
     qed
 
     lemma VxV_arr_eq_VV_arr:
     shows "VxV.arr f \<longleftrightarrow> VV.arr f"
       using inclusion VxV.arr_char VV.arr_char arr_char src_def trg_def
       by auto
 
     lemma VxV_comp_eq_VV_comp:
     shows "VxV.comp = VV.comp"
     proof -
       have "\<And>f g. VxV.comp f g = VV.comp f g"
       proof -
         fix f g
         show "VxV.comp f g = VV.comp f g"
           unfolding VV.comp_def
           using VxV.comp_char arr_simps(1) arr_simps(2)
           apply (cases "seq (fst f) (fst g)", cases "seq (snd f) (snd g)")
           by (elim seqE) auto
       qed
       thus ?thesis by blast
     qed
 
     lemma VxVxV_arr_eq_VVV_arr:
     shows "VxVxV.arr f \<longleftrightarrow> VVV.arr f"
       using VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
       by auto
 
     lemma VxVxV_comp_eq_VVV_comp:
     shows "VxVxV.comp = VVV.comp"
     proof -
       have "\<And>f g. VxVxV.comp f g = VVV.comp f g"
       proof -
         fix f g
         show "VxVxV.comp f g = VVV.comp f g"
         proof (cases "VxVxV.seq f g")
           assume 1: "\<not> VxVxV.seq f g"
           have "VxVxV.comp f g = VxVxV.null"
             using 1 VxVxV.ext by blast
           also have "... = (null, null, null)"
             using VxVxV.null_char VxV.null_char by simp
           also have "... = VVV.null"
             using VVV.null_char VV.null_char by simp
           also have "... = VVV.comp f g"
           proof -
             have "\<not> VVV.seq f g"
               using 1 VVV.seq_char by blast
             thus ?thesis
               by (metis (no_types, lifting) VVV.ext)
           qed
           finally show ?thesis by simp
           next
           assume 1: "VxVxV.seq f g"
           have 2: "B.arr (fst f) \<and> B.arr (fst (snd f)) \<and> B.arr (snd (snd f)) \<and>
                 src\<^sub>B (fst f) = a \<and> src\<^sub>B (fst (snd f)) = a \<and> src\<^sub>B (snd (snd f)) = a \<and>
                 trg\<^sub>B (fst f) = a \<and> trg\<^sub>B (fst (snd f)) = a \<and> trg\<^sub>B (snd (snd f)) = a"
             using 1 VxVxV.seq_char VxV.seq_char arr_char by blast
           have 3: "B.arr (fst g) \<and> B.arr (fst (snd g)) \<and> B.arr (snd (snd g)) \<and>
                    src\<^sub>B (fst g) = a \<and> src\<^sub>B (fst (snd g)) = a \<and> src\<^sub>B (snd (snd g)) = a \<and>
                    trg\<^sub>B (fst g) = a \<and> trg\<^sub>B (fst (snd g)) = a \<and> trg\<^sub>B (snd (snd g)) = a"
             using 1 VxVxV.seq_char VxV.seq_char arr_char by blast
           have 4: "B.seq (fst f) (fst g) \<and> B.seq (fst (snd f)) (fst (snd g)) \<and>
                    B.seq (snd (snd f)) (snd (snd g))"
             using 1 VxVxV.seq_char VxV.seq_char seq_char by blast
           have 5: "VxVxV.comp f g =
                    (fst f \<cdot> fst g, fst (snd f) \<cdot> fst (snd g), snd (snd f) \<cdot> snd (snd g))"
             using 1 2 3 4 VxVxV.seqE VxVxV.comp_char VxV.comp_char seq_char arr_char
             by (metis (no_types, lifting)) 
           also have "... = VVV.comp f g"
             using 1 VVV.comp_char VVV.arr_char VV.arr_char
             apply simp
             using 2 3 5 arrI arr_simps(1) arr_simps(2) by presburger
           finally show ?thesis by blast
         qed
       qed
       thus ?thesis by blast
     qed
  
     interpretation H: "functor" VxV.comp \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
       using H.functor_axioms hcomp_def VxV_comp_eq_VV_comp by simp
 
     interpretation H: binary_endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> ..
 
     lemma HoHV_eq_ToTC:
     shows "HoHV = H.ToTC"
       using HoHV_def H.ToTC_def VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
       by auto
 
     lemma HoVH_eq_ToCT:
     shows "HoVH = H.ToCT"
       using HoVH_def H.ToCT_def VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
       by auto
 
     interpretation ToTC: "functor" VxVxV.comp \<open>(\<cdot>)\<close> H.ToTC
       using HoHV_eq_ToTC VxVxV_comp_eq_VVV_comp HoHV.functor_axioms by simp
     interpretation ToCT: "functor" VxVxV.comp \<open>(\<cdot>)\<close> H.ToCT
       using HoVH_eq_ToCT VxVxV_comp_eq_VVV_comp HoVH.functor_axioms by simp
 
     interpretation \<alpha>: natural_isomorphism VxVxV.comp \<open>(\<cdot>)\<close> H.ToTC H.ToCT \<alpha>
       unfolding \<alpha>_def
       using \<alpha>.natural_isomorphism_axioms HoHV_eq_ToTC HoVH_eq_ToCT \<alpha>_def
             VxVxV_comp_eq_VVV_comp
       by simp
 
     interpretation L: endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close>
     proof
       fix f
       show "\<not> arr f \<Longrightarrow> fst (w, f) \<star> snd (w, f) = null"
         using arr_char hcomp_def by auto
       assume f: "arr f"
       show "hseq (fst (w, f)) (snd (w, f))"
         using f hseq_char arr_char src_def trg_def \<omega>_in_vhom cod_char by simp
       show "dom (fst (w, f) \<star> snd (w, f)) = fst (w, dom f) \<star> snd (w, dom f)"
         using f arr_char hcomp_def dom_simp by simp
       show "cod (fst (w, f) \<star> snd (w, f)) = fst (w, cod f) \<star> snd (w, cod f)"
         using f arr_char hcomp_def cod_simp by simp
       next
       fix f g
       assume fg: "seq g f"
       show "fst (w, g \<cdot> f) \<star> snd (w, g \<cdot> f) = (fst (w, g) \<star> snd (w, g)) \<cdot> (fst (w, f) \<star> snd (w, f))"
         by (simp add: fg whisker_left)
     qed
 
     interpretation L': equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close>
     proof -
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi>"
         using isomorphic_a_w B.isomorphic_symmetric by force
       have "\<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright>"
         using \<phi> in_hom_char
         by (metis (no_types, lifting) B.in_homE B.src_cod B.src_src B.trg_cod B.trg_trg
             \<omega>_in_vhom arr_char arr_cod cod_simp)
       hence \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi> \<and> \<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
         using \<phi> iso_char arr_char by auto
       interpret \<l>: natural_isomorphism \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close>
                      \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close> map \<open>\<lambda>f. \<ll> f \<cdot> (\<phi> \<star> dom f)\<close>
       proof
         fix \<mu>
         show "\<not> arr \<mu> \<Longrightarrow> \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>) = null"
           using \<phi> arr_char dom_char ext
           apply simp
           using comp_null(2) hcomp_def by fastforce
         assume \<mu>: "arr \<mu>"
         have 0: "in_hhom (dom \<mu>) a a"
           using \<mu> arr_char src_dom trg_dom src_def trg_def dom_simp by simp
         have 1: "in_hhom \<phi> a a"
           using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
         have 2: "hseq \<phi> (B.dom \<mu>)"
           using \<mu> 0 1 dom_simp by (intro hseqI) auto
         have 3: "seq (\<ll> \<mu>) (\<phi> \<star> dom \<mu>)"
         proof (intro seqI')
           show "\<guillemotleft>\<phi> \<star> dom \<mu> : w \<star> dom \<mu> \<Rightarrow> a \<star> dom \<mu>\<guillemotright>"
             by (metis (no_types, lifting) 0 \<mu> \<phi> hcomp_in_vhom ide_dom ide_in_hom(2)
                 in_hhom_def w_simps(3))
           show "\<guillemotleft>\<ll> \<mu> : a \<star> dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
             using \<mu> 2 \<ll>.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] arr_simps(2) arr_cod by fastforce
         qed
         show "dom (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = fst (w, dom \<mu>) \<star> snd (w, dom \<mu>)"
         proof -
           have "dom (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = dom \<phi> \<star> dom \<mu>"
             using \<mu> 3 hcomp_simps(3) dom_comp dom_dom
             apply (elim seqE) by auto
           also have "... = fst (w, dom \<mu>) \<star> snd (w, dom \<mu>)"
             using \<omega>_in_vhom \<phi>
             by (metis (no_types, lifting) in_homE prod.sel(1) prod.sel(2))
           finally show ?thesis by simp
         qed
         show "cod (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = map (cod \<mu>)"
         proof -
           have "seq (\<ll> \<mu>) (\<phi> \<star> dom \<mu>)"
             using 3 by simp
           hence "cod (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = cod (\<ll> \<mu>)"
             using cod_comp by blast
           also have "... = map (cod \<mu>)"
             using \<mu> by blast
           finally show ?thesis by blast
         qed
         show "map \<mu> \<cdot> \<ll> (dom \<mu>) \<cdot> (\<phi> \<star> dom (dom \<mu>)) = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
         proof -
           have "map \<mu> \<cdot> \<ll> (dom \<mu>) \<cdot> (\<phi> \<star> dom (dom \<mu>)) = (map \<mu> \<cdot> \<ll> (dom \<mu>)) \<cdot> (\<phi> \<star> dom \<mu>)"
             using \<mu> comp_assoc by simp
           also have "... = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
             using \<mu> \<phi> \<ll>.is_natural_1 by auto
           finally show ?thesis by blast
         qed
         show "(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> dom (cod \<mu>))) \<cdot> (fst (w, \<mu>) \<star> snd (w, \<mu>)) = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
         proof -
           have "(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> dom (cod \<mu>))) \<cdot> (fst (w, \<mu>) \<star> snd (w, \<mu>)) =
                 (\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> B.cod \<mu>)) \<cdot> (w \<star> \<mu>)"
             using \<mu> \<phi> dom_char arr_char \<omega>_in_vhom cod_simp by simp
           also have "... = \<ll> (cod \<mu>) \<cdot> (\<phi> \<cdot> w \<star> B.cod \<mu> \<cdot> \<mu>)"
           proof -
             have "seq \<phi> w"
               using \<phi> \<omega>_in_vhom w_simps(1) by blast
             moreover have 2: "seq (B.cod \<mu>) \<mu>"
               using \<mu> seq_char cod_simp by (simp add: comp_cod_arr)
             moreover have "src \<phi> = trg (B.cod \<mu>)"
               using \<mu> \<phi> 2
               by (metis (no_types, lifting) arr_simps(2) seqE vconn_implies_hpar(1) w_simps(3))
             ultimately show ?thesis
               using interchange comp_assoc by simp
           qed
           also have "... = \<ll> (cod \<mu>) \<cdot> (\<phi> \<star> \<mu>)"
             using \<mu> \<phi> \<omega>_in_vhom comp_arr_dom comp_cod_arr cod_simp
             apply (elim conjE in_homE) by auto
           also have "... = (\<ll> (cod \<mu>) \<cdot> (cod \<phi> \<star> \<mu>)) \<cdot> (\<phi> \<star> dom \<mu>)"
           proof -
             have 1: "seq (cod \<phi>) \<phi>"
               using \<phi> arr_cod_iff_arr dom_cod iso_is_arr seqI by presburger
             moreover have 2: "seq \<mu> (dom \<mu>)"
               using \<mu> by (simp add: comp_arr_dom)
             moreover have "src (cod \<phi>) = trg \<mu>"
               using \<mu> \<phi> arr_cod arr_simps(1-2) iso_is_arr by auto
             ultimately show ?thesis
               using 1 2 interchange [of "cod \<phi>" \<phi> \<mu> "dom \<mu>"] comp_arr_dom comp_cod_arr
                     comp_assoc by fastforce
           qed
           also have "... = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
           proof -
             have "L \<mu> = cod \<phi> \<star> \<mu>"
               using \<mu> \<phi> arr_simps(2) in_homE by auto
             hence "\<ll> (cod \<mu>) \<cdot> (cod \<phi> \<star> \<mu>) = \<ll> \<mu>"
               using \<mu> \<ll>.is_natural_2 [of \<mu>] by simp
             thus ?thesis by simp
           qed
           finally show ?thesis by simp
         qed
         next
         show "\<And>f. ide f \<Longrightarrow> iso (\<ll> f \<cdot> (\<phi> \<star> dom f))"
         proof -
           fix f
           assume f: "ide f"
           have "iso (\<ll> f)"
             using f iso_lunit by simp
           moreover have "iso (\<phi> \<star> dom f)"
             using \<phi> f src_def trg_def ide_char arr_char
             apply (intro iso_hcomp, simp_all)
             by (metis (no_types, lifting) in_homE)
           moreover have "seq (\<ll> f) (\<phi> \<star> dom f)"
           proof (intro seqI')
             show " \<guillemotleft>\<ll> f : a \<star> f \<Rightarrow> f\<guillemotright>"
               using f lunit_in_hom(2) \<ll>_ide_simp ide_char arr_char trg_def by simp
             show "\<guillemotleft>\<phi> \<star> dom f : w \<star> f \<Rightarrow> a \<star> f\<guillemotright>"
               using \<phi> f ide_char arr_char hcomp_def src_def trg_def obj_a ide_in_hom
                     in_hom_char
               by (intro hcomp_in_vhom, auto)
           qed
           ultimately show "iso (\<ll> f \<cdot> (\<phi> \<star> dom f))"
             using isos_compose by simp
         qed
       qed
       show "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (w, f) \<star> snd (w, f))"
         using \<l>.natural_isomorphism_axioms L.isomorphic_to_identity_is_equivalence by simp
     qed
     interpretation L: equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f)\<close>
     proof -
       have "(\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f)) = (\<lambda>f. fst (w, f) \<star> snd (w, f))"
         using \<omega>_in_vhom by simp
       thus "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f))"
         using L'.equivalence_functor_axioms by simp
     qed
 
     interpretation R: endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close>
     proof
       fix f
       show "\<not> arr f \<Longrightarrow> fst (f, w) \<star> snd (f, w) = null"
         using arr_char hcomp_def by auto
       assume f: "arr f"
       show "hseq (fst (f, w)) (snd (f, w))"
         using f hseq_char arr_char src_def trg_def \<omega>_in_vhom cod_char isomorphic_a_w
               B.isomorphic_def in_hom_char
         by simp
       show "dom (fst (f, w) \<star> snd (f, w)) = fst (dom f, w) \<star> snd (dom f, w)"
         using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom by simp
       show "cod (fst (f, w) \<star> snd (f, w)) = fst (cod f, w) \<star> snd (cod f, w)"
         using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom by simp
       next
       fix f g
       assume fg: "seq g f"
       have 1: "a \<cdot>\<^sub>B a = a"
         using obj_a by auto
       show "fst (g \<cdot> f, w) \<star> snd (g \<cdot> f, w) = (fst (g, w) \<star> snd (g, w)) \<cdot> (fst (f, w) \<star> snd (f, w))"
         by (simp add: fg whisker_right)
     qed
 
     interpretation R': equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close>
     proof -
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi>"
         using isomorphic_a_w B.isomorphic_symmetric by force
       have "\<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright>"
         using \<phi> in_hom_char
         by (metis (no_types, lifting) B.in_homE B.src_cod B.src_src B.trg_cod B.trg_trg
             \<omega>_in_vhom arr_char arr_cod cod_simp)
       hence \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi> \<and> \<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
         using \<phi> iso_char arr_char by auto
       interpret \<r>: natural_isomorphism comp comp
                      \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close> map \<open>\<lambda>f. \<rr> f \<cdot> (dom f \<star> \<phi>)\<close>
       proof
         fix \<mu>
         show "\<not> arr \<mu> \<Longrightarrow> \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>) = null"
           using \<phi> arr_char dom_char ext
           apply simp
           using comp_null(2) hcomp_def by fastforce
         assume \<mu>: "arr \<mu>"
         have 0: "in_hhom (dom \<mu>) a a"
           using \<mu> arr_char src_dom trg_dom src_def trg_def dom_simp by simp
         have 1: "in_hhom \<phi> a a"
           using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
         have 2: "hseq (B.dom \<mu>) \<phi>"
           using \<mu> 0 1 dom_simp hseqI by auto
         have 3: "seq (\<rr> \<mu>) (dom \<mu> \<star> \<phi>)"
         proof (intro seqI')
           show "\<guillemotleft>dom \<mu> \<star> \<phi> : dom \<mu> \<star> w \<Rightarrow> dom \<mu> \<star> a\<guillemotright>"
             by (metis (no_types, lifting) "0" "1" \<mu> \<phi> hcomp_in_vhom hseqI hseq_char
                 ide_dom ide_in_hom(2) vconn_implies_hpar(2))
           show "\<guillemotleft>\<rr> \<mu> : dom \<mu> \<star> a \<Rightarrow> cod \<mu>\<guillemotright>"
             using \<mu> 2 \<rr>.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] arr_simps(2) arr_cod
                   dom_simp cod_simp
             by fastforce
         qed
         show "dom (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = fst (dom \<mu>, w) \<star> snd (dom \<mu>, w)"
         proof -
           have "dom (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = dom \<mu> \<star> dom \<phi>"
             using \<mu> 3 hcomp_simps(3) dom_comp dom_dom
             apply (elim seqE) by auto
           also have "... = fst (dom \<mu>, w) \<star> snd (dom \<mu>, w)"
             using \<omega>_in_vhom \<phi>
             by (metis (no_types, lifting) in_homE prod.sel(1) prod.sel(2))
           finally show ?thesis by simp
         qed
         show "cod (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = map (cod \<mu>)"
         proof -
           have "seq (\<rr> \<mu>) (dom \<mu> \<star> \<phi>)"
             using 3 by simp
           hence "cod (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = cod (\<rr> \<mu>)"
             using cod_comp by blast
           also have "... = map (cod \<mu>)"
             using \<mu> by blast
           finally show ?thesis by blast
         qed
         show "map \<mu> \<cdot> \<rr> (dom \<mu>) \<cdot> (dom (dom \<mu>) \<star> \<phi>) = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
         proof -
           have "map \<mu> \<cdot> \<rr> (dom \<mu>) \<cdot> (dom (dom \<mu>) \<star> \<phi>) =
                 (map \<mu> \<cdot> \<rr> (dom \<mu>)) \<cdot> (dom (dom \<mu>) \<star> \<phi>)"
             using comp_assoc by simp
           also have "... = (map \<mu> \<cdot> \<rr> (dom \<mu>)) \<cdot> (dom \<mu> \<star> \<phi>)"
             using \<mu> dom_dom by simp
           also have "... = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
             using \<mu> \<phi> \<rr>.is_natural_1 by auto
           finally show ?thesis by blast
         qed
         show "(\<rr> (cod \<mu>) \<cdot> (dom (cod \<mu>) \<star> \<phi>)) \<cdot> (fst (\<mu>, w) \<star> snd (\<mu>, w)) = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
         proof -
           have "(\<rr> (cod \<mu>) \<cdot> (dom (cod \<mu>) \<star> \<phi>)) \<cdot> (fst (\<mu>, w) \<star> snd (\<mu>, w)) =
                 (\<rr> (cod \<mu>) \<cdot> (B.cod \<mu> \<star> \<phi>)) \<cdot> (\<mu> \<star> w)"
             using \<mu> \<phi> dom_char arr_char \<omega>_in_vhom cod_simp by simp
           also have "... = \<rr> (cod \<mu>) \<cdot> (B.cod \<mu> \<cdot> \<mu> \<star> \<phi> \<cdot> w)"
           proof -
             have 2: "seq \<phi> w"
               using \<phi> \<omega>_in_vhom w_simps(1) by blast
             moreover have "seq (B.cod \<mu>) \<mu>"
               using \<mu> seq_char cod_simp by (simp add: comp_cod_arr)
             moreover have "src (B.cod \<mu>) = trg \<phi>"
               using \<mu> \<phi> 2
               using arr_simps(1) calculation(2) seq_char vconn_implies_hpar(2) by force
             ultimately show ?thesis
               using interchange comp_assoc by simp
           qed
           also have "... = \<rr> (cod \<mu>) \<cdot> (\<mu> \<star> \<phi>)"
             using \<mu> \<phi> \<omega>_in_vhom comp_arr_dom comp_cod_arr cod_simp
             apply (elim conjE in_homE) by auto
           also have "... = (\<rr> (cod \<mu>) \<cdot> (\<mu> \<star> cod \<phi>)) \<cdot> (dom \<mu> \<star> \<phi>)"
           proof -
             have "(\<mu> \<star> cod \<phi>) \<cdot> (dom \<mu> \<star> \<phi>) = \<mu> \<star> \<phi>"
             proof -
               have "seq \<mu> (dom \<mu>)"
                 using \<mu> by (simp add: comp_arr_dom)
               moreover have "seq (cod \<phi>) \<phi>"
                 using \<phi> iso_is_arr arr_cod dom_cod by auto
               moreover have "src \<mu> = trg (cod \<phi>)"
                 using \<mu> \<phi> 2
                 by (metis (no_types, lifting) arr_simps(1) arr_simps(2) calculation(2) seqE)
               ultimately show ?thesis
                 using \<mu> \<phi> iso_is_arr comp_arr_dom comp_cod_arr
                       interchange [of \<mu> "dom \<mu>" "cod \<phi>" \<phi>]
                 by simp
             qed
             thus ?thesis
               using comp_assoc by simp
           qed
           also have "... = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
           proof -
             have "\<mu> \<star> cod \<phi> = R \<mu>"
               using \<mu> \<phi> arr_simps(1) in_homE by auto
             hence "\<rr> (cod \<mu>) \<cdot> (\<mu> \<star> cod \<phi>) = \<rr> \<mu>"
               using \<mu> \<phi> \<rr>.is_natural_2 by simp
             thus ?thesis by simp
           qed
           finally show ?thesis by simp
         qed
         next
         show "\<And>f. ide f \<Longrightarrow> iso (\<rr> f \<cdot> (dom f \<star> \<phi>))"
         proof -
           fix f
           assume f: "ide f"
           have 1: "iso (\<rr> f)"
             using f iso_lunit by simp
           moreover have 2: "iso (dom f \<star> \<phi>)"
             using \<phi> f src_def trg_def ide_char arr_char
             apply (intro iso_hcomp, simp_all)
             by (metis (no_types, lifting) in_homE)
           moreover have "seq (\<rr> f) (dom f \<star> \<phi>)"
           proof (intro seqI')
             show "\<guillemotleft>\<rr> f : f \<star> a \<Rightarrow> f\<guillemotright>"
               using f runit_in_hom(2) \<rr>_ide_simp ide_char arr_char src_def by simp
             show "\<guillemotleft>dom f \<star> \<phi> : f \<star> w \<Rightarrow> f \<star> a\<guillemotright>"
               using \<phi> f ide_char arr_char hcomp_def src_def trg_def obj_a ide_in_hom
                     in_hom_char
               by (intro hcomp_in_vhom, auto)
           qed
           ultimately show "iso (\<rr> f \<cdot> (dom f \<star> \<phi>))"
-            using isos_compose by simp
+            using isos_compose by blast
          qed
       qed
       show "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (f, w) \<star> snd (f, w))"
         using \<r>.natural_isomorphism_axioms R.isomorphic_to_identity_is_equivalence by simp
     qed
     interpretation R: equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>)\<close>
     proof -
       have "(\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>)) = (\<lambda>f. fst (f, w) \<star> snd (f, w))"
         using \<omega>_in_vhom by simp
       thus "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>))"
         using R'.equivalence_functor_axioms by simp
     qed
 
     interpretation M: monoidal_category \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> \<alpha> \<omega>
     proof
       show "\<guillemotleft>\<omega> : fst (cod \<omega>, cod \<omega>) \<star> snd (cod \<omega>, cod \<omega>) \<Rightarrow> cod \<omega>\<guillemotright>"
         using \<omega>_in_vhom hcomp_def arr_char by auto
       show "iso \<omega>"
         using \<omega>_is_iso iso_char arr_char inv_char \<omega>_in_vhom by auto
       show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k \<rbrakk> \<Longrightarrow>
                        (fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
                          \<alpha> (f, hcomp (fst (g, h)) (snd (g, h)), k) \<cdot>
                          (fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
                        \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
       proof -
         fix f g h k
         assume f: "ide f" and g: "ide g" and h: "ide h" and k: "ide k"
         have 1: "VVV.arr (f, g, h) \<and> VVV.arr (g, h, k)"
           using f g h k VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
           by simp
         have 2: "VVV.arr (f, g \<star> h, k)"
           using f g h k 1 HoHV_def VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
                 VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp hseqI'
           by auto
         have 3: "VVV.arr (f, g, h \<star> k)"
           using f g h k 1 VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
                 VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp H.preserves_reflects_arr hseqI'
           by auto
         have 4: "VVV.arr (f \<star> g, h, k)"
           using f g h k VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char hseq_char
                 VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp
           by force
         have "(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
                 \<alpha> (f, fst (g, h) \<star> snd (g, h), k) \<cdot>
                 (fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
               (f \<star> \<a>\<^sub>B[g, h, k]) \<cdot> \<a>\<^sub>B[f, g \<star> h, k] \<cdot> (\<a>\<^sub>B[f, g, h] \<star> k)"
           unfolding \<alpha>_def by (simp add: 1 2)
         also have "... = (f \<star>\<^sub>B \<a>\<^sub>B g h k) \<cdot> \<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot> (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
           unfolding hcomp_def
           using f g h k src_def trg_def arr_char
           using assoc_closed ide_char by auto
         also have "... = (f \<star>\<^sub>B \<a>\<^sub>B g h k) \<cdot>\<^sub>B \<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
         proof -
           have "arr (f \<star>\<^sub>B \<a>\<^sub>B g h k)"
             using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
           moreover have "arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k)"
             using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
           moreover have "arr (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
             using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
           moreover have "arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B (\<a>\<^sub>B f g h \<star>\<^sub>B k))"
             unfolding arr_char
             apply (intro conjI)
             using ide_char arr_char assoc_closed f g h hcomp_closed k B.HoHV_def B.HoVH_def
             apply (intro B.seqI)
                 apply simp_all
           proof -
             have 1: "B.arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k)"
               using f g h k ide_char arr_char B.HoHV_def B.HoVH_def
               apply (intro B.seqI)
               by auto
             show "src\<^sub>B (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k) = a"
               using 1 f g h k arr_char B.src_vcomp B.vseq_implies_hpar(1) by fastforce
             show "trg\<^sub>B (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k) = a"
               using "1" arr_char calculation(2-3) by auto
           qed
           ultimately show ?thesis
             using B.ext comp_char by (metis (no_types, lifting))
         qed
         also have "... = \<a>\<^sub>B f g (h \<star>\<^sub>B k) \<cdot>\<^sub>B \<a>\<^sub>B (f \<star>\<^sub>B g) h k"
           using f g h k src_def trg_def arr_char ide_char B.pentagon
           using "4" \<alpha>_def hcomp_def by auto
         also have "... = \<a>\<^sub>B f g (h \<star>\<^sub>B k) \<cdot> \<a>\<^sub>B (f \<star>\<^sub>B g) h k"
         proof -
           have "arr (\<a>\<^sub>B (f \<star>\<^sub>B g) h k)"
             using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
           moreover have "arr (\<a>\<^sub>B f g (h \<star>\<^sub>B k))"
             using ide_char arr_char assoc_closed f g h hcomp_closed k by fastforce
           ultimately show ?thesis
             using B.ext comp_char by auto
         qed
         also have "... = \<a>\<^sub>B[f, g, fst (h, k) \<star> snd (h, k)] \<cdot> \<a>\<^sub>B[fst (f, g) \<star> snd (f, g), h, k]"
           unfolding hcomp_def
           using f g h k src_def trg_def arr_char ide_char by simp
         also have "... = \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
           unfolding \<alpha>_def using 1 2 3 4 by simp
         finally show "(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
                         \<alpha> (f, fst (g, h) \<star> snd (g, h), k) \<cdot>
                         (fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
                       \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
           by simp
       qed
     qed
 
     proposition is_monoidal_category:
     shows "monoidal_category (\<cdot>) (\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>) \<alpha> \<omega>"
       ..
 
   end
 
   text \<open>
     In a bicategory, the ``objects'' are essentially arbitrarily chosen representatives
     of their isomorphism classes.  Choosing any other representatives results in an
     equivalent structure.  Each object \<open>a\<close> is additionally equipped with an arbitrarily chosen
     unit isomorphism \<open>\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.  For any \<open>(a, \<iota>)\<close> and \<open>(a', \<iota>')\<close>,
     where \<open>a\<close> and \<open>a'\<close> are isomorphic to the same object, there exists a unique isomorphism
     \<open>\<guillemotleft>\<psi>: a \<Rightarrow> a'\<guillemotright>\<close> that is compatible with the chosen unit isomorphisms \<open>\<iota>\<close> and \<open>\<iota>'\<close>.
     We have already proved this property for monoidal categories, which are bicategories
     with just one ``object''.  Here we use that already-proven property to establish its
     generalization to arbitary bicategories, by exploiting the fact that if \<open>a\<close> is an object
     in a bicategory, then the sub-bicategory consisting of all \<open>\<mu>\<close> such that
     \<open>src \<mu> = a = trg \<mu>\<close>, is a monoidal category.
 
     At some point it would potentially be nicer to transfer the proof for monoidal
     categories to obtain a direct, ``native'' proof of this fact for bicategories.
   \<close>
 
   lemma (in bicategory) unit_unique_upto_unique_iso:
   assumes "obj a"
   and "isomorphic a w"
   and "\<guillemotleft>\<omega> : w \<star> w \<Rightarrow> w\<guillemotright>"
   and "iso \<omega>"
   shows "\<exists>!\<psi>. \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright> \<and> iso \<psi> \<and> \<psi> \<cdot> \<i>[a] = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
   proof -
     have \<omega>_in_hhom: "\<guillemotleft>\<omega> : a \<rightarrow> a\<guillemotright>"
       using assms
       apply (intro in_hhomI)
         apply auto
        apply (metis src_cod in_homE isomorphic_implies_hpar(3) objE)
       by (metis trg_cod in_homE isomorphic_implies_hpar(4) objE)
     interpret S: subbicategory V H \<a> \<i> src trg \<open>\<lambda>\<mu>. arr \<mu> \<and> src \<mu> = a \<and> trg \<mu> = a\<close>
       using assms iso_unit in_homE isoE isomorphicE VVV.arr_char VV.arr_char
       apply unfold_locales
                  apply auto[7]
     proof
       fix f g h
       assume f: "(arr f \<and> src f = a \<and> trg f = a) \<and> ide f"
       and g: "(arr g \<and> src g = a \<and> trg g = a) \<and> ide g"
       and h: "(arr h \<and> src h = a \<and> trg h = a) \<and> ide h"
       and fg: "src f = trg g" and gh: "src g = trg h"
       show "arr (\<a>[f, g, h])"
         using assms f g h fg gh by auto
       show "src (\<a>[f, g, h]) = a \<and> trg (\<a>[f, g, h]) = a"
         using assms f g h fg gh by auto
       show "arr (inv (\<a>[f, g, h])) \<and> src (inv (\<a>[f, g, h])) = a \<and> trg (inv (\<a>[f, g, h])) = a"
         using assms f g h fg gh \<alpha>.preserves_hom src_dom trg_dom by simp
       next
       fix f
       assume f: "arr f \<and> src f = a \<and> trg f = a"
       assume ide_left: "ide f"
       show "arr (\<ll> f) \<and> src (\<ll> f) = a \<and> trg (\<ll> f) = a"
         using f assms(1) \<ll>.preserves_hom src_cod [of "\<ll> f"] trg_cod [of "\<ll> f"] by simp
       show "arr (inv (\<ll> f)) \<and> src (inv (\<ll> f)) = a \<and> trg (inv (\<ll> f)) = a"
         using f ide_left assms(1) \<ll>'.preserves_hom src_dom [of "\<ll>'.map f"] trg_dom [of "\<ll>'.map f"]
         by simp
       show "arr (\<rr> f) \<and> src (\<rr> f) = a \<and> trg (\<rr> f) = a"
         using f assms(1) \<rr>.preserves_hom src_cod [of "\<rr> f"] trg_cod [of "\<rr> f"] by simp
       show "arr (inv (\<rr> f)) \<and> src (inv (\<rr> f)) = a \<and> trg (inv (\<rr> f)) = a"
         using f ide_left assms(1) \<rr>'.preserves_hom src_dom [of "\<rr>'.map f"] trg_dom [of "\<rr>'.map f"]
         by simp
     qed
     interpret S: subbicategory_at_object V H \<a> \<i> src trg a a \<open>\<i>[a]\<close>
     proof
       show "obj a" by fact
       show "isomorphic a a"
         using assms(1) isomorphic_reflexive by blast
       show "S.in_hom \<i>[a] (a \<star> a) a"
         using S.arr_char S.in_hom_char assms(1) by fastforce
       show "iso \<i>[a]"
         using assms iso_unit by simp
     qed
     interpret S\<^sub>\<omega>: subbicategory_at_object V H \<a> \<i> src trg a w \<omega>
     proof
       show "obj a" by fact
       show "iso \<omega>" by fact
       show "isomorphic a w"
         using assms by simp
       show "S.in_hom \<omega> (w \<star> w) w"
         using assms S.arr_char S.dom_char S.cod_char \<omega>_in_hhom
         by (intro S.in_homI, auto)
     qed
     interpret M: monoidal_category S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<open>\<i>[a]\<close>
       using S.is_monoidal_category by simp
     interpret M\<^sub>\<omega>: monoidal_category S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<omega>
       using S\<^sub>\<omega>.is_monoidal_category by simp
     interpret M: monoidal_category_with_alternate_unit
                    S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<open>\<i>[a]\<close> \<omega> ..
     have 1: "M\<^sub>\<omega>.unity = w"
       using assms M\<^sub>\<omega>.unity_def S.cod_char S.arr_char
       by (metis (no_types, lifting) S.in_homE S\<^sub>\<omega>.\<omega>_in_vhom)
     have 2: "M.unity = a"
       using assms M.unity_def S.cod_char S.arr_char by simp
     have "\<exists>!\<psi>. S.in_hom \<psi> a w \<and> S.iso \<psi> \<and> S.comp \<psi> \<i>[a] = S.comp \<omega> (M.tensor \<psi> \<psi>)"
       using assms 1 2 M.unit_unique_upto_unique_iso M.unity_def M\<^sub>\<omega>.unity_def S.cod_char
       by simp
     show "\<exists>!\<psi>. \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright> \<and> iso \<psi> \<and> \<psi> \<cdot> \<i>[a] = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
     proof -
       have 1: "\<And>\<psi>. S.in_hom \<psi> a w \<longleftrightarrow> \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright>"
         using assms S.in_hom_char S.arr_char
         by (metis (no_types, lifting) S.ideD(1) S.w_simps(1) S\<^sub>\<omega>.w_simps(1) in_homE
             src_dom trg_dom)
       moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.iso \<psi> \<longleftrightarrow> iso \<psi>"
         using assms S.in_hom_char S.arr_char S.iso_char by auto
       moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> M.tensor \<psi> \<psi> = \<psi> \<star> \<psi>"
         using assms S.in_hom_char S.arr_char S.hcomp_def by simp
       moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.comp \<psi> \<i>[a] = \<psi> \<cdot> \<i>[a]"
         using assms S.in_hom_char S.comp_char by auto
       moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.comp \<omega> (M.tensor \<psi> \<psi>) = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
         using assms S.in_hom_char S.arr_char S.hcomp_def S.comp_char S.dom_char S.cod_char
         by (metis (no_types, lifting) M\<^sub>\<omega>.arr_tensor S\<^sub>\<omega>.\<omega>_simps(1) calculation(3) ext)
       ultimately show ?thesis
         by (metis (no_types, lifting) M.unit_unique_upto_unique_iso M.unity_def M\<^sub>\<omega>.unity_def
             S.\<omega>_in_vhom S.in_homE S\<^sub>\<omega>.\<omega>_in_vhom)
     qed
   qed
 
 end
diff --git a/thys/Category3/Adjunction.thy b/thys/Category3/Adjunction.thy
--- a/thys/Category3/Adjunction.thy
+++ b/thys/Category3/Adjunction.thy
@@ -1,3190 +1,3187 @@
 (*  Title:       Adjunction
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter Adjunction
 
 theory Adjunction
 imports Yoneda
 begin
 
   text\<open>
     This theory defines the notions of adjoint functor and adjunction in various
     ways and establishes their equivalence.
     The notions ``left adjoint functor'' and ``right adjoint functor'' are defined
     in terms of universal arrows.
     ``Meta-adjunctions'' are defined in terms of natural bijections between hom-sets,
     where the notion of naturality is axiomatized directly.
     ``Hom-adjunctions'' formalize the notion of adjunction in terms of natural
     isomorphisms of hom-functors.
     ``Unit-counit adjunctions'' define adjunctions in terms of functors equipped
     with unit and counit natural transformations that satisfy the usual
     ``triangle identities.''
     The \<open>adjunction\<close> locale is defined as the grand unification of all the
     definitions, and includes formulas that connect the data from each of them.
     It is shown that each of the definitions induces an interpretation of the
     \<open>adjunction\<close> locale, so that all the definitions are essentially equivalent.
     Finally, it is shown that right adjoint functors are unique up to natural
     isomorphism.
 
     The reference \cite{Wikipedia-Adjoint-Functors} was useful in constructing this theory.
 \<close>
 
   section "Left Adjoint Functor"
 
   text\<open>
     ``@{term e} is an arrow from @{term "F x"} to @{term y}.''
 \<close>
 
   locale arrow_from_functor =
     C: category C +
     D: category D +
     F: "functor" D C F
     for D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and F :: "'d \<Rightarrow> 'c"
     and x :: 'd
     and y :: 'c
     and e :: 'c +
     assumes arrow: "D.ide x \<and> C.in_hom e (F x) y"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     text\<open>
       ``@{term g} is a @{term[source=true] D}-coextension of @{term f} along @{term e}.''
 \<close>
 
     definition is_coext :: "'d \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
     where "is_coext x' f g \<equiv> \<guillemotleft>g : x' \<rightarrow>\<^sub>D x\<guillemotright> \<and> f = e \<cdot>\<^sub>C F g"
 
   end
 
   text\<open>
     ``@{term e} is a terminal arrow from @{term "F x"} to @{term y}.''
 \<close>
 
   locale terminal_arrow_from_functor =
     arrow_from_functor D C F x y e
     for D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and F :: "'d \<Rightarrow> 'c"
     and x :: 'd
     and y :: 'c
     and e :: 'c +
     assumes is_terminal: "arrow_from_functor D C F x' y f \<Longrightarrow> (\<exists>!g. is_coext x' f g)"
   begin
 
     definition the_coext :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     where "the_coext x' f = (THE g. is_coext x' f g)"
 
     lemma the_coext_prop:
     assumes "arrow_from_functor D C F x' y f"
     shows "\<guillemotleft>the_coext x' f : x' \<rightarrow>\<^sub>D x\<guillemotright>" and "f = e \<cdot>\<^sub>C F (the_coext x' f)"
       by (metis assms is_coext_def is_terminal the_coext_def the_equality)+
 
     lemma the_coext_unique:
     assumes "arrow_from_functor D C F x' y f" and "is_coext x' f g"
     shows "g = the_coext x' f"
       using assms is_terminal the_coext_def the_equality by metis
 
   end
 
   text\<open>
     A left adjoint functor is a functor \<open>F: D \<rightarrow> C\<close>
     that enjoys the following universal coextension property: for each object
     @{term y} of @{term C} there exists an object @{term x} of @{term D} and an
     arrow \<open>e \<in> C.hom (F x) y\<close> such that for any arrow
     \<open>f \<in> C.hom (F x') y\<close> there exists a unique \<open>g \<in> D.hom x' x\<close>
     such that @{term "f = C e (F g)"}.
 \<close>
 
   locale left_adjoint_functor =
     C: category C +
     D: category D +
     "functor" D C F
     for D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and F :: "'d \<Rightarrow> 'c" +
     assumes ex_terminal_arrow: "C.ide y \<Longrightarrow> (\<exists>x e. terminal_arrow_from_functor D C F x y e)"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   section "Right Adjoint Functor"
 
   text\<open>
     ``@{term e} is an arrow from @{term x} to @{term "G y"}.''
 \<close>
 
   locale arrow_to_functor =
     C: category C +
     D: category D +
     G: "functor" C D G
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and G :: "'c \<Rightarrow> 'd"
     and x :: 'd
     and y :: 'c
     and e :: 'd +
     assumes arrow: "C.ide y \<and> D.in_hom e x (G y)"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     text\<open>
       ``@{term f} is a @{term[source=true] C}-extension of @{term g} along @{term e}.''
 \<close>
 
     definition is_ext :: "'c \<Rightarrow> 'd \<Rightarrow> 'c \<Rightarrow> bool"
     where "is_ext y' g f \<equiv> \<guillemotleft>f : y \<rightarrow>\<^sub>C y'\<guillemotright> \<and> g = G f \<cdot>\<^sub>D e"
 
   end
 
   text\<open>
     ``@{term e} is an initial arrow from @{term x} to @{term "G y"}.''
 \<close>
 
   locale initial_arrow_to_functor =
     arrow_to_functor C D G x y e
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and G :: "'c \<Rightarrow> 'd"
     and x :: 'd
     and y :: 'c
     and e :: 'd +
     assumes is_initial: "arrow_to_functor C D G x y' g \<Longrightarrow> (\<exists>!f. is_ext y' g f)"
   begin
 
     definition the_ext :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     where "the_ext y' g = (THE f. is_ext y' g f)"
 
     lemma the_ext_prop:
     assumes "arrow_to_functor C D G x y' g"
     shows "\<guillemotleft>the_ext y' g : y \<rightarrow>\<^sub>C y'\<guillemotright>" and "g = G (the_ext y' g) \<cdot>\<^sub>D e"
       by (metis assms is_initial is_ext_def the_equality the_ext_def)+
 
     lemma the_ext_unique:
     assumes "arrow_to_functor C D G x y' g" and "is_ext y' g f"
     shows "f = the_ext y' g"
       using assms is_initial the_ext_def the_equality by metis
 
   end
 
   text\<open>
     A right adjoint functor is a functor \<open>G: C \<rightarrow> D\<close>
     that enjoys the following universal extension property:
     for each object @{term x} of @{term D} there exists an object @{term y} of @{term C}
     and an arrow \<open>e \<in> D.hom x (G y)\<close> such that for any arrow
     \<open>g \<in> D.hom x (G y')\<close> there exists a unique \<open>f \<in> C.hom y y'\<close>
     such that @{term "h = D e (G f)"}.
 \<close>
 
   locale right_adjoint_functor =
     C: category C +
     D: category D +
     "functor" C D G
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and G :: "'c \<Rightarrow> 'd" +
     assumes initial_arrows_exist: "D.ide x \<Longrightarrow> (\<exists>y e. initial_arrow_to_functor C D G x y e)"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   section "Various Definitions of Adjunction"
 
   subsection "Meta-Adjunction"
 
   text\<open>
     A ``meta-adjunction'' consists of a functor \<open>F: D \<rightarrow> C\<close>,
     a functor \<open>G: C \<rightarrow> D\<close>, and for each object @{term x}
     of @{term C} and @{term y} of @{term D} a bijection between
     \<open>C.hom (F y) x\<close> to \<open>D.hom y (G x)\<close> which is natural in @{term x}
     and @{term y}.  The naturality is easy to express at the meta-level without having
     to resort to the formal baggage of ``set category,'' ``hom-functor,''
     and ``natural isomorphism,'' hence the name.
 \<close>
 
   locale meta_adjunction =
     C: category C +
     D: category D +
     F: "functor" D C F +
     G: "functor" C D G
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     and \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c" +
     assumes \<phi>_in_hom: "\<lbrakk> D.ide y; C.in_hom f (F y) x \<rbrakk> \<Longrightarrow> D.in_hom (\<phi> y f) y (G x)"
     and \<psi>_in_hom: "\<lbrakk> C.ide x; D.in_hom g y (G x) \<rbrakk> \<Longrightarrow> C.in_hom (\<psi> x g) (F y) x"
     and \<psi>_\<phi>: "\<lbrakk> D.ide y; C.in_hom f (F y) x \<rbrakk> \<Longrightarrow> \<psi> x (\<phi> y f) = f"
     and \<phi>_\<psi>: "\<lbrakk> C.ide x; D.in_hom g y (G x) \<rbrakk> \<Longrightarrow> \<phi> y (\<psi> x g) = g"
     and \<phi>_naturality: "\<lbrakk> C.in_hom f x x'; D.in_hom g y' y; C.in_hom h (F y) x \<rbrakk> \<Longrightarrow>
                          \<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
   begin
 
     notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     text\<open>
       The naturality of @{term \<psi>} is a consequence of the naturality of @{term \<phi>}
       and the other assumptions.
 \<close>
 
     lemma \<psi>_naturality:
     assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = \<psi> x' (G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g)"
       using f g h \<phi>_naturality \<psi>_in_hom C.ide_dom D.ide_dom D.in_homE \<phi>_\<psi> \<psi>_\<phi>
       by (metis C.comp_in_homI' F.preserves_hom C.in_homE D.in_homE)
 
     lemma respects_natural_isomorphism:
     assumes "natural_isomorphism D C F' F \<tau>" and "natural_isomorphism C D G G' \<mu>"
     shows "meta_adjunction C D F' G'
              (\<lambda>y f. \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C inverse_transformation.map D C F \<tau> y))
              (\<lambda>x g. \<psi> x ((inverse_transformation.map C D G' \<mu> x) \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))"
     proof -
       interpret \<tau>: natural_isomorphism D C F' F \<tau>
         using assms(1) by simp
       interpret \<tau>': inverse_transformation D C F' F \<tau>
         ..
       interpret \<mu>: natural_isomorphism C D G G' \<mu>
         using assms(2) by simp
       interpret \<mu>': inverse_transformation C D G G' \<mu>
         ..
       let ?\<phi>' = "\<lambda>y f. \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)"
       let ?\<psi>' = "\<lambda>x g. \<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)"
       show "meta_adjunction C D F' G' ?\<phi>' ?\<psi>'"
       proof
         show "\<And>y f x. \<lbrakk>D.ide y; \<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>\<rbrakk>
                          \<Longrightarrow> \<guillemotleft>\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
         proof -
           fix x y f
           assume y: "D.ide y" and f: "\<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           show "\<guillemotleft>\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
           proof (intro D.comp_in_homI)
             show "\<guillemotleft>\<mu> (C.cod f) : G x \<rightarrow>\<^sub>D G' x\<guillemotright>"
               using f by fastforce
             show "\<guillemotleft>\<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
               using f y \<phi>_in_hom by auto
           qed
         qed
         show "\<And>x g y. \<lbrakk>C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>\<rbrakk>
                          \<Longrightarrow> \<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g) : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
         proof -
           fix x y g
           assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
           show "\<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g) : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           proof (intro C.comp_in_homI)
             show "\<guillemotleft>\<tau> (D.dom g) : F' y \<rightarrow>\<^sub>C F y\<guillemotright>"
               using g by fastforce
             show "\<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
               using x g \<psi>_in_hom by auto
           qed
         qed
         show "\<And>y f x. \<lbrakk>D.ide y; \<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>\<rbrakk>
                           \<Longrightarrow> \<psi> x (\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                                 \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y))) =
                               f"
         proof -
           fix x y f
           assume y: "D.ide y" and f: "\<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           have 1: "\<guillemotleft>\<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
             using f y \<phi>_in_hom by auto
           show "\<psi> x (\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                   \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y))) =
                 f"
           proof -
             have "\<psi> x (\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                     \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y))) =
                   \<psi> x ((\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f)) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                     \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)))"
               using D.comp_assoc by simp
             also have "... = \<psi> x (\<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C \<tau> y"
-              using f 1
-              by (metis C.ide_cod C.in_homE C.seqE D.comp_inv_arr D.in_homE D.seqI
-                  G.functor_axioms \<mu>'.inverts_components \<mu>.preserves_dom
-                  \<mu>.preserves_reflects_arr category.comp_cod_arr category.dom_comp
-                  functor_def)
+              by (metis "1" C.arr_cod C.dom_cod C.ide_cod C.in_homE D.comp_ide_arr D.dom_comp
+                  D.ide_compE D.in_homE D.inverse_arrowsE \<mu>'.inverts_components \<mu>.preserves_dom
+                  \<mu>.preserves_reflects_arr category.seqI f meta_adjunction_axioms
+                  meta_adjunction_def)
             also have "... = f"
               using f y \<psi>_\<phi> C.comp_assoc \<tau>'.inverts_components [of y] C.comp_arr_dom
               by fastforce
             finally show ?thesis by blast
           qed
         qed
         show "\<And>x g y. \<lbrakk>C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>\<rbrakk>
                          \<Longrightarrow> \<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                                \<phi> y ((\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)) \<cdot>\<^sub>C \<tau>'.map y) =
                              g"
         proof -
           fix x y g
           assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
           have 1: "\<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
             using x g \<psi>_in_hom by auto
           show "\<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                   \<phi> y ((\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)) \<cdot>\<^sub>C \<tau>'.map y) =
                 g"
           proof -
             have "\<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                     \<phi> y ((\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)) \<cdot>\<^sub>C \<tau>'.map y) =
                   \<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                     \<phi> y (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g) \<cdot>\<^sub>C \<tau>'.map y)"
               using C.comp_assoc by simp
             also have "... = \<mu> x \<cdot>\<^sub>D \<phi> y (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g))"
               using 1 C.comp_arr_dom C.comp_arr_inv' g by fastforce
             also have "... = (\<mu> x \<cdot>\<^sub>D \<mu>'.map x) \<cdot>\<^sub>D g"
               using x g \<phi>_\<psi> D.comp_assoc by auto
             also have "... = g"
               using x g \<mu>'.inverts_components [of x] D.comp_cod_arr by fastforce
             finally show ?thesis by blast
           qed
         qed
         show "\<And>f x x' g y' y h. \<lbrakk>\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>; \<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>; \<guillemotleft>h : F' y \<rightarrow>\<^sub>C x\<guillemotright>\<rbrakk>
                   \<Longrightarrow> \<mu> (C.cod (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g)) \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y') =
                       G' f \<cdot>\<^sub>D (\<mu> (C.cod h) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>D g"
         proof -
           fix x y x' y' f g h
           assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           show "\<mu> (C.cod (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g)) \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y') =
                 G' f \<cdot>\<^sub>D (\<mu> (C.cod h) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>D g"
           proof -
             have "\<mu> (C.cod (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g)) \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y') =
                   \<mu> x' \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y')"
               using f g h by fastforce
             also have "... = \<mu> x' \<cdot>\<^sub>D \<phi> y' (f \<cdot>\<^sub>C (h \<cdot>\<^sub>C \<tau>'.map y) \<cdot>\<^sub>C F g)"
               using g \<tau>'.naturality C.comp_assoc by auto
             also have "... = (\<mu> x' \<cdot>\<^sub>D G f) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y) \<cdot>\<^sub>D g"
               using f g h \<phi>_naturality [of f x x' g y' y "h \<cdot>\<^sub>C \<tau>'.map y"] D.comp_assoc
               by fastforce
             also have "... = (G' f \<cdot>\<^sub>D \<mu> x) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y) \<cdot>\<^sub>D g"
               using f \<mu>.naturality by auto
             also have "... = G' f \<cdot>\<^sub>D (\<mu> (C.cod h) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>D g"
               using h D.comp_assoc by auto
             finally show ?thesis by blast
           qed
         qed
       qed
     qed
 
   end
 
   subsection "Hom-Adjunction"
 
   text\<open>
     The bijection between hom-sets that defines an adjunction can be represented
     formally as a natural isomorphism of hom-functors.  However, stating the definition
     this way is more complex than was the case for \<open>meta_adjunction\<close>.
     One reason is that we need to have a ``set category'' that is suitable as
     a target category for the hom-functors, and since the arrows of the categories
     @{term C} and @{term D} will in general have distinct types, we need a set category
     that simultaneously embeds both.  Another reason is that we simply have to formally
     construct the various categories and functors required to express the definition.
 
     This is a good place to point out that I have often included more sublocales
     in a locale than are strictly required.  The main reason for this is the fact that
     the locale system in Isabelle only gives one name to each entity introduced by
     a locale: the name that it has in the first locale in which it occurs.
     This means that entities that make their first appearance deeply nested in sublocales
     will have to be referred to by long qualified names that can be difficult to
     understand, or even to discover.  To counteract this, I have typically introduced
     sublocales before the superlocales that contain them to ensure that the entities
     in the sublocales can be referred to by short meaningful (and predictable) names.
     In my opinion, though, it would be better if the locale system would make entities
     that occur in multiple locales accessible by \emph{all} possible qualified names,
     so that the most perspicuous name could be used in any particular context.
 \<close>
 
   locale hom_adjunction =
     C: category C +
     D: category D +
     S: replete_set_category S +
     Cop: dual_category C +
     Dop: dual_category D +
     CopxC: product_category Cop.comp C +
     DopxD: product_category Dop.comp D +
     DopxC: product_category Dop.comp C +
     F: "functor" D C F +
     G: "functor" C D G +
     HomC: hom_functor C S \<phi>C +
     HomD: hom_functor D S \<phi>D +
     Fop: dual_functor Dop.comp Cop.comp F +
     FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
     DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
     Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
     Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
     Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
     Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
     \<Phi>: set_valued_transformation DopxC.comp S Hom_FopxC.map Hom_DopxG.map \<Phi> +
     \<Psi>: set_valued_transformation DopxC.comp S Hom_DopxG.map Hom_FopxC.map \<Psi> +
     \<Phi>\<Psi>: inverse_transformations DopxC.comp S Hom_FopxC.map Hom_DopxG.map \<Phi> \<Psi>
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and S :: "'s comp"     (infixr "\<cdot>\<^sub>S" 55)
     and \<phi>C :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
     and \<phi>D :: "'d * 'd \<Rightarrow> 'd \<Rightarrow> 's"
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<Phi> :: "'d * 'c \<Rightarrow> 's"
     and \<Psi> :: "'d * 'c \<Rightarrow> 's"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     abbreviation \<psi>C :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
     where "\<psi>C \<equiv> HomC.\<psi>"
 
     abbreviation \<psi>D :: "'d * 'd \<Rightarrow> 's \<Rightarrow> 'd"
     where "\<psi>D \<equiv> HomD.\<psi>"
 
   end
 
   subsection "Unit/Counit Adjunction"
 
   text\<open>
     Expressed in unit/counit terms, an adjunction consists of functors
     \<open>F: D \<rightarrow> C\<close> and \<open>G: C \<rightarrow> D\<close>, equipped with natural transformations
     \<open>\<eta>: 1 \<rightarrow> GF\<close> and \<open>\<epsilon>: FG \<rightarrow> 1\<close> satisfying certain ``triangle identities''.
 \<close>
 
   locale unit_counit_adjunction =
     C: category C +
     D: category D +
     F: "functor" D C F +
     G: "functor" C D G +
     GF: composite_functor D C D F G +
     FG: composite_functor C D C G F +
     FGF: composite_functor D C C F \<open>F o G\<close> +
     GFG: composite_functor C D D G \<open>G o F\<close> +
     \<eta>: natural_transformation D D D.map \<open>G o F\<close> \<eta> +
     \<epsilon>: natural_transformation C C \<open>F o G\<close> C.map \<epsilon> +
     F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>\<close> +
     \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta> o G\<close> +
     \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close> +
     G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>\<close> +
     \<epsilon>FoF\<eta>: vertical_composite D C F \<open>F o G o F\<close> F \<open>F o \<eta>\<close> \<open>\<epsilon> o F\<close> +
     G\<epsilon>o\<eta>G: vertical_composite C D G \<open>G o F o G\<close> G \<open>\<eta> o G\<close> \<open>G o \<epsilon>\<close>
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<eta> :: "'d \<Rightarrow> 'd"
     and \<epsilon> :: "'c \<Rightarrow> 'c" +
     assumes triangle_F: "\<epsilon>FoF\<eta>.map = F"
     and triangle_G: "G\<epsilon>o\<eta>G.map = G"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   lemma unit_determines_counit:
   assumes "unit_counit_adjunction C D F G \<eta> \<epsilon>"
   and "unit_counit_adjunction C D F G \<eta> \<epsilon>'"
   shows "\<epsilon> = \<epsilon>'"
   proof -
     (* IDEA:  \<epsilon>' = \<epsilon>'FG o (FG\<epsilon> o F\<eta>G) = \<epsilon>'\<epsilon> o F\<eta>G = \<epsilon>FG o (\<epsilon>'FG o F\<eta>G) = \<epsilon> *)
     interpret Adj: unit_counit_adjunction C D F G \<eta> \<epsilon> using assms(1) by auto
     interpret Adj': unit_counit_adjunction C D F G \<eta> \<epsilon>' using assms(2) by auto
     interpret FGFG: composite_functor C D C G \<open>F o G o F\<close> ..
     interpret FG\<epsilon>: natural_transformation C C \<open>(F o G) o (F o G)\<close> \<open>F o G\<close> \<open>(F o G) o \<epsilon>\<close>
       using Adj.\<epsilon>.natural_transformation_axioms Adj.FG.as_nat_trans.natural_transformation_axioms
             horizontal_composite
       by fastforce
     interpret F\<eta>G: natural_transformation C C \<open>F o G\<close> \<open>F o G o F o G\<close> \<open>F o \<eta> o G\<close>
       using Adj.\<eta>.natural_transformation_axioms Adj.F\<eta>.natural_transformation_axioms
             Adj.G.as_nat_trans.natural_transformation_axioms horizontal_composite
       by blast
     interpret \<epsilon>'\<epsilon>: natural_transformation C C \<open>F o G o F o G\<close> Adj.C.map \<open>\<epsilon>' o \<epsilon>\<close>
     proof -
       have "natural_transformation C C ((F o G) o (F o G)) Adj.C.map (\<epsilon>' o \<epsilon>)"
         using Adj.\<epsilon>.natural_transformation_axioms Adj'.\<epsilon>.natural_transformation_axioms
               horizontal_composite Adj.C.is_functor comp_functor_identity
         by (metis (no_types, lifting))
       thus "natural_transformation C C (F o G o F o G) Adj.C.map (\<epsilon>' o \<epsilon>)"
         using o_assoc by metis
     qed
     interpret \<epsilon>'\<epsilon>oF\<eta>G: vertical_composite
                          C C \<open>F o G\<close> \<open>F o G o F o G\<close> Adj.C.map \<open>F o \<eta> o G\<close> \<open>\<epsilon>' o \<epsilon>\<close> ..
     have "\<epsilon>' = vertical_composite.map C C (F o Adj.G\<epsilon>o\<eta>G.map) \<epsilon>'"
       using vcomp_ide_dom [of C C "F o G" Adj.C.map \<epsilon>'] Adj.triangle_G
       by (simp add: Adj'.\<epsilon>.natural_transformation_axioms)
     also have "... = vertical_composite.map C C
                        (vertical_composite.map C C (F o \<eta> o G) (F o G o \<epsilon>)) \<epsilon>'"
       using whisker_left Adj.F.functor_axioms Adj.G\<epsilon>.natural_transformation_axioms
             Adj.\<eta>G.natural_transformation_axioms o_assoc
       by (metis (no_types, lifting))
     also have "... = vertical_composite.map C C
                        (vertical_composite.map C C (F o \<eta> o G) (\<epsilon>' o F o G)) \<epsilon>"
     proof -
       have "vertical_composite.map C C
               (vertical_composite.map C C (F o \<eta> o G) (F o G o \<epsilon>)) \<epsilon>'
               = vertical_composite.map C C (F o \<eta> o G)
                   (vertical_composite.map C C (F o G o \<epsilon>) \<epsilon>')"
         using vcomp_assoc
         by (metis (no_types, lifting) Adj'.\<epsilon>.natural_transformation_axioms
             FG\<epsilon>.natural_transformation_axioms F\<eta>G.natural_transformation_axioms o_assoc)
       also have "... = vertical_composite.map C C (F o \<eta> o G)
                          (vertical_composite.map C C (\<epsilon>' o F o G) \<epsilon>)"
         using Adj'.\<epsilon>.natural_transformation_axioms Adj.\<epsilon>.natural_transformation_axioms
               interchange_spc [of C C "F o G" Adj.C.map \<epsilon> C "F o G" Adj.C.map \<epsilon>']
         by (metis hcomp_ide_cod hcomp_ide_dom o_assoc)
       also have "... = vertical_composite.map C C
                          (vertical_composite.map C C (F o \<eta> o G) (\<epsilon>' o F o G)) \<epsilon>"
         using vcomp_assoc
         by (metis Adj'.\<epsilon>F.natural_transformation_axioms
             Adj.G.as_nat_trans.natural_transformation_axioms
             Adj.\<epsilon>.natural_transformation_axioms F\<eta>G.natural_transformation_axioms
             horizontal_composite)
       finally show ?thesis by simp
     qed
     also have "... = vertical_composite.map C C
                        (vertical_composite.map D C (F o \<eta>) (\<epsilon>' o F) o G) \<epsilon>"
       using whisker_right Adj'.\<epsilon>F.natural_transformation_axioms
             Adj.F\<eta>.natural_transformation_axioms Adj.G.functor_axioms
       by metis
     also have "... = \<epsilon>"
       using Adj'.triangle_F vcomp_ide_cod Adj.\<epsilon>.natural_transformation_axioms by simp
     finally show ?thesis by simp
   qed
 
   lemma counit_determines_unit:
   assumes "unit_counit_adjunction C D F G \<eta> \<epsilon>"
   and "unit_counit_adjunction C D F G \<eta>' \<epsilon>"
   shows "\<eta> = \<eta>'"
   proof -
     interpret Adj: unit_counit_adjunction C D F G \<eta> \<epsilon> using assms(1) by auto
     interpret Adj': unit_counit_adjunction C D F G \<eta>' \<epsilon> using assms(2) by auto
     interpret GFGF: composite_functor D C D F \<open>G o F o G\<close> ..
     interpret GF\<eta>: natural_transformation D D \<open>G o F\<close> \<open>(G o F) o (G o F)\<close> \<open>(G o F) o \<eta>\<close>
       using Adj.\<eta>.natural_transformation_axioms Adj.GF.functor_axioms
             Adj.GF.as_nat_trans.natural_transformation_axioms comp_functor_identity
             horizontal_composite
       by (metis (no_types, lifting))
     interpret \<eta>'GF: natural_transformation D D \<open>G o F\<close> \<open>(G o F) o (G o F)\<close> \<open>\<eta>' o (G o F)\<close>
       using Adj'.\<eta>.natural_transformation_axioms Adj.GF.functor_axioms
             Adj.GF.as_nat_trans.natural_transformation_axioms comp_identity_functor
             horizontal_composite
       by (metis (no_types, lifting))
     interpret G\<epsilon>F: natural_transformation D D \<open>G o F o G o F\<close> \<open>G o F\<close> \<open>G o \<epsilon> o F\<close>
       using Adj.\<epsilon>.natural_transformation_axioms Adj.F.as_nat_trans.natural_transformation_axioms
             Adj.G\<epsilon>.natural_transformation_axioms horizontal_composite
       by blast
     interpret \<eta>'\<eta>: natural_transformation D D Adj.D.map \<open>G o F o G o F\<close> \<open>\<eta>' o \<eta>\<close>
     proof -
       have "natural_transformation D D Adj.D.map ((G o F) o (G o F)) (\<eta>' o \<eta>)"
-        using Adj.\<eta>.natural_transformation_axioms Adj'.\<eta>.natural_transformation_axioms
-              horizontal_composite Adj.D.as_nat_trans.natural_transformation_axioms hcomp_ide_cod
-        by (metis (no_types, lifting))
+        using Adj'.\<eta>.natural_transformation_axioms Adj.D.identity_functor_axioms
+              Adj.\<eta>.natural_transformation_axioms horizontal_composite identity_functor.is_functor
+        by fastforce
       thus "natural_transformation D D Adj.D.map (G o F o G o F) (\<eta>' o \<eta>)"
         using o_assoc by metis
     qed
     interpret G\<epsilon>Fo\<eta>'\<eta>: vertical_composite
                          D D Adj.D.map \<open>G o F o G o F\<close> \<open>G o F\<close> \<open>\<eta>' o \<eta>\<close> \<open>G o \<epsilon> o F\<close> ..
     have "\<eta>' = vertical_composite.map D D \<eta>' (G o Adj.\<epsilon>FoF\<eta>.map)"
       using vcomp_ide_cod [of D D  Adj.D.map "G o F" \<eta>'] Adj.triangle_F
       by (simp add: Adj'.\<eta>.natural_transformation_axioms)
     also have "... = vertical_composite.map D D \<eta>'
                        (vertical_composite.map D D (G o (F o \<eta>)) (G o (\<epsilon> o F)))"
       using whisker_left Adj.F\<eta>.natural_transformation_axioms Adj.G.functor_axioms
             Adj.\<epsilon>F.natural_transformation_axioms
       by fastforce
     also have "... = vertical_composite.map D D
                        (vertical_composite.map D D \<eta>' (G o (F o \<eta>))) (G o \<epsilon> o F)"
       using vcomp_assoc Adj'.\<eta>.natural_transformation_axioms
             GF\<eta>.natural_transformation_axioms G\<epsilon>F.natural_transformation_axioms o_assoc
       by (metis (no_types, lifting))
     also have "... = vertical_composite.map D D
                        (vertical_composite.map D D \<eta> (\<eta>' o G o F)) (G o \<epsilon> o F)"
         using interchange_spc [of D D Adj.D.map "G o F" \<eta> D Adj.D.map "G o F" \<eta>']
               Adj.\<eta>.natural_transformation_axioms Adj'.\<eta>.natural_transformation_axioms
         by (metis hcomp_ide_cod hcomp_ide_dom o_assoc)
     also have "... = vertical_composite.map D D \<eta>
                        (vertical_composite.map D D (\<eta>' o G o F) (G o \<epsilon> o F))"
       using vcomp_assoc
       by (metis (no_types, lifting) Adj.\<eta>.natural_transformation_axioms
           G\<epsilon>F.natural_transformation_axioms \<eta>'GF.natural_transformation_axioms o_assoc)
     also have "... = vertical_composite.map D D \<eta>
                        (vertical_composite.map C D (\<eta>' o G) (G o \<epsilon>) o F)"
       using whisker_right Adj'.\<eta>G.natural_transformation_axioms Adj.F.functor_axioms
             Adj.G\<epsilon>.natural_transformation_axioms
       by fastforce
     also have "... = \<eta>"
       using Adj'.triangle_G vcomp_ide_dom Adj.GF.functor_axioms
             Adj.\<eta>.natural_transformation_axioms
       by simp
     finally show ?thesis by simp
   qed
 
   subsection "Adjunction"
 
   text\<open>
     The grand unification of everything to do with an adjunction.
 \<close>
 
   locale adjunction =
     C: category C +
     D: category D +
     S: replete_set_category S +
     Cop: dual_category C +
     Dop: dual_category D +
     CopxC: product_category Cop.comp C +
     DopxD: product_category Dop.comp D +
     DopxC: product_category Dop.comp C +
     idDop: identity_functor Dop.comp +
     HomC: hom_functor C S \<phi>C +
     HomD: hom_functor D S \<phi>D +
     F: left_adjoint_functor D C F +
     G: right_adjoint_functor C D G +
     GF: composite_functor D C D F G +
     FG: composite_functor C D C G F +
     FGF: composite_functor D C C F FG.map +
     GFG: composite_functor C D D G GF.map +
     Fop: dual_functor Dop.comp Cop.comp F +
     FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
     DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
     Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
     Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
     Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
     Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
     \<eta>: natural_transformation D D D.map GF.map \<eta> +
     \<epsilon>: natural_transformation C C FG.map C.map \<epsilon> +
     F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>\<close> +
     \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta> o G\<close> +
     \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close> +
     G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>\<close> +
     \<epsilon>FoF\<eta>: vertical_composite D C F FGF.map F \<open>F o \<eta>\<close> \<open>\<epsilon> o F\<close> +
     G\<epsilon>o\<eta>G: vertical_composite C D G GFG.map G \<open>\<eta> o G\<close> \<open>G o \<epsilon>\<close> +
     \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi> +
     \<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon> +
     \<Phi>\<Psi>: hom_adjunction C D S \<phi>C \<phi>D F G \<Phi> \<Psi>
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and S :: "'s comp"     (infixr "\<cdot>\<^sub>S" 55)
     and \<phi>C :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
     and \<phi>D :: "'d * 'd \<Rightarrow> 'd \<Rightarrow> 's"
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     and \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     and \<eta> :: "'d \<Rightarrow> 'd"
     and \<epsilon> :: "'c \<Rightarrow> 'c"
     and \<Phi> :: "'d * 'c \<Rightarrow> 's"
     and \<Psi> :: "'d * 'c \<Rightarrow> 's" +
     assumes \<phi>_in_terms_of_\<eta>: "\<lbrakk> D.ide y; \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<rbrakk> \<Longrightarrow> \<phi> y f = G f \<cdot>\<^sub>D \<eta> y"
     and \<psi>_in_terms_of_\<epsilon>: "\<lbrakk> C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<rbrakk> \<Longrightarrow> \<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g"
     and \<eta>_in_terms_of_\<phi>: "D.ide y \<Longrightarrow> \<eta> y = \<phi> y (F y)"
     and \<epsilon>_in_terms_of_\<psi>: "C.ide x \<Longrightarrow> \<epsilon> x = \<psi> x (G x)"
     and \<phi>_in_terms_of_\<Phi>: "\<lbrakk> D.ide y; \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<rbrakk> \<Longrightarrow>
                               \<phi> y f = (\<Phi>\<Psi>.\<psi>D (y, G x) o S.Fun (\<Phi> (y, x)) o \<phi>C (F y, x)) f"
     and \<psi>_in_terms_of_\<Psi>: "\<lbrakk> C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<rbrakk> \<Longrightarrow>
                               \<psi> x g = (\<Phi>\<Psi>.\<psi>C (F y, x) o S.Fun (\<Psi> (y, x)) o \<phi>D (y, G x)) g"
     and \<Phi>_in_terms_of_\<phi>:
            "\<lbrakk> C.ide x; D.ide y \<rbrakk> \<Longrightarrow>
                 \<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                     (\<phi>D (y, G x) o \<phi> y o \<Phi>\<Psi>.\<psi>C (F y, x))"
     and \<Psi>_in_terms_of_\<psi>:
            "\<lbrakk> C.ide x; D.ide y \<rbrakk> \<Longrightarrow>
                 \<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                     (\<phi>C (F y, x) o \<psi> x o \<Phi>\<Psi>.\<psi>D (y, G x))"
 
   section "Meta-Adjunctions Induce Unit/Counit Adjunctions"
 
   context meta_adjunction
   begin
 
     interpretation GF: composite_functor D C D F G ..
     interpretation FG: composite_functor C D C G F ..
     interpretation FGF: composite_functor D C C F FG.map ..
     interpretation GFG: composite_functor C D D G GF.map ..
 
     definition \<eta>o :: "'d \<Rightarrow> 'd"
     where "\<eta>o y = \<phi> y (F y)"
 
     lemma \<eta>o_in_hom:
     assumes "D.ide y"
     shows "\<guillemotleft>\<eta>o y : y \<rightarrow>\<^sub>D G (F y)\<guillemotright>"
       using assms D.ide_in_hom \<eta>o_def \<phi>_in_hom by force
 
     lemma \<phi>_in_terms_of_\<eta>o:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y f = G f \<cdot>\<^sub>D \<eta>o y"
     proof (unfold \<eta>o_def)
       have 1: "\<guillemotleft>F y : F y \<rightarrow>\<^sub>C F y\<guillemotright>"
         using assms(1) D.ide_in_hom by blast
       hence "\<phi> y (F y) = \<phi> y (F y) \<cdot>\<^sub>D y"
         by (metis assms(1) D.in_homE \<phi>_in_hom D.comp_arr_dom)
       thus "\<phi> y f = G f \<cdot>\<^sub>D \<phi> y (F y)"
         using assms 1 D.ide_in_hom by (metis C.comp_arr_dom C.in_homE \<phi>_naturality)
     qed
 
     lemma \<phi>_F_char:
     assumes "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>"
     shows "\<phi> y' (F g) = \<eta>o y \<cdot>\<^sub>D g"
       using assms \<eta>o_def \<phi>_in_hom [of y "F y" "F y"]
             D.comp_cod_arr [of "D (\<phi> y (F y)) g" "G (F y)"]
             \<phi>_naturality [of "F y" "F y" "F y" g y' y "F y"]
-      by (metis D.arr_cod D.cod_cod D.comp_in_homI' D.ide_char' D.ide_in_hom D.in_homE
-          F.as_nat_trans.is_natural_2 F.preserves_hom)
+      by (metis C.ide_in_hom D.arr_cod_iff_arr D.arr_dom D.cod_cod D.cod_dom D.comp_ide_arr
+          D.comp_ide_self D.ide_cod D.in_homE F.as_nat_trans.is_natural_2 F.functor_axioms
+          F.preserves_section_retraction \<phi>_in_hom functor.preserves_hom)
 
     interpretation \<eta>: transformation_by_components D D D.map GF.map \<eta>o
     proof
       show "\<And>a. D.ide a \<Longrightarrow> \<guillemotleft>\<eta>o a : D.map a \<rightarrow>\<^sub>D GF.map a\<guillemotright>"
         using \<eta>o_def \<phi>_in_hom D.ide_in_hom by force
       fix f
       assume f: "D.arr f"
       show "\<eta>o (D.cod f) \<cdot>\<^sub>D D.map f = GF.map f \<cdot>\<^sub>D \<eta>o (D.dom f)"
         using f \<phi>_F_char [of "D.map f" "D.dom f" "D.cod f"]
               \<phi>_in_terms_of_\<eta>o [of "D.dom f" "F f" "F (D.cod f)"]
         by force
     qed
 
     lemma \<eta>_map_simp:
     assumes "D.ide y"
     shows "\<eta>.map y = \<phi> y (F y)"
       using assms \<eta>.map_simp_ide \<eta>o_def by simp
 
     definition \<epsilon>o :: "'c \<Rightarrow> 'c"
     where "\<epsilon>o x = \<psi> x (G x)"
 
     lemma \<epsilon>o_in_hom:
     assumes "C.ide x"
     shows "\<guillemotleft>\<epsilon>o x : F (G x) \<rightarrow>\<^sub>C x\<guillemotright>"
       using assms C.ide_in_hom \<epsilon>o_def \<psi>_in_hom by force
 
     lemma \<psi>_in_terms_of_\<epsilon>o:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<psi> x g = \<epsilon>o x \<cdot>\<^sub>C F g"
     proof -
       have "\<epsilon>o x \<cdot>\<^sub>C F g = x \<cdot>\<^sub>C \<psi> x (G x) \<cdot>\<^sub>C F g"
         using assms \<epsilon>o_def \<psi>_in_hom [of x "G x" "G x"]
               C.comp_cod_arr [of "\<psi> x (G x) \<cdot>\<^sub>C F g" x]
         by fastforce
       also have "... = \<psi> x (G x \<cdot>\<^sub>D G x \<cdot>\<^sub>D g)"
         using assms \<psi>_naturality [of x x x g y "G x" "G x"] by force
       also have "... = \<psi> x g"
         using assms D.comp_cod_arr by fastforce
       finally show ?thesis by simp
     qed
 
     lemma \<psi>_G_char:
     assumes "\<guillemotleft>f: x \<rightarrow>\<^sub>C x'\<guillemotright>"
     shows "\<psi> x' (G f) = f \<cdot>\<^sub>C \<epsilon>o x"
     proof (unfold \<epsilon>o_def)
       have 0: "C.ide x \<and> C.ide x'" using assms by auto
       thus "\<psi> x' (G f) = f \<cdot>\<^sub>C \<psi> x (G x)"
         using 0 assms \<psi>_naturality \<psi>_in_hom [of x "G x" "G x"] G.preserves_hom \<epsilon>o_def
               \<psi>_in_terms_of_\<epsilon>o G.as_nat_trans.is_natural_1 C.ide_in_hom
         by (metis C.arrI C.in_homE)
     qed
 
     interpretation \<epsilon>: transformation_by_components C C FG.map C.map \<epsilon>o
       apply unfold_locales
       using \<epsilon>o_in_hom
        apply simp
       using \<psi>_G_char \<psi>_in_terms_of_\<epsilon>o
       by (metis C.arr_iff_in_hom C.ide_cod C.map_simp G.preserves_hom comp_apply)
 
     lemma \<epsilon>_map_simp:
     assumes "C.ide x"
     shows "\<epsilon>.map x = \<psi> x (G x)"
       using assms \<epsilon>o_def by simp
 
     interpretation FD: composite_functor D D C D.map F ..
     interpretation CF: composite_functor D C C F C.map ..
     interpretation GC: composite_functor C C D C.map G ..
     interpretation DG: composite_functor C D D G D.map ..
 
     interpretation F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>.map\<close>
       by (metis (no_types, lifting) F.as_nat_trans.natural_transformation_axioms
           F.functor_axioms \<eta>.natural_transformation_axioms comp_functor_identity
           horizontal_composite o_assoc)
 
     interpretation \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon>.map o F\<close>
       using \<epsilon>.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
             horizontal_composite
       by fastforce
 
     interpretation \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta>.map o G\<close>
       using \<eta>.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
             horizontal_composite
       by fastforce
 
     interpretation G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>.map\<close>
       by (metis (no_types, lifting) G.as_nat_trans.natural_transformation_axioms
           G.functor_axioms \<epsilon>.natural_transformation_axioms comp_functor_identity
           horizontal_composite o_assoc)
 
     interpretation \<epsilon>FoF\<eta>: vertical_composite D C F \<open>F o G o F\<close> F \<open>F o \<eta>.map\<close> \<open>\<epsilon>.map o F\<close>
       ..
     interpretation G\<epsilon>o\<eta>G: vertical_composite C D G \<open>G o F o G\<close> G \<open>\<eta>.map o G\<close> \<open>G o \<epsilon>.map\<close>
       ..
 
     lemma unit_counit_F:
     assumes "D.ide y"
     shows "F y = \<epsilon>o (F y) \<cdot>\<^sub>C F (\<eta>o y)"
       using assms \<psi>_in_terms_of_\<epsilon>o \<eta>o_def \<psi>_\<phi> \<eta>o_in_hom F.preserves_ide C.ide_in_hom by metis
 
     lemma unit_counit_G:
     assumes "C.ide x"
     shows "G x = G (\<epsilon>o x) \<cdot>\<^sub>D \<eta>o (G x)"
       using assms \<phi>_in_terms_of_\<eta>o \<epsilon>o_def \<phi>_\<psi> \<epsilon>o_in_hom G.preserves_ide D.ide_in_hom by metis
 
     lemma induces_unit_counit_adjunction':
     shows "unit_counit_adjunction C D F G \<eta>.map \<epsilon>.map"
     proof
       show "\<epsilon>FoF\<eta>.map = F"
         using \<epsilon>FoF\<eta>.is_natural_transformation \<epsilon>FoF\<eta>.map_simp_ide unit_counit_F
               F.as_nat_trans.natural_transformation_axioms
         by (intro NaturalTransformation.eqI) auto
       show "G\<epsilon>o\<eta>G.map = G"
         using G\<epsilon>o\<eta>G.is_natural_transformation G\<epsilon>o\<eta>G.map_simp_ide unit_counit_G
               G.as_nat_trans.natural_transformation_axioms
         by (intro NaturalTransformation.eqI) auto
     qed
 
     definition \<eta> :: "'d \<Rightarrow> 'd" where "\<eta> \<equiv> \<eta>.map"
     definition \<epsilon> :: "'c \<Rightarrow> 'c" where "\<epsilon> \<equiv> \<epsilon>.map"
 
     theorem induces_unit_counit_adjunction:
     shows "unit_counit_adjunction C D F G \<eta> \<epsilon>"
       unfolding \<eta>_def \<epsilon>_def
       using induces_unit_counit_adjunction' by simp
 
     lemma \<eta>_is_natural_transformation:
     shows "natural_transformation D D D.map GF.map \<eta>"
       unfolding \<eta>_def ..
 
     lemma \<epsilon>_is_natural_transformation:
     shows "natural_transformation C C FG.map C.map \<epsilon>"
       unfolding \<epsilon>_def ..
 
     text\<open>
       From the defined @{term \<eta>} and @{term \<epsilon>} we can recover the original @{term \<phi>} and @{term \<psi>}.
 \<close>
 
     lemma \<phi>_in_terms_of_\<eta>:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y f = G f \<cdot>\<^sub>D \<eta> y"
       using assms \<eta>_def by (simp add: \<phi>_in_terms_of_\<eta>o)
 
     lemma \<psi>_in_terms_of_\<epsilon>:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g"
       using assms \<epsilon>_def by (simp add: \<psi>_in_terms_of_\<epsilon>o)
 
   end
 
   section "Meta-Adjunctions Induce Left and Right Adjoint Functors"
 
   context meta_adjunction
   begin
 
     interpretation unit_counit_adjunction C D F G \<eta> \<epsilon>
       using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
 
     lemma has_terminal_arrows_from_functor:
     assumes x: "C.ide x"
     shows "terminal_arrow_from_functor D C F (G x) x (\<epsilon> x)"
     and "\<And>y' f. arrow_from_functor D C F y' x f
                    \<Longrightarrow> terminal_arrow_from_functor.the_coext D C F (G x) (\<epsilon> x) y' f = \<phi> y' f"
     proof -
       interpret \<epsilon>x: arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon> x\<close>
         using x \<epsilon>.preserves_hom G.preserves_ide by unfold_locales auto
       have 1: "\<And>y' f. arrow_from_functor D C F y' x f \<Longrightarrow>
                       \<epsilon>x.is_coext y' f (\<phi> y' f) \<and> (\<forall>g'. \<epsilon>x.is_coext y' f g' \<longrightarrow> g' = \<phi> y' f)"
         using x
         by (metis (full_types) \<epsilon>x.is_coext_def \<phi>_\<psi> \<psi>_in_terms_of_\<epsilon> arrow_from_functor.arrow
             \<phi>_in_hom \<psi>_\<phi>)
       interpret \<epsilon>x: terminal_arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon> x\<close>
         using 1 by unfold_locales blast
       show "terminal_arrow_from_functor D C F (G x) x (\<epsilon> x)" ..
       show "\<And>y' f. arrow_from_functor D C F y' x f \<Longrightarrow> \<epsilon>x.the_coext y' f = \<phi> y' f"
         using 1 \<epsilon>x.the_coext_def by auto
     qed
 
     lemma has_left_adjoint_functor:
     shows "left_adjoint_functor D C F"
       apply unfold_locales using has_terminal_arrows_from_functor by auto
 
     lemma has_initial_arrows_to_functor:
     assumes y: "D.ide y"
     shows "initial_arrow_to_functor C D G y (F y) (\<eta> y)"
     and "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow>
                   initial_arrow_to_functor.the_ext C D G (F y) (\<eta> y) x' g = \<psi> x' g"
     proof -
       interpret \<eta>y: arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta> y\<close>
         using y by unfold_locales auto
       have 1: "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow>
                          \<eta>y.is_ext x' g (\<psi> x' g) \<and> (\<forall>f'. \<eta>y.is_ext x' g f' \<longrightarrow> f' = \<psi> x' g)"
         using y
         by (metis (full_types) \<eta>y.is_ext_def \<psi>_\<phi> \<phi>_in_terms_of_\<eta> arrow_to_functor.arrow
             \<psi>_in_hom \<phi>_\<psi>)
       interpret \<eta>y: initial_arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta> y\<close>
         apply unfold_locales using 1 by blast
       show "initial_arrow_to_functor C D G y (F y) (\<eta> y)" ..
       show "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow> \<eta>y.the_ext x' g = \<psi> x' g"
         using 1 \<eta>y.the_ext_def by auto
     qed
 
     lemma has_right_adjoint_functor:
     shows "right_adjoint_functor C D G"
       apply unfold_locales using has_initial_arrows_to_functor by auto
 
   end
 
   section "Unit/Counit Adjunctions Induce Meta-Adjunctions"
 
   context unit_counit_adjunction
   begin
 
     definition \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     where "\<phi> y h = G h \<cdot>\<^sub>D \<eta> y"
 
     definition \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     where "\<psi> x h = \<epsilon> x \<cdot>\<^sub>C F h"
 
     interpretation meta_adjunction C D F G \<phi> \<psi>
     proof
       fix x :: 'c and y :: 'd and f :: 'c
       assume y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       show 0: "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
         using f y G.preserves_hom \<eta>.preserves_hom \<phi>_def D.ide_in_hom by auto
       show "\<psi> x (\<phi> y f) = f"
       proof -
         have "\<psi> x (\<phi> y f) = (\<epsilon> x \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (\<eta> y)"
           using y f \<phi>_def \<psi>_def C.comp_assoc by auto
         also have "... = (f \<cdot>\<^sub>C \<epsilon> (F y)) \<cdot>\<^sub>C F (\<eta> y)"
           using y f \<epsilon>.naturality by auto
         also have "... = f"
           using y f \<epsilon>FoF\<eta>.map_simp_2 triangle_F C.comp_arr_dom D.ide_in_hom C.comp_assoc
           by fastforce
         finally show ?thesis by auto
       qed
       next
       fix x :: 'c and y :: 'd and g :: 'd
       assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       show "\<guillemotleft>\<psi> x g : F y \<rightarrow>\<^sub>C x\<guillemotright>" using g x \<psi>_def by fastforce
       show "\<phi> y (\<psi> x g) = g"
       proof -
         have "\<phi> y (\<psi> x g) = (G (\<epsilon> x) \<cdot>\<^sub>D \<eta> (G x)) \<cdot>\<^sub>D g"
           using g x \<phi>_def \<psi>_def \<eta>.naturality [of g] D.comp_assoc by auto
         also have "... = g"
           using x g triangle_G D.comp_ide_arr G\<epsilon>o\<eta>G.map_simp_ide by auto
         finally show ?thesis by auto
       qed
       next
       fix f :: 'c and g :: 'd and h :: 'c and x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
       assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       show "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
         using \<phi>_def f g h \<eta>.naturality D.comp_assoc by fastforce
     qed
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>" ..
 
     text\<open>
       From the defined @{term \<phi>} and @{term \<psi>} we can recover the original @{term \<eta>} and @{term \<epsilon>}.
 \<close>
 
     lemma \<eta>_in_terms_of_\<phi>:
     assumes "D.ide y"
     shows "\<eta> y = \<phi> y (F y)"
       using assms \<phi>_def D.comp_cod_arr by auto
 
     lemma \<epsilon>_in_terms_of_\<psi>:
     assumes "C.ide x"
     shows "\<epsilon> x = \<psi> x (G x)"
       using assms \<psi>_def C.comp_arr_dom by auto
 
   end
 
   section "Left and Right Adjoint Functors Induce Meta-Adjunctions"
 
   text\<open>
     A left adjoint functor induces a meta-adjunction, modulo the choice of a
     right adjoint and counit.
 \<close>
 
   context left_adjoint_functor
   begin
 
     definition Go :: "'c \<Rightarrow> 'd"
     where "Go a = (SOME b. \<exists>e. terminal_arrow_from_functor D C F b a e)"
 
     definition \<epsilon>o :: "'c \<Rightarrow> 'c"
     where "\<epsilon>o a = (SOME e. terminal_arrow_from_functor D C F (Go a) a e)"
 
     lemma Go_\<epsilon>o_terminal:
     assumes "\<exists>b e. terminal_arrow_from_functor D C F b a e"
     shows "terminal_arrow_from_functor D C F (Go a) a (\<epsilon>o a)"
       using assms Go_def \<epsilon>o_def
             someI_ex [of "\<lambda>b. \<exists>e. terminal_arrow_from_functor D C F b a e"]
             someI_ex [of "\<lambda>e. terminal_arrow_from_functor D C F (Go a) a e"]
       by simp
 
     text\<open>
       The right adjoint @{term G} to @{term F} takes each arrow @{term f} of
       @{term[source=true] C} to the unique @{term[source=true] D}-coextension of
       @{term "C f (\<epsilon>o (C.dom f))"} along @{term "\<epsilon>o (C.cod f)"}.
 \<close>
 
     definition G :: "'c \<Rightarrow> 'd"
     where "G f = (if C.arr f then
                      terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (\<epsilon>o (C.cod f))
                                   (Go (C.dom f)) (f \<cdot>\<^sub>C \<epsilon>o (C.dom f))
                   else D.null)"
 
     lemma G_ide:
     assumes "C.ide x"
     shows "G x = Go x"
     proof -
       interpret terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
         using assms ex_terminal_arrow Go_\<epsilon>o_terminal by blast
       have 1: "arrow_from_functor D C F (Go x) x (\<epsilon>o x)" ..
       have "is_coext (Go x) (\<epsilon>o x) (Go x)"
         using arrow is_coext_def C.in_homE C.comp_arr_dom by auto
       hence "Go x = the_coext (Go x) (\<epsilon>o x)" using 1 the_coext_unique by blast
       moreover have "\<epsilon>o x = C x (\<epsilon>o (C.dom x))"
         using assms arrow C.comp_ide_arr C.seqI' C.ide_in_hom C.in_homE by metis
       ultimately show ?thesis using assms G_def C.cod_dom C.ide_in_hom C.in_homE by metis
     qed
 
     lemma G_is_functor:
     shows "functor C D G"
     proof
       fix f :: 'c
       assume "\<not>C.arr f"
       thus "G f = D.null" using G_def by auto
       next
       fix f :: 'c
       assume f: "C.arr f"
       let ?x = "C.dom f"
       let ?x' = "C.cod f"
       interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> \<open>?x\<close> \<open>\<epsilon>o ?x\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> \<open>?x'\<close> \<open>\<epsilon>o ?x'\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (\<epsilon>o ?x))"
         using f x\<epsilon>.arrow by (unfold_locales, auto)
       have "G f = x'\<epsilon>.the_coext (Go ?x) (C f (\<epsilon>o ?x))" using f G_def by simp
       hence Gf: "\<guillemotleft>G f : Go ?x \<rightarrow>\<^sub>D Go ?x'\<guillemotright> \<and> f \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x' \<cdot>\<^sub>C F (G f)"
         using 1 x'\<epsilon>.the_coext_prop by simp
       show "D.arr (G f)" using Gf by auto
       show "D.dom (G f) = G ?x" using f Gf G_ide by auto
       show "D.cod (G f) = G ?x'" using f Gf G_ide by auto
       next
       fix f f' :: 'c
       assume ff': "C.arr (C f' f)"
       have f: "C.arr f" using ff' by auto
       let ?x = "C.dom f"
       let ?x' = "C.cod f"
       let ?x'' = "C.cod f'"
       interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> \<open>?x\<close> \<open>\<epsilon>o ?x\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> \<open>?x'\<close> \<open>\<epsilon>o ?x'\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       interpret x''\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x''\<close> \<open>?x''\<close> \<open>\<epsilon>o ?x''\<close>
         using ff' ex_terminal_arrow Go_\<epsilon>o_terminal by auto
       have 1: "arrow_from_functor D C F (Go ?x) ?x' (f \<cdot>\<^sub>C \<epsilon>o ?x)"
          using f x\<epsilon>.arrow by (unfold_locales, auto)
       have 2: "arrow_from_functor D C F (Go ?x') ?x'' (f' \<cdot>\<^sub>C \<epsilon>o ?x')"
          using ff' x'\<epsilon>.arrow by (unfold_locales, auto)
       have "G f = x'\<epsilon>.the_coext (Go ?x) (C f (\<epsilon>o ?x))"
         using f G_def by simp
       hence Gf: "D.in_hom (G f) (Go ?x) (Go ?x') \<and> f \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x' \<cdot>\<^sub>C F (G f)"
         using 1 x'\<epsilon>.the_coext_prop by simp
       have "G f' = x''\<epsilon>.the_coext (Go ?x') (f' \<cdot>\<^sub>C \<epsilon>o ?x')"
         using ff' G_def by auto
       hence Gf': "\<guillemotleft>G f' : Go (C.cod f) \<rightarrow>\<^sub>D Go (C.cod f')\<guillemotright> \<and> f' \<cdot>\<^sub>C \<epsilon>o ?x' = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f')"
         using 2 x''\<epsilon>.the_coext_prop by simp
       show "G (f' \<cdot>\<^sub>C f) = G f' \<cdot>\<^sub>D G f"
       proof -
         have "x''\<epsilon>.is_coext (Go ?x) ((f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x) (G f' \<cdot>\<^sub>D G f)"
         proof -
           have 3: "\<guillemotleft>G f' \<cdot>\<^sub>D G f : Go (C.dom f) \<rightarrow>\<^sub>D Go (C.cod f')\<guillemotright>" using 1 2 Gf Gf' by auto
           moreover have "(f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f' \<cdot>\<^sub>D G f)"
             by (metis 3 C.comp_assoc D.in_homE Gf Gf' preserves_comp)
           ultimately show ?thesis using x''\<epsilon>.is_coext_def by auto
         qed
         moreover have "arrow_from_functor D C F (Go ?x) ?x'' ((f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x)"
            using ff' x\<epsilon>.arrow by unfold_locales blast
         ultimately show ?thesis
           using ff' G_def x''\<epsilon>.the_coext_unique C.seqE C.cod_comp C.dom_comp by auto
       qed
     qed
 
     interpretation G: "functor" C D G using G_is_functor by auto
 
     lemma G_simp:
     assumes "C.arr f"
     shows "G f = terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (\<epsilon>o (C.cod f))
                                                              (Go (C.dom f)) (f \<cdot>\<^sub>C \<epsilon>o (C.dom f))"
       using assms G_def by simp
 
     interpretation idC: identity_functor C ..
     interpretation GF: composite_functor C D C G F ..
 
     interpretation \<epsilon>: transformation_by_components C C GF.map C.map \<epsilon>o
     proof
       fix x :: 'c
       assume x: "C.ide x"
       show "\<guillemotleft>\<epsilon>o x : GF.map x \<rightarrow>\<^sub>C C.map x\<guillemotright>"
       proof -
         interpret terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
           using x Go_\<epsilon>o_terminal ex_terminal_arrow by simp
         show ?thesis using x G_ide arrow by auto
       qed
       next
       fix f :: 'c
       assume f: "C.arr f"
       show "\<epsilon>o (C.cod f) \<cdot>\<^sub>C GF.map f = C.map f \<cdot>\<^sub>C \<epsilon>o (C.dom f)"
       proof -
         let ?x = "C.dom f"
         let ?x' = "C.cod f"
         interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> ?x \<open>\<epsilon>o ?x\<close>
           using f Go_\<epsilon>o_terminal ex_terminal_arrow by simp
         interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> ?x' \<open>\<epsilon>o ?x'\<close>
           using f Go_\<epsilon>o_terminal ex_terminal_arrow by simp
         have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (\<epsilon>o ?x))"
            using f x\<epsilon>.arrow by unfold_locales auto
         have "G f = x'\<epsilon>.the_coext (Go ?x) (f \<cdot>\<^sub>C \<epsilon>o ?x)"
           using f G_simp by blast
         hence "x'\<epsilon>.is_coext (Go ?x) (f \<cdot>\<^sub>C \<epsilon>o ?x) (G f)"
           using 1 x'\<epsilon>.the_coext_prop x'\<epsilon>.is_coext_def by auto
         thus ?thesis
           using f x'\<epsilon>.is_coext_def by simp
       qed
     qed
 
     definition \<psi>
     where "\<psi> x h = C (\<epsilon>.map x) (F h)"
 
     lemma \<psi>_in_hom:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<guillemotleft>\<psi> x g : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       unfolding \<psi>_def using assms \<epsilon>.maps_ide_in_hom by auto
 
     lemma \<psi>_natural:
     assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = \<psi> x' ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
     proof -
       have "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = f \<cdot>\<^sub>C (\<epsilon>.map x \<cdot>\<^sub>C F h) \<cdot>\<^sub>C F g"
         unfolding \<psi>_def by auto
       also have "... = (f \<cdot>\<^sub>C \<epsilon>.map x) \<cdot>\<^sub>C F h \<cdot>\<^sub>C F g"
         using C.comp_assoc by fastforce
       also have "... = (f \<cdot>\<^sub>C \<epsilon>.map x) \<cdot>\<^sub>C F (h \<cdot>\<^sub>D g)"
         using g h by fastforce
       also have "... = (\<epsilon>.map x' \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (h \<cdot>\<^sub>D g)"
         using f \<epsilon>.naturality by auto
       also have "... = \<epsilon>.map x' \<cdot>\<^sub>C F ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
         using f g h C.comp_assoc by fastforce
       also have "... = \<psi> x' ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
         unfolding \<psi>_def by auto
       finally show ?thesis by auto
     qed
 
     lemma \<psi>_inverts_coext:
     assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "arrow_from_functor.is_coext D C F (G x) (\<epsilon>.map x) y (\<psi> x g) g"
     proof -
       interpret x\<epsilon>: arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon>.map x\<close>
         using x \<epsilon>.maps_ide_in_hom by unfold_locales auto
       show "x\<epsilon>.is_coext y (\<psi> x g) g"
         using x g \<psi>_def x\<epsilon>.is_coext_def G_ide by blast
     qed
 
     lemma \<psi>_invertible:
     assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<exists>!g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"
     proof
       have x: "C.ide x" using f by auto
       interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
         using x ex_terminal_arrow Go_\<epsilon>o_terminal by auto
       have 1: "arrow_from_functor D C F y x f"
         using y f by (unfold_locales, auto)
       let ?g = "x\<epsilon>.the_coext y f"
       have "\<psi> x ?g = f"
         using 1 x y \<psi>_def x\<epsilon>.the_coext_prop G_ide \<psi>_inverts_coext x\<epsilon>.is_coext_def by simp
       thus "\<guillemotleft>?g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x ?g = f"
         using 1 x x\<epsilon>.the_coext_prop G_ide by simp
       show "\<And>g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = f \<Longrightarrow> g' = ?g"
         using 1 x y \<psi>_inverts_coext G_ide x\<epsilon>.the_coext_unique by force
     qed
 
     definition \<phi>
     where "\<phi> y f = (THE g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G (C.cod f)\<guillemotright> \<and> \<psi> (C.cod f) g = f)"
 
     lemma \<phi>_in_hom:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       using assms \<psi>_invertible \<phi>_def theI' [of "\<lambda>g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"]
       by auto
 
     lemma \<phi>_\<psi>:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<phi> y (\<psi> x g) = g"
     proof -
       have "\<phi> y (\<psi> x g) = (THE g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = \<psi> x g)"
       proof -
         have "C.cod (\<psi> x g) = x"
           using assms \<psi>_in_hom by auto
         thus ?thesis
           using \<phi>_def by auto
       qed
       moreover have "\<exists>!g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = \<psi> x g"
         using assms \<psi>_in_hom \<psi>_invertible D.ide_dom by blast
       ultimately show "\<phi> y (\<psi> x g) = g"
         using assms(2) by auto
     qed
 
     lemma \<psi>_\<phi>:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<psi> x (\<phi> y f) = f"
       using assms \<psi>_invertible \<phi>_def theI' [of "\<lambda>g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"]
       by auto
 
     lemma \<phi>_natural:
     assumes "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = (G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g"
     proof -
       have "C.ide x' \<and> D.ide y \<and> D.in_hom (\<phi> y h) y (G x)"
         using assms \<phi>_in_hom by auto
       thus ?thesis
         using assms D.comp_in_homI G.preserves_hom \<psi>_natural [of f x x' g y' y "\<phi> y h"] \<phi>_\<psi> \<psi>_\<phi>
         by auto
     qed
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>"
       using \<phi>_in_hom \<psi>_in_hom \<phi>_\<psi> \<psi>_\<phi> \<phi>_natural D.comp_assoc
       by unfold_locales auto
 
   end
 
   text\<open>
     A right adjoint functor induces a meta-adjunction, modulo the choice of a
     left adjoint and unit.
 \<close>
 
   context right_adjoint_functor
   begin
 
     definition Fo :: "'d \<Rightarrow> 'c"
     where "Fo y = (SOME x. \<exists>u. initial_arrow_to_functor C D G y x u)"
 
     definition \<eta>o :: "'d \<Rightarrow> 'd"
     where "\<eta>o y = (SOME u. initial_arrow_to_functor C D G y (Fo y) u)"
 
     lemma Fo_\<eta>o_initial:
     assumes "\<exists>x u. initial_arrow_to_functor C D G y x u"
     shows "initial_arrow_to_functor C D G y (Fo y) (\<eta>o y)"
       using assms Fo_def \<eta>o_def
             someI_ex [of "\<lambda>x. \<exists>u. initial_arrow_to_functor C D G y x u"]
             someI_ex [of "\<lambda>u. initial_arrow_to_functor C D G y (Fo y) u"]
       by simp
 
     text\<open>
       The left adjoint @{term F} to @{term g} takes each arrow @{term g} of
       @{term[source=true] D} to the unique @{term[source=true] C}-extension of
       @{term "D (\<eta>o (D.cod g)) g"} along @{term "\<eta>o (D.dom g)"}.
 \<close>
 
     definition F :: "'d \<Rightarrow> 'c"
     where "F g = (if D.arr g then
                      initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (\<eta>o (D.dom g))
                                   (Fo (D.cod g)) (\<eta>o (D.cod g) \<cdot>\<^sub>D g)
                   else C.null)"
 
     lemma F_ide:
     assumes "D.ide y"
     shows "F y = Fo y"
     proof -
       interpret initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
         using assms initial_arrows_exist Fo_\<eta>o_initial by blast
       have 1: "arrow_to_functor C D G y (Fo y) (\<eta>o y)" ..
       have "is_ext (Fo y) (\<eta>o y) (Fo y)"
         unfolding is_ext_def using arrow D.comp_ide_arr [of "G (Fo y)" "\<eta>o y"] by force
       hence "Fo y = the_ext (Fo y) (\<eta>o y)"
         using 1 the_ext_unique by blast
       moreover have "\<eta>o y = D (\<eta>o (D.cod y)) y"
         using assms arrow D.comp_arr_ide D.comp_arr_dom by auto
       ultimately show ?thesis
         using assms F_def D.dom_cod D.in_homE D.ide_in_hom by metis
     qed
 
     lemma F_is_functor:
     shows "functor D C F"
     proof
       fix g :: 'd
       assume "\<not>D.arr g"
       thus "F g = C.null" using F_def by auto
       next
       fix g :: 'd
       assume g: "D.arr g"
       let ?y = "D.dom g"
       let ?y' = "D.cod g"
       interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       have 1: "arrow_to_functor C D G ?y (Fo ?y') (D (\<eta>o ?y') g)"
         using g y'\<eta>.arrow by unfold_locales auto
       have "F g = y\<eta>.the_ext (Fo ?y') (D (\<eta>o ?y') g)"
         using g F_def by simp
       hence Fg: "\<guillemotleft>F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y'\<guillemotright> \<and> \<eta>o ?y' \<cdot>\<^sub>D g = G (F g) \<cdot>\<^sub>D \<eta>o ?y"
         using 1 y\<eta>.the_ext_prop by simp
       show "C.arr (F g)" using Fg by auto
       show "C.dom (F g) = F ?y" using Fg g F_ide by auto
       show "C.cod (F g) = F ?y'" using Fg g F_ide by auto
       next
       fix g :: 'd
       fix g' :: 'd
       assume g': "D.arr (D g' g)"
       have g: "D.arr g" using g' by auto
       let ?y = "D.dom g"
       let ?y' = "D.cod g"
       let ?y'' = "D.cod g'"
       interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       interpret y''\<eta>: initial_arrow_to_functor C D G ?y'' \<open>Fo ?y''\<close> \<open>\<eta>o ?y''\<close>
         using g' initial_arrows_exist Fo_\<eta>o_initial by auto
       have 1: "arrow_to_functor C D G ?y (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
         using g y'\<eta>.arrow by unfold_locales auto
       have "F g = y\<eta>.the_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
         using g F_def by simp
       hence Fg: "\<guillemotleft>F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y'\<guillemotright> \<and> \<eta>o ?y' \<cdot>\<^sub>D g = G (F g) \<cdot>\<^sub>D \<eta>o ?y"
         using 1 y\<eta>.the_ext_prop by simp
       have 2: "arrow_to_functor C D G ?y' (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g')"
         using g' y''\<eta>.arrow by unfold_locales auto
       have "F g' = y'\<eta>.the_ext (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g')"
         using g' F_def by auto
       hence Fg': "\<guillemotleft>F g' : Fo ?y' \<rightarrow>\<^sub>C Fo ?y''\<guillemotright> \<and> \<eta>o ?y'' \<cdot>\<^sub>D g' = G (F g') \<cdot>\<^sub>D \<eta>o ?y'"
         using 2 y'\<eta>.the_ext_prop by simp
       show "F (g' \<cdot>\<^sub>D g) = F g' \<cdot>\<^sub>C F g"
       proof -
         have "y\<eta>.is_ext (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g) (F g' \<cdot>\<^sub>C F g)"
         proof -
           have 3: "\<guillemotleft>F g' \<cdot>\<^sub>C F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y''\<guillemotright>" using 1 2 Fg Fg' by auto
           moreover have "\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g = G (F g' \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>o ?y"
             using Fg Fg' g g' 3 y''\<eta>.arrow
             by (metis C.arrI D.comp_assoc preserves_comp)
           ultimately show ?thesis using y\<eta>.is_ext_def by auto
         qed
         moreover have "arrow_to_functor C D G ?y (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g)"
           using g g' y''\<eta>.arrow by unfold_locales auto
         ultimately show ?thesis
           using g g' F_def y\<eta>.the_ext_unique D.dom_comp D.cod_comp by auto
       qed
     qed
 
     interpretation F: "functor" D C F using F_is_functor by auto
 
     lemma F_simp:
     assumes "D.arr g"
     shows "F g = initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (\<eta>o (D.dom g))
                                                         (Fo (D.cod g)) (\<eta>o (D.cod g) \<cdot>\<^sub>D g)"
       using assms F_def by simp
 
     interpretation FG: composite_functor D C D F G ..
 
     interpretation \<eta>: transformation_by_components D D D.map FG.map \<eta>o
     proof
       fix y :: 'd
       assume y: "D.ide y"
       show "\<guillemotleft>\<eta>o y : D.map y \<rightarrow>\<^sub>D FG.map y\<guillemotright>"
       proof -
         interpret initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
           using y Fo_\<eta>o_initial initial_arrows_exist by simp
         show ?thesis using y F_ide arrow by auto
       qed
       next
       fix g :: 'd
       assume g: "D.arr g"
       show "\<eta>o (D.cod g) \<cdot>\<^sub>D D.map g = FG.map g \<cdot>\<^sub>D \<eta>o (D.dom g)"
       proof -
         let ?y = "D.dom g"
         let ?y' = "D.cod g"
         interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
           using g Fo_\<eta>o_initial initial_arrows_exist by simp
         interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
           using g Fo_\<eta>o_initial initial_arrows_exist by simp
         have "arrow_to_functor C D G ?y (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
           using g y'\<eta>.arrow by unfold_locales auto
         moreover have "F g = y\<eta>.the_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
           using g F_simp by blast
         ultimately have "y\<eta>.is_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g) (F g)"
           using y\<eta>.the_ext_prop y\<eta>.is_ext_def by auto
         thus ?thesis
           using g y\<eta>.is_ext_def by simp
       qed
     qed
 
     definition \<phi>
     where "\<phi> y h = D (G h) (\<eta>.map y)"
 
     lemma \<phi>_in_hom:
     assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       unfolding \<phi>_def using assms \<eta>.maps_ide_in_hom by auto
 
     lemma \<phi>_natural:
     assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = (G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g"
     proof -
       have "(G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g = (G f \<cdot>\<^sub>D G h \<cdot>\<^sub>D \<eta>.map y) \<cdot>\<^sub>D g"
         unfolding \<phi>_def by auto
       also have "... = (G f \<cdot>\<^sub>D G h) \<cdot>\<^sub>D \<eta>.map y \<cdot>\<^sub>D g"
         using D.comp_assoc by fastforce
       also have "... = G (f \<cdot>\<^sub>C h) \<cdot>\<^sub>D G (F g) \<cdot>\<^sub>D \<eta>.map y'"
         using f g h \<eta>.naturality by fastforce
       also have "... = (G (f \<cdot>\<^sub>C h) \<cdot>\<^sub>D G (F g)) \<cdot>\<^sub>D \<eta>.map y'"
         using D.comp_assoc by fastforce
       also have "... = G (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>.map y'"
         using f g h D.comp_assoc by fastforce
       also have "... = \<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)"
         unfolding \<phi>_def by auto
       finally show ?thesis by auto
     qed
 
     lemma \<phi>_inverts_ext:
     assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "arrow_to_functor.is_ext C D G (F y) (\<eta>.map y) x (\<phi> y f) f"
     proof -
       interpret y\<eta>: arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta>.map y\<close>
         using y \<eta>.maps_ide_in_hom by unfold_locales auto
       show "y\<eta>.is_ext x (\<phi> y f) f"
         using f y \<phi>_def y\<eta>.is_ext_def F_ide by blast
     qed
 
     lemma \<phi>_invertible:
     assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<exists>!f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"
     proof
       have y: "D.ide y" using g by auto
       interpret y\<eta>: initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
         using y initial_arrows_exist Fo_\<eta>o_initial by auto
       have 1: "arrow_to_functor C D G y x g"
         using x g by (unfold_locales, auto)
       let ?f = "y\<eta>.the_ext x g"
       have "\<phi> y ?f = g"
         using \<phi>_def y\<eta>.the_ext_prop 1 F_ide x y \<phi>_inverts_ext y\<eta>.is_ext_def by fastforce
       moreover have "\<guillemotleft>?f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
         using 1 y y\<eta>.the_ext_prop F_ide by simp
       ultimately show "\<guillemotleft>?f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y ?f = g" by auto
       show "\<And>f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = g \<Longrightarrow> f' = ?f"
         using 1 y \<phi>_inverts_ext y\<eta>.the_ext_unique F_ide by force
     qed
 
     definition \<psi>
     where "\<psi> x g = (THE f. \<guillemotleft>f : F (D.dom g) \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> (D.dom g) f = g)"
 
     lemma \<psi>_in_hom:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "C.in_hom (\<psi> x g) (F y) x"
       using assms \<phi>_invertible \<psi>_def theI' [of "\<lambda>f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"]
       by auto
 
     lemma \<psi>_\<phi>:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<psi> x (\<phi> y f) = f"
     proof -
       have "D.dom (\<phi> y f) = y" using assms \<phi>_in_hom by blast
       hence "\<psi> x (\<phi> y f) = (THE f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = \<phi> y f)"
         using \<psi>_def by auto
       moreover have "\<exists>!f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = \<phi> y f"
         using assms \<phi>_in_hom \<phi>_invertible C.ide_cod by blast
       ultimately show ?thesis using assms(2) by auto
     qed
 
     lemma \<phi>_\<psi>:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<phi> y (\<psi> x g) = g"
       using assms \<phi>_invertible \<psi>_def theI' [of "\<lambda>f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"]
       by auto
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>"
       using \<phi>_in_hom \<psi>_in_hom \<phi>_\<psi> \<psi>_\<phi> \<phi>_natural D.comp_assoc
       by (unfold_locales, auto)
 
   end
 
   section "Meta-Adjunctions Induce Hom-Adjunctions"
 
   text\<open>
     To obtain a hom-adjunction from a meta-adjunction, we need to exhibit hom-functors
     from @{term C} and @{term D} to a common set category @{term S}, so it is necessary
     to apply an actual concrete construction of such a category.
     We use the replete set category generated by the disjoint sum
     @{typ "('c+'d)"} of the arrow types of @{term C} and @{term D}.
 \<close>
 
   context meta_adjunction
   begin
 
     interpretation S: replete_setcat \<open>undefined :: 'c+'d\<close> .
 
     definition inC :: "'c \<Rightarrow> ('c+'d) setcat.arr"
     where "inC \<equiv> S.UP o Inl"
 
     definition inD :: "'d \<Rightarrow> ('c+'d) setcat.arr"
     where "inD \<equiv> S.UP o Inr"
 
     interpretation Cop: dual_category C ..
     interpretation Dop: dual_category D ..
     interpretation CopxC: product_category Cop.comp C ..
     interpretation DopxD: product_category Dop.comp D ..
     interpretation DopxC: product_category Dop.comp C ..
     interpretation HomC: hom_functor C S.comp \<open>\<lambda>_. inC\<close>
     proof
       show "\<And>f. C.arr f \<Longrightarrow> inC f \<in> S.Univ"
         unfolding inC_def using S.UP_mapsto by auto
       show "\<And>b a. \<lbrakk>C.ide b; C.ide a\<rbrakk> \<Longrightarrow> inj_on inC (C.hom b a)"
         unfolding inC_def
         using S.inj_UP
         by (metis injD inj_Inl inj_compose inj_on_def)
     qed
     interpretation HomD: hom_functor D S.comp \<open>\<lambda>_. inD\<close>
     proof
       show "\<And>f. D.arr f \<Longrightarrow> inD f \<in> S.Univ"
         unfolding inD_def using S.UP_mapsto by auto
       show "\<And>b a. \<lbrakk>D.ide b; D.ide a\<rbrakk> \<Longrightarrow> inj_on inD (D.hom b a)"
         unfolding inD_def
         using S.inj_UP
         by (metis injD inj_Inr inj_compose inj_on_def)
     qed
     interpretation Fop: dual_functor D C F ..
     interpretation FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map ..
     interpretation DopxG: product_functor Dop.comp C Dop.comp D Dop.map G ..
     interpretation Hom_FopxC: composite_functor DopxC.comp CopxC.comp S.comp
                                                 FopxC.map HomC.map ..
     interpretation Hom_DopxG: composite_functor DopxC.comp DopxD.comp S.comp
                                                 DopxG.map HomD.map ..
 
     lemma inC_\<psi> [simp]:
     assumes "C.ide b" and "C.ide a" and "x \<in> inC ` C.hom b a"
     shows "inC (HomC.\<psi> (b, a) x) = x"
       using assms by auto
 
     lemma \<psi>_inC [simp]:
     assumes "C.arr f"
     shows "HomC.\<psi> (C.dom f, C.cod f) (inC f) = f"
       using assms HomC.\<psi>_\<phi> by blast
 
     lemma inD_\<psi> [simp]:
     assumes "D.ide b" and "D.ide a" and "x \<in> inD ` D.hom b a"
     shows "inD (HomD.\<psi> (b, a) x) = x"
       using assms by auto
 
     lemma \<psi>_inD [simp]:
     assumes "D.arr f"
     shows "HomD.\<psi> (D.dom f, D.cod f) (inD f) = f"
       using assms HomD.\<psi>_\<phi> by blast
 
     lemma Hom_FopxC_simp:
     assumes "DopxC.arr gf"
     shows "Hom_FopxC.map gf =
               S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
                       (HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
                       (inC \<circ> (\<lambda>h. snd gf \<cdot>\<^sub>C h \<cdot>\<^sub>C F (fst gf))
                            \<circ> HomC.\<psi> (F (D.cod (fst gf)), C.dom (snd gf)))"
       using assms HomC.map_def by simp
 
     lemma Hom_DopxG_simp:
     assumes "DopxC.arr gf"
     shows "Hom_DopxG.map gf =
               S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
                       (HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
                       (inD \<circ> (\<lambda>h. G (snd gf) \<cdot>\<^sub>D h \<cdot>\<^sub>D fst gf)
                            \<circ> HomD.\<psi> (D.cod (fst gf), G (C.dom (snd gf))))"
       using assms HomD.map_def by simp
                       
     definition \<Phi>o
     where "\<Phi>o yx = S.mkArr (HomC.set (F (fst yx), snd yx))
                            (HomD.set (fst yx, G (snd yx)))
                            (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
 
     lemma \<Phi>o_in_hom:
     assumes yx: "DopxC.ide yx"
     shows "\<guillemotleft>\<Phi>o yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
     proof -
       have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
         using yx HomC.map_ide by auto
       moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
         using yx HomD.map_ide by auto
       moreover have
           "\<guillemotleft>S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
                     (inD \<circ> \<phi> (fst yx) \<circ> HomC.\<psi> (F (fst yx), snd yx)) :
               S.mkIde (HomC.set (F (fst yx), snd yx))
                  \<rightarrow>\<^sub>S S.mkIde (HomD.set (fst yx, G (snd yx)))\<guillemotright>"
       proof (intro S.mkArr_in_hom)
         show "HomC.set (F (fst yx), snd yx) \<subseteq> S.Univ" using yx HomC.set_subset_Univ by simp
         show "HomD.set (fst yx, G (snd yx)) \<subseteq> S.Univ" using yx HomD.set_subset_Univ by simp
         show "inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)
                  \<in> HomC.set (F (fst yx), snd yx) \<rightarrow> HomD.set (fst yx, G (snd yx))"
         proof
           fix x
           assume x: "x \<in> HomC.set (F (fst yx), snd yx)"
           show "(inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)) x
                   \<in> HomD.set (fst yx, G (snd yx))"
             using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"]
                   \<phi>_in_hom [of "fst yx"] HomD.\<phi>_mapsto [of "fst yx" "G (snd yx)"]
             by auto
         qed
       qed
       ultimately show ?thesis using \<Phi>o_def by auto
     qed
 
     interpretation \<Phi>: transformation_by_components
                         DopxC.comp S.comp Hom_FopxC.map Hom_DopxG.map \<Phi>o
     proof
       fix yx
       assume yx: "DopxC.ide yx"
       show "\<guillemotleft>\<Phi>o yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
         using yx \<Phi>o_in_hom by auto
       next
       fix gf
       assume gf: "DopxC.arr gf"
       show "S.comp (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)
                 = S.comp (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))"
       proof -
         let ?g = "fst gf"
         let ?f = "snd gf"
         let ?x = "C.dom ?f"
         let ?x' = "C.cod ?f"
         let ?y = "D.cod ?g"
         let ?y' = "D.dom ?g"
         let ?Fy = "F ?y"
         let ?Fy' = "F ?y'"
         let ?Fg = "F ?g"
         let ?Gx = "G ?x"
         let ?Gx' = "G ?x'"
         let ?Gf = "G ?f"
         have 1: "S.arr (Hom_FopxC.map gf) \<and>
                  Hom_FopxC.map gf = S.mkArr (HomC.set (?Fy, ?x)) (HomC.set (?Fy', ?x'))
                                             (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))"
           using gf Hom_FopxC.preserves_arr Hom_FopxC_simp by blast
         have 2: "S.arr (\<Phi>o (DopxC.cod gf)) \<and>
                  \<Phi>o (DopxC.cod gf) = S.mkArr (HomC.set (?Fy', ?x')) (HomD.set (?y', ?Gx'))
                                              (inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))"
           using gf \<Phi>o_in_hom [of "DopxC.cod gf"] \<Phi>o_def [of "DopxC.cod gf"] \<phi>_in_hom
                 S.card_of_leq
           by auto
         have 3: "S.arr (\<Phi>o (DopxC.dom gf)) \<and>
                  \<Phi>o (DopxC.dom gf) = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y, ?Gx))
                                              (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))"
           using gf \<Phi>o_in_hom [of "DopxC.dom gf"] \<Phi>o_def [of "DopxC.dom gf"] \<phi>_in_hom
                 S.card_of_leq
           by auto
         have 4: "S.arr (Hom_DopxG.map gf) \<and>
                  Hom_DopxG.map gf = S.mkArr (HomD.set (?y, ?Gx)) (HomD.set (?y', ?Gx'))
                                             (inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))"
           using gf Hom_DopxG.preserves_arr Hom_DopxG_simp by blast
         have 5: "S.seq (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf) \<and>
                  S.comp (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)
                      = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                                ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                                  o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x)))"
           by (metis gf 1 2 DopxC.arr_iff_in_hom DopxC.ide_cod Hom_FopxC.preserves_hom
                     S.comp_mkArr S.seqI' \<Phi>o_in_hom)
         have 6: "S.comp (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))
                   = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                             ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                               o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x)))"
           by (metis 3 4 S.comp_mkArr)
         have 7:
           "restrict ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                       o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) (HomC.set (?Fy, ?x))
              = restrict ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                           o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) (HomC.set (?Fy, ?x))"
         proof (intro restrict_ext)
           show "\<And>h. h \<in> HomC.set (?Fy, ?x) \<Longrightarrow>
                      ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                        o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
                        = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                            o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
           proof -
             fix h
             assume h: "h \<in> HomC.set (?Fy, ?x)"
             have \<psi>h: "\<guillemotleft>HomC.\<psi> (?Fy, ?x) h : ?Fy \<rightarrow>\<^sub>C ?x\<guillemotright>"
               using gf h HomC.\<psi>_mapsto [of ?Fy ?x] CopxC.ide_char by auto
             show "((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                        o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
                        = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                            o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
             proof -
               have
                 "((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                    o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
                    = inD (\<phi> ?y' (?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg))"
                 using gf \<psi>h HomC.\<phi>_mapsto HomC.\<psi>_mapsto \<phi>_in_hom
                       \<psi>_inC [of "?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg"]
                 by auto
               also have "... = inD (D ?Gf (D (\<phi> ?y (HomC.\<psi> (?Fy, ?x) h)) ?g))"
                 by (metis (no_types, lifting) C.arr_cod C.arr_dom_iff_arr C.arr_iff_in_hom
                     C.in_homE D.arr_cod_iff_arr D.arr_iff_in_hom F.preserves_reflects_arr
                     \<phi>_naturality \<psi>h)
               also have "... = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                                 o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
                 using gf \<psi>h \<phi>_in_hom by simp
               finally show ?thesis by auto
             qed
           qed
         qed
         have 8: "S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                          ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                            o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x)))
                     = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                               ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                                 o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x)))"
           using 5 7 by force
         show ?thesis using 5 6 8 by auto
       qed
     qed
 
     lemma \<Phi>_simp:
     assumes YX: "DopxC.ide yx"
     shows "\<Phi>.map yx =
            S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
                    (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
       using YX \<Phi>o_def by simp
       
     abbreviation \<Psi>o
     where "\<Psi>o yx \<equiv> S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
                             (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))"
 
     lemma \<Psi>o_in_hom:
     assumes yx: "DopxC.ide yx"
     shows "\<guillemotleft>\<Psi>o yx : Hom_DopxG.map yx \<rightarrow>\<^sub>S Hom_FopxC.map yx\<guillemotright>"
     proof -
       have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
         using yx HomC.map_ide by auto
       moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
         using yx HomD.map_ide by auto
       moreover have "\<guillemotleft>\<Psi>o yx : S.mkIde (HomD.set (fst yx, G (snd yx)))
                                  \<rightarrow>\<^sub>S S.mkIde (HomC.set (F (fst yx), snd yx))\<guillemotright>"
       proof (intro S.mkArr_in_hom)
         show "HomC.set (F (fst yx), snd yx) \<subseteq> S.Univ" using yx HomC.set_subset_Univ by simp
         show "HomD.set (fst yx, G (snd yx)) \<subseteq> S.Univ" using yx HomD.set_subset_Univ by simp
         show "inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))
                  \<in> HomD.set (fst yx, G (snd yx)) \<rightarrow> HomC.set (F (fst yx), snd yx)"
         proof
           fix x
           assume x: "x \<in> HomD.set (fst yx, G (snd yx))"
           show "(inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))) x
                   \<in> HomC.set (F (fst yx), snd yx)"
             using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<psi>_in_hom [of "snd yx"]
                   HomC.\<phi>_mapsto [of "F (fst yx)" "snd yx"]
             by auto
         qed
       qed
       ultimately show ?thesis by auto
     qed
 
     lemma \<Phi>_inv:
     assumes yx: "DopxC.ide yx"
     shows "S.inverse_arrows (\<Phi>.map yx) (\<Psi>o yx)"
     proof -
       have 1: "\<guillemotleft>\<Phi>.map yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
         using yx \<Phi>.preserves_hom [of yx yx yx] DopxC.ide_in_hom by blast
       have 2: "\<guillemotleft>\<Psi>o yx : Hom_DopxG.map yx \<rightarrow>\<^sub>S Hom_FopxC.map yx\<guillemotright>"
         using yx \<Psi>o_in_hom by simp
       have 3: "\<Phi>.map yx = S.mkArr (HomC.set (F (fst yx), snd yx))
                                    (HomD.set (fst yx, G (snd yx)))
                                    (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
         using yx \<Phi>_simp by blast
       have antipar: "S.antipar (\<Phi>.map yx) (\<Psi>o yx)"
         using 1 2 by blast
       moreover have "S.ide (S.comp (\<Psi>o yx) (\<Phi>.map yx))"
       proof -
         have "S.comp (\<Psi>o yx) (\<Phi>.map yx) =
                   S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                           ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                             o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)))"
           using 1 2 3 antipar S.comp_mkArr by auto
         also have
           "... = S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                          (\<lambda>x. x)"
         proof -
           have
             "S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx)) (\<lambda>x. x)
                = ..."
           proof
             show
               "S.arr (S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                      (\<lambda>x. x))"
               using yx HomC.set_subset_Univ S.arr_mkArr by simp
             show "\<And>x. x \<in> HomC.set (F (fst yx), snd yx) \<Longrightarrow>
                         x = ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                              o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x"
             proof -
               fix x
               assume x: "x \<in> HomC.set (F (fst yx), snd yx)"
               have "((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                              o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x
                       = inC (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx))
                               (inD (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx) x)))))"
                 by simp
               also have "... = inC (\<psi> (snd yx) (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx) x)))"
                 using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"] \<phi>_in_hom by force
               also have "... = inC (HomC.\<psi> (F (fst yx), snd yx) x)"
                 using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"] \<psi>_\<phi> by force
               also have "... = x" using x yx inC_\<psi> by simp
               finally show "x = ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                                    o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x"
                 by auto
             qed
           qed
           thus ?thesis by auto
         qed
         also have "... = S.mkIde (HomC.set (F (fst yx), snd yx))"
           using yx S.mkIde_as_mkArr HomC.set_subset_Univ by force
         finally have
             "S.comp (\<Psi>o yx) (\<Phi>.map yx) = S.mkIde (HomC.set (F (fst yx), snd yx))"
           by auto
         thus ?thesis using yx HomC.set_subset_Univ S.ide_mkIde by simp
       qed
       moreover have "S.ide (S.comp (\<Phi>.map yx) (\<Psi>o yx))"
       proof -
         have "S.comp (\<Phi>.map yx) (\<Psi>o yx) =
                   S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                           ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                             o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))))"
           using 1 2 3 S.comp_mkArr antipar by fastforce
         also
           have "... = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                               (\<lambda>x. x)"
         proof -
           have
             "S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx))) (\<lambda>x. x)
                 = ..."
           proof
             show
               "S.arr (S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                      (\<lambda>x. x))"
               using yx HomD.set_subset_Univ S.arr_mkArr by simp
             show "\<And>x. x \<in> (HomD.set (fst yx, G (snd yx))) \<Longrightarrow>
                         x = ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                             o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x"
             proof -
               fix x
               assume x: "x \<in> HomD.set (fst yx, G (snd yx))"
               have "((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                           o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x
                        = inD (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx)
                             (inC (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x)))))"
                 by simp
               also have "... = inD (\<phi> (fst yx) (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x)))"
               proof -
                 have "\<guillemotleft>\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x) : F (fst yx) \<rightarrow> snd yx\<guillemotright>"
                   using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<psi>_in_hom by auto
                 thus ?thesis by simp
               qed
               also have "... = inD (HomD.\<psi> (fst yx, G (snd yx)) x)"
                 using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<phi>_\<psi> by force
               also have "... = x" using x yx inD_\<psi> by simp
               finally show "x = ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                                    o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x"
                 by auto
             qed
           qed
           thus ?thesis by auto
         qed
         also have "... = S.mkIde (HomD.set (fst yx, G (snd yx)))"
           using yx S.mkIde_as_mkArr HomD.set_subset_Univ by force
         finally have
             "S.comp (\<Phi>.map yx) (\<Psi>o yx) = S.mkIde (HomD.set (fst yx, G (snd yx)))"
           by auto
         thus ?thesis using yx HomD.set_subset_Univ S.ide_mkIde by simp
       qed
       ultimately show ?thesis by auto
     qed
 
     interpretation \<Phi>: natural_isomorphism DopxC.comp S.comp
                                           Hom_FopxC.map Hom_DopxG.map \<Phi>.map
       using \<Phi>_inv by unfold_locales blast
 
     interpretation \<Psi>: inverse_transformation DopxC.comp S.comp
                            Hom_FopxC.map Hom_DopxG.map \<Phi>.map ..
 
     interpretation \<Phi>\<Psi>: inverse_transformations DopxC.comp S.comp
                            Hom_FopxC.map Hom_DopxG.map \<Phi>.map \<Psi>.map
       using \<Psi>.inverts_components by unfold_locales simp
 
     abbreviation \<Phi> where "\<Phi> \<equiv> \<Phi>.map"
     abbreviation \<Psi> where "\<Psi> \<equiv> \<Psi>.map"
 
     abbreviation HomC where "HomC \<equiv> HomC.map"
     abbreviation \<phi>C where "\<phi>C \<equiv> \<lambda>_. inC"
     abbreviation HomD where "HomD \<equiv> HomD.map"
     abbreviation \<phi>D where "\<phi>D \<equiv> \<lambda>_. inD"
 
     theorem induces_hom_adjunction: "hom_adjunction C D S.comp \<phi>C \<phi>D F G \<Phi> \<Psi>"
       using F.is_extensional by unfold_locales auto
 
     lemma \<Psi>_simp:
     assumes yx: "DopxC.ide yx"
     shows "\<Psi> yx = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
                           (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))"
       using assms \<Phi>o_def \<Phi>_inv S.inverse_unique by simp
 
     text\<open>
       The original @{term \<phi>} and @{term \<psi>} can be recovered from @{term \<Phi>} and @{term \<Psi>}.
 \<close>
 
     interpretation \<Phi>: set_valued_transformation DopxC.comp S.comp
                                                 Hom_FopxC.map Hom_DopxG.map \<Phi>.map ..
      
     interpretation \<Psi>: set_valued_transformation DopxC.comp S.comp
                                                 Hom_DopxG.map Hom_FopxC.map \<Psi>.map ..
 
     lemma \<phi>_in_terms_of_\<Phi>':
     assumes y: "D.ide y" and f: "\<guillemotleft>f: F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y f = (HomD.\<psi> (y, G x) o \<Phi>.FUN (y, x) o inC) f"
     proof -
       have x: "C.ide x" using f by auto
       have "(HomD.\<psi> (y, G x) o \<Phi>.FUN (y, x) o inC) f =
               HomD.\<psi> (y, G x)
                      (restrict (inD o \<phi> y o HomC.\<psi> (F y, x)) (HomC.set (F y, x)) (inC f))"
       proof -
         have "S.arr (\<Phi> (y, x))" using x y by fastforce
         thus ?thesis
           using x y \<Phi>o_def by simp
       qed
       also have "... = \<phi> y f"
         using x y f HomC.\<phi>_mapsto \<phi>_in_hom HomC.\<psi>_mapsto C.ide_in_hom D.ide_in_hom
         by auto
       finally show ?thesis by auto
     qed
 
     lemma \<psi>_in_terms_of_\<Psi>':
     assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<psi> x g = (HomC.\<psi> (F y, x) o \<Psi>.FUN (y, x) o inD) g"
     proof -
       have y: "D.ide y" using g by auto
       have "(HomC.\<psi> (F y, x) o \<Psi>.FUN (y, x) o inD) g =
               HomC.\<psi> (F y, x)
                      (restrict (inC o \<psi> x o HomD.\<psi> (y, G x)) (HomD.set (y, G x)) (inD g))"
       proof -
         have "S.arr (\<Psi> (y, x))"
           using x y \<Psi>.preserves_reflects_arr [of "(y, x)"] by simp
         thus ?thesis
           using x y \<Psi>_simp by simp
       qed
       also have "... = \<psi> x g"
         using x y g HomD.\<phi>_mapsto \<psi>_in_hom HomD.\<psi>_mapsto C.ide_in_hom D.ide_in_hom
         by auto
       finally show ?thesis by auto
     qed
 
   end
 
   section "Hom-Adjunctions Induce Meta-Adjunctions"
 
   context hom_adjunction
   begin
 
     definition \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     where
       "\<phi> y h = (HomD.\<psi> (y, G (C.cod h)) o \<Phi>.FUN (y, C.cod h) o \<phi>C (F y, C.cod h)) h"
     
     definition \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     where
       "\<psi> x h = (HomC.\<psi> (F (D.dom h), x) o \<Psi>.FUN (D.dom h, x) o \<phi>D (D.dom h, G x)) h"
 
     lemma Hom_FopxC_map_simp:
     assumes "DopxC.arr gf"
     shows "Hom_FopxC.map gf =
               S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
                       (HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))            
                       (\<phi>C (F (D.dom (fst gf)), C.cod (snd gf))
                            o (\<lambda>h. snd gf \<cdot>\<^sub>C h \<cdot>\<^sub>C F (fst gf))
                            o HomC.\<psi> (F (D.cod (fst gf)), C.dom (snd gf)))"
       using assms HomC.map_def by simp
 
     lemma Hom_DopxG_map_simp:
     assumes "DopxC.arr gf"
     shows "Hom_DopxG.map gf =
               S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
                       (HomD.set (D.dom (fst gf), G (C.cod (snd gf))))           
                       (\<phi>D (D.dom (fst gf), G (C.cod (snd gf)))
                            o (\<lambda>h. G (snd gf) \<cdot>\<^sub>D h \<cdot>\<^sub>D fst gf)
                            o HomD.\<psi> (D.cod (fst gf), G (C.dom (snd gf))))"
       using assms HomD.map_def by simp
                       
     lemma \<Phi>_Fun_mapsto:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<Phi>.FUN (y, x) \<in> HomC.set (F y, x) \<rightarrow> HomD.set (y, G x)"
     proof -
       have "S.arr (\<Phi> (y, x)) \<and> \<Phi>.DOM (y, x) = HomC.set (F y, x) \<and>
                                 \<Phi>.COD (y, x) = HomD.set (y, G x)"
         using assms HomC.set_map HomD.set_map by auto
       thus ?thesis using S.Fun_mapsto by blast
     qed
 
     lemma \<phi>_mapsto:
     assumes y: "D.ide y"
     shows "\<phi> y \<in> C.hom (F y) x \<rightarrow> D.hom y (G x)"
     proof
       fix h
       assume h: "h \<in> C.hom (F y) x"
       hence 1: " \<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>" by simp
       show "\<phi> y h \<in> D.hom y (G x)"
       proof -
         have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
           using y h 1 HomC.\<phi>_mapsto [of "F y" x] by fastforce
         hence "\<Phi>.FUN (y, x) (\<phi>C (F y, x) h) \<in> HomD.set (y, G x)"
           using h y \<Phi>_Fun_mapsto by auto
         thus ?thesis
           using y h 1 \<phi>_def HomC.\<phi>_mapsto HomD.\<psi>_mapsto [of y "G x"] by fastforce
       qed
     qed
 
     lemma \<Phi>_simp:
     assumes "D.ide y" and "C.ide x"
     shows "S.arr (\<Phi> (y, x))"
     and "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                             (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
     proof -
       show 1: "S.arr (\<Phi> (y, x))" using assms by auto
       hence "\<Phi> (y, x) = S.mkArr (\<Phi>.DOM (y, x)) (\<Phi>.COD (y, x)) (\<Phi>.FUN (y, x))"
         using S.mkArr_Fun by metis
       also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (\<Phi>.FUN (y, x))"
         using assms HomC.set_map HomD.set_map by fastforce
       also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
       proof (intro S.mkArr_eqI')
         show 2: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (\<Phi>.FUN (y, x)))"
           using 1 calculation by argo
         show "\<And>h. h \<in> HomC.set (F y, x) \<Longrightarrow>
                     \<Phi>.FUN (y, x) h = (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) h"
         proof -
           fix h
           assume h: "h \<in> HomC.set (F y, x)"
           have "(\<phi>D (y, G x) o \<phi> y o HomC.\<psi> (F y, x)) h =
                    \<phi>D (y, G x) (\<psi>D (y, G x) (\<Phi>.FUN (y, x) (\<phi>C (F y, x) (\<psi>C (F y, x) h))))"
           proof -
             have "\<guillemotleft>\<psi>C (F y, x) h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
               using assms h HomC.\<psi>_mapsto [of "F y" x] by auto
             thus ?thesis
               using h \<phi>_def by auto
           qed
           also have "... = \<phi>D (y, G x) (\<psi>D (y, G x) (\<Phi>.FUN (y, x) h))"
             using assms h HomC.\<phi>_\<psi> \<Phi>_Fun_mapsto by simp
           also have "... = \<Phi>.FUN (y, x) h"
             using assms h \<Phi>_Fun_mapsto [of y "\<psi>C (F y, x) h"] HomC.\<psi>_mapsto
                   HomD.\<phi>_\<psi> [of y "G x"] C.ide_in_hom D.ide_in_hom
             by (meson 2 G.preserves_ide S.arr_mkArr funcset_mem)
           finally show "\<Phi>.FUN (y, x) h = (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) h" by auto
         qed
       qed
       finally show "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                        (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
         by force
     qed
 
     lemma \<Psi>_Fun_mapsto:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<Psi>.FUN (y, x) \<in> HomD.set (y, G x) \<rightarrow> HomC.set (F y, x)"
     proof -
       have "S.arr (\<Psi> (y, x)) \<and> \<Psi>.COD (y, x) = HomC.set (F y, x) \<and>
                                 \<Psi>.DOM (y, x) = HomD.set (y, G x)"
         using assms HomC.set_map HomD.set_map by auto
       thus ?thesis using S.Fun_mapsto by fast
     qed
 
     lemma \<psi>_mapsto:
     assumes x: "C.ide x"
     shows "\<psi> x \<in> D.hom y (G x) \<rightarrow> C.hom (F y) x"
     proof
       fix h
       assume h: "h \<in> D.hom y (G x)"
       hence 1: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>" by auto
       show "\<psi> x h \<in> C.hom (F y) x"
       proof -
         have "\<Psi>.FUN (y, x) (\<phi>D (y, G x) h) \<in> HomC.set (F y, x)"
         proof -
           have "\<phi>D (y, G x) h \<in> HomD.set (y, G x)"
             using x h 1 HomD.\<phi>_mapsto [of y "G x"] by fastforce
           thus ?thesis
             using h x \<Psi>_Fun_mapsto by auto
         qed
         thus ?thesis
           using x h 1 \<psi>_def HomD.\<phi>_mapsto HomC.\<psi>_mapsto [of "F y" x] by fastforce
       qed
     qed
 
     lemma \<Psi>_simp:
     assumes "D.ide y" and "C.ide x"
     shows "S.arr (\<Psi> (y, x))"
     and "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                             (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
     proof -
       show 1: "S.arr (\<Psi> (y, x))" using assms by auto
       hence "\<Psi> (y, x) = S.mkArr (\<Psi>.DOM (y, x)) (\<Psi>.COD (y, x)) (\<Psi>.FUN (y, x))"
         using S.mkArr_Fun by metis
       also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (\<Psi>.FUN (y, x))"
         using assms HomC.set_map HomD.set_map by auto
       also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
       proof (intro S.mkArr_eqI')
         show "S.arr (S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (\<Psi>.FUN (y, x)))"
           using 1 calculation by argo
         show "\<And>h. h \<in> HomD.set (y, G x) \<Longrightarrow>
                     \<Psi>.FUN (y, x) h = (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x)) h"
         proof -
           fix h
           assume h: "h \<in> HomD.set (y, G x)"
           have "(\<phi>C (F y, x) o \<psi> x o HomD.\<psi> (y, G x)) h =
                    \<phi>C (F y, x) (\<psi>C (F y, x) (\<Psi>.FUN (y, x) (\<phi>D (y, G x) (\<psi>D (y, G x) h))))"
           proof -
             have "\<guillemotleft>\<psi>D (y, G x) h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
               using assms h HomD.\<psi>_mapsto [of y "G x"] by auto
             thus ?thesis
               using h \<psi>_def by auto
           qed
           also have "... = \<phi>C (F y, x) (\<psi>C (F y, x) (\<Psi>.FUN (y, x) h))"
             using assms h HomD.\<phi>_\<psi> \<Psi>_Fun_mapsto by simp
           also have "... = \<Psi>.FUN (y, x) h"
             using assms h \<Psi>_Fun_mapsto HomD.\<psi>_mapsto [of y "G x"] HomC.\<phi>_\<psi> [of "F y" x]
                   C.ide_in_hom D.ide_in_hom
             by blast
           finally show "\<Psi>.FUN (y, x) h = (\<phi>C (F y, x) o \<psi> x o HomD.\<psi> (y, G x)) h" by auto
         qed
       qed
       finally show "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                        (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
         by force
     qed
 
     text\<open>
       The length of the next proof stems from having to use properties of composition
       of arrows in @{term[source=true] S} to infer properties of the composition of the
       corresponding functions.
 \<close>
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
     proof
       fix y :: 'd and x :: 'c and h :: 'c
       assume y: "D.ide y" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       have x: "C.ide x" using h by auto
       show "\<guillemotleft>\<phi> y h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       proof -
         have "\<Phi>.FUN (y, x) \<in> HomC.set (F y, x) \<rightarrow> HomD.set (y, G x)"
           using y h \<Phi>_Fun_mapsto by blast
         thus ?thesis
           using x y h \<phi>_def HomD.\<psi>_mapsto [of y "G x"] HomC.\<phi>_mapsto [of "F y" x] by auto
       qed
       show "\<psi> x (\<phi> y h) = h"
       proof -
         have 0: "restrict (\<lambda>h. h) (HomC.set (F y, x))
                    = restrict (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (HomC.set (F y, x))"
         proof -
           have 1: "S.ide (\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x))"
             using x y \<Phi>\<Psi>.inv [of "(y, x)"] by auto
           hence 6: "S.seq (\<Psi> (y, x)) (\<Phi> (y, x))" by auto
           have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) \<and>
                    \<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                       (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
             using x y \<Phi>_simp \<Psi>_simp by force
           have 3: "S (\<Psi> (y, x)) (\<Phi> (y, x))
                     = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                               (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))"
           proof -
             have 4: "S.arr (\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x))" using 1 by auto
             hence "S (\<Psi> (y, x)) (\<Phi> (y, x))
                      = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                ((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                                   o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
               using 1 2 S.ide_in_hom S.comp_mkArr by fastforce
             also have "... = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                      (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))"
             proof (intro S.mkArr_eqI')
               show "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                    ((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                                      o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
                 using 4 calculation by simp
               show "\<And>h. h \<in> HomC.set (F y, x) \<Longrightarrow>
                           ((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                             o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))) h =
                           (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) h"
               proof -
                 fix h
                 assume h: "h \<in> HomC.set (F y, x)"
                 hence "\<guillemotleft>\<phi> y (\<psi>C (F y, x) h) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
                   using x y h HomC.\<psi>_mapsto [of "F y" x] \<phi>_mapsto by auto
                 thus "((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                             o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))) h =
                       (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) h"
                   using x y 1 \<phi>_mapsto HomD.\<psi>_\<phi> by simp
               qed
             qed
             finally show ?thesis by simp
           qed
           moreover have "\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x)
                              = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (\<lambda>h. h)"
             using 1 2 6 calculation S.mkIde_as_mkArr S.arr_mkArr S.dom_mkArr S.ideD(2)
             by metis
           ultimately have 4: "S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                       (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))
                                 = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (\<lambda>h. h)"
             by auto
           have 5: "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                   (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)))"
             using 1 3 6 by presburger
           hence "restrict (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (HomC.set (F y, x))
                   = S.Fun (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                          (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)))"
             by auto
           also have "... = restrict (\<lambda>h. h) (HomC.set (F y, x))"
             using 4 5 by auto
           finally show ?thesis by auto
         qed
         moreover have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
           using x y h HomC.\<phi>_mapsto [of "F y" x] by auto
         ultimately have
             "\<phi>C (F y, x) h = (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (\<phi>C (F y, x) h)"
           using x y h HomC.\<phi>_mapsto [of "F y" x] by fast
         hence "\<psi>C (F y, x) (\<phi>C (F y, x) h) =
                  \<psi>C (F y, x) ((\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (\<phi>C (F y, x) h))"
           by simp
         hence "h = \<psi>C (F y, x) (\<phi>C (F y, x) (\<psi> x (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h)))))"
           using x y h HomC.\<psi>_\<phi> [of "F y" x] by simp
         also have "... = \<psi> x (\<phi> y h)"
           using x y h HomC.\<psi>_\<phi> HomC.\<psi>_\<phi> \<phi>_mapsto \<psi>_mapsto
           by (metis PiE mem_Collect_eq)
         finally show ?thesis by auto
       qed
       next
       fix x :: 'c and h :: 'd and y :: 'd
       assume x: "C.ide x" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       have y: "D.ide y" using h by auto
       show "\<guillemotleft>\<psi> x h : F y \<rightarrow>\<^sub>C x\<guillemotright>" using x y h \<psi>_mapsto [of x y] by auto
       show "\<phi> y (\<psi> x h) = h"
       proof -
         have 0: "restrict (\<lambda>h. h) (HomD.set (y, G x))
                    = restrict (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (HomD.set (y, G x))"
         proof -
           have 1: "S.ide (S (\<Phi> (y, x)) (\<Psi> (y, x)))"
             using x y \<Phi>\<Psi>.inv by force
           hence 6: "S.seq (\<Phi> (y, x)) (\<Psi> (y, x))" by auto
           have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) \<and>
                    \<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                        (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
             using x h \<Phi>_simp \<Psi>_simp by auto
           have 3: "S (\<Phi> (y, x)) (\<Psi> (y, x))
                      = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))"
           proof -
             have 4: "S.seq (\<Phi> (y, x)) (\<Psi> (y, x))" using 1 by auto
             hence "S (\<Phi> (y, x)) (\<Psi> (y, x))
                      = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                ((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                                  o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x)))"
               using 1 2 6 S.ide_in_hom S.comp_mkArr by fastforce
             also have "... = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                      (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))"
             proof
               show "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                    ((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                                      o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))))"
                 using 4 calculation by simp
               show "\<And>h. h \<in> HomD.set (y, G x) \<Longrightarrow>
                           ((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                             o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))) h =
                           (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) h"
               proof -
                 fix h
                 assume h: "h \<in> HomD.set (y, G x)"
                 hence "\<guillemotleft>\<psi> x (\<psi>D (y, G x) h) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
                   using x y HomD.\<psi>_mapsto [of y "G x"] \<psi>_mapsto by auto
                 thus "((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                             o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))) h =
                       (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) h"
                   using x y HomC.\<psi>_\<phi> by simp
               qed
             qed
             finally show ?thesis by auto
           qed
           moreover have "\<Phi> (y, x) \<cdot>\<^sub>S \<Psi> (y, x) =
                            S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (\<lambda>h. h)"
             using 1 2 6 calculation
             by (metis S.arr_mkArr S.cod_mkArr S.ide_in_hom S.mkIde_as_mkArr S.in_homE)
           ultimately have 4: "S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))
                                 = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (\<lambda>h. h)"
             by auto
           have 5: "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                   (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)))"
             using 1 3 by fastforce
           hence "restrict (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (HomD.set (y, G x))
                   = S.Fun (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                          (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)))"
             by auto
           also have "... = restrict (\<lambda>h. h) (HomD.set (y, G x))"
             using 4 5 by auto
           finally show ?thesis by auto
         qed
         moreover have "\<phi>D (y, G x) h \<in> HomD.set (y, G x)"
           using x y h HomD.\<phi>_mapsto [of y "G x"] by auto
         ultimately have
             "\<phi>D (y, G x) h = (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (\<phi>D (y, G x) h)"
           by fast
         hence "\<psi>D (y, G x) (\<phi>D (y, G x) h) =
                 \<psi>D (y, G x) ((\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (\<phi>D (y, G x) h))"
           by simp
         hence "h = \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi> x (\<psi>D (y, G x) (\<phi>D (y, G x) h)))))"
           using x y h HomD.\<psi>_\<phi> by simp
         also have "... = \<phi> y (\<psi> x h)"
           using x y h HomD.\<psi>_\<phi> HomD.\<psi>_\<phi> [of "\<phi> y (\<psi> x h)" y "G x"] \<phi>_mapsto \<psi>_mapsto
           by fastforce
         finally show ?thesis by auto
       qed
       next
       fix x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
       and f :: 'c and g :: 'd and h :: 'c
       assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       have x: "C.ide x" using f by auto
       have y: "D.ide y" using g by auto
       have x': "C.ide x'" using f by auto
       have y': "D.ide y'" using g by auto
       show "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
       proof -
         have 0: "restrict ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                            o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                        (HomC.set (F y, x))
                 = restrict ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                              o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)) o \<psi>C (F y, x))
                            (HomC.set (F y, x))"
         proof -
           have 1: "S.arr (\<Phi> (y, x)) \<and>
                    \<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
                 using x y \<Phi>_simp [of y x] by auto
           have 2: "S.arr (\<Phi> (y', x')) \<and>
                    \<Phi> (y', x') = S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                         (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))"
                 using x' y' \<Phi>_simp [of y' x'] by auto
           have 3: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                   ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                     o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))
                    \<and> S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                              ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                      = S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                   (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                          (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                   (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
           proof -
             have 1: "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                   (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                            (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                   (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
             proof -
               have "S.arr (Hom_DopxG.map (g, f)) \<and>
                     Hom_DopxG.map (g, f)
                         = S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                   (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))"
                 using f g Hom_DopxG.preserves_arr Hom_DopxG_map_simp by fastforce
               thus ?thesis
                 using 1 S.cod_mkArr S.dom_mkArr S.seqI by metis
             qed
             have "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                  (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                         (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                  (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
               using 1 by (intro S.seqI', auto)
             moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                              ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                              = S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                           (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                                  (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                           (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
               using 1 S.comp_mkArr by fastforce
             ultimately show ?thesis by auto
           qed
           moreover have
              4: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                 ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                   o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))))
                  \<and> S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                            ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                              o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
                      = S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x')) 
                                   (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                          (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                   (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
           proof -
             have 5: "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                     (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                            (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                     (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
             proof -
               have "S.arr (Hom_FopxC.map (g, f)) \<and>
                     Hom_FopxC.map (g, f)
                           = S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                     (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"
                 using f g Hom_FopxC.preserves_arr Hom_FopxC_map_simp by fastforce
               thus ?thesis using 2 S.cod_mkArr S.dom_mkArr S.seqI by metis
             qed
             have "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                  (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                         (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                  (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
               using 5 by (intro S.seqI', auto)
             moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                    ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                      o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
                              = S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                           (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                                  (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                           (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
               using 5 S.comp_mkArr by fastforce
             ultimately show ?thesis by argo
           qed
           moreover have 2:
               "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                        ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                          o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                   = S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                             ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                               o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
           proof -
             have
               "S (Hom_DopxG.map (g, f)) (\<Phi> (y, x)) = S (\<Phi> (y', x')) (Hom_FopxC.map (g, f))"
               using f g \<Phi>.is_natural_1 \<Phi>.is_natural_2 by fastforce
             moreover have "Hom_DopxG.map (g, f)
                              = S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                        (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))"
               using f g Hom_DopxG_map_simp [of "(g, f)"] by fastforce
             moreover have "Hom_FopxC.map (g, f)
                              = S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                        (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"
               using f g Hom_FopxC_map_simp [of "(g, f)"] by fastforce
             ultimately show ?thesis using 1 2 3 4 by simp
           qed
           ultimately have 6: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                              ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                                o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
             by fast
           hence "restrict ((\<phi>D (y', G x') o (\<lambda>h. D (G f) (D h g)) o \<psi>D (y, G x))
                             o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                           (HomC.set (F y, x))
                   = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                   ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                     o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
             by simp
           also have "... = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                        ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                          o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))))"
             using 2 by argo
           also have "... = restrict ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                       o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
                                     (HomC.set (F y, x))"
             using 4 S.Fun_mkArr by meson
           finally show ?thesis by auto
         qed
         hence 5: "((\<phi>D (y', G x') \<circ> (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) \<circ> \<psi>D (y, G x))
                     \<circ> (\<phi>D (y, G x) \<circ> \<phi> y \<circ> \<psi>C (F y, x))) (\<phi>C (F y, x) h) =
                    (\<phi>D (y', G x') \<circ> \<phi> y' \<circ> \<psi>C (F y', x')
                      \<circ> (\<phi>C (F y', x') \<circ> (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)) \<circ> \<psi>C (F y, x)) (\<phi>C (F y, x) h)"
         proof -
           have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
             using x y h HomC.\<phi>_mapsto [of "F y" x] by auto
           thus ?thesis
             using 0 h restr_eqE [of "(\<phi>D (y', G x') \<circ> (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) \<circ> \<psi>D (y, G x))
                                       \<circ> (\<phi>D (y, G x) \<circ> \<phi> y \<circ> \<psi>C (F y, x))"
                                     "HomC.set (F y, x)"
                                     "(\<phi>D (y', G x') \<circ> \<phi> y' \<circ> \<psi>C (F y', x'))
                                        \<circ> (\<phi>C (F y', x') \<circ> (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"]
             by fast
         qed
         show ?thesis
         proof -
           have "\<phi> y' (C f (C h (F g))) =
                   \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
                      (C f (C (\<psi>C (F y, x) (\<phi>C (F y, x) h)) (F g)))))))"
           proof -
             have "\<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
                      (C f (C (\<psi>C (F y, x) (\<phi>C (F y, x) h)) (F g)))))))
                     = \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
                          (C f (C h (F g)))))))"
               using x y h HomC.\<psi>_\<phi> by simp
             also have "... = \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (C f (C h (F g)))))"
               using f g h HomC.\<psi>_\<phi> [of "C f (C h (F g))"] by fastforce
             also have "... = \<phi> y' (C f (C h (F g)))"
             proof -
               have "\<guillemotleft>\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) : y' \<rightarrow>\<^sub>D G x'\<guillemotright>"
                 using f g h y' x' \<phi>_mapsto [of y' x'] by auto
               thus ?thesis by simp
             qed
             finally show ?thesis by auto
           qed
           also have
              "... = \<psi>D (y', G x')
                        (\<phi>D (y', G x')
                            (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h))))
                                 \<cdot>\<^sub>D g))"
             using 5 by force
           also have "... = D (G f) (D (\<phi> y h) g)"
           proof -
             have \<phi>yh: "\<guillemotleft>\<phi> y h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
               using x y h \<phi>_mapsto by auto
             have "\<psi>D (y', G x')
                      (\<phi>D (y', G x')
                          (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h))))
                               \<cdot>\<^sub>D g)) =
                   \<psi>D (y', G x') (\<phi>D (y', G x') (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y h)) \<cdot>\<^sub>D g))"
               using x y f g h by auto
             also have "... = \<psi>D (y', G x') (\<phi>D (y', G x') (G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g))"
               using \<phi>yh x' y' f g by simp
             also have "... = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
               using \<phi>yh f g by fastforce
             finally show ?thesis by auto
           qed
           finally show ?thesis by auto
         qed
       qed
     qed
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>" ..
 
   end
 
   section "Putting it All Together"
 
   text\<open>
     Combining the above results, an interpretation of any one of the locales:
     \<open>left_adjoint_functor\<close>, \<open>right_adjoint_functor\<close>, \<open>meta_adjunction\<close>,
     \<open>hom_adjunction\<close>, and \<open>unit_counit_adjunction\<close> extends to an interpretation
     of \<open>adjunction\<close>.
 \<close>
 
   context meta_adjunction
   begin
 
     interpretation F: left_adjoint_functor D C F using has_left_adjoint_functor by auto
     interpretation G: right_adjoint_functor C D G using has_right_adjoint_functor by auto
 
     interpretation \<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon>
       using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
     interpretation \<Phi>\<Psi>: hom_adjunction C D replete_setcat.comp \<phi>C \<phi>D F G \<Phi> \<Psi>
       using induces_hom_adjunction by auto
 
     theorem induces_adjunction:
     shows "adjunction C D replete_setcat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
       using \<epsilon>_map_simp \<eta>_map_simp \<phi>_in_terms_of_\<eta> \<phi>_in_terms_of_\<Phi>' \<psi>_in_terms_of_\<epsilon>
             \<psi>_in_terms_of_\<Psi>' \<Phi>_simp \<Psi>_simp \<eta>_def \<epsilon>_def
       by unfold_locales auto
 
   end
 
   context unit_counit_adjunction
   begin
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi> using induces_meta_adjunction by auto
 
     interpretation F: left_adjoint_functor D C F using \<phi>\<psi>.has_left_adjoint_functor by auto
     interpretation G: right_adjoint_functor C D G using \<phi>\<psi>.has_right_adjoint_functor by auto
 
     interpretation \<Phi>\<Psi>: hom_adjunction C D replete_setcat.comp
                           \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>
       using \<phi>\<psi>.induces_hom_adjunction by auto
 
     theorem induces_adjunction:
     shows "adjunction C D replete_setcat.comp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
       using \<epsilon>_in_terms_of_\<psi> \<eta>_in_terms_of_\<phi> \<phi>\<psi>.\<phi>_in_terms_of_\<Phi>' \<psi>_def \<phi>\<psi>.\<psi>_in_terms_of_\<Psi>'
             \<phi>\<psi>.\<Phi>_simp \<phi>\<psi>.\<Psi>_simp \<phi>_def
       by unfold_locales auto
 
   end
 
   context hom_adjunction
   begin
    
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using induces_meta_adjunction by auto
     interpretation F: left_adjoint_functor D C F using \<phi>\<psi>.has_left_adjoint_functor by auto
     interpretation G: right_adjoint_functor C D G using \<phi>\<psi>.has_right_adjoint_functor by auto
     interpretation \<eta>\<epsilon>: unit_counit_adjunction C D F G \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon>
       using \<phi>\<psi>.induces_unit_counit_adjunction \<phi>\<psi>.\<eta>_def \<phi>\<psi>.\<epsilon>_def by auto
 
     theorem induces_adjunction:
     shows "adjunction C D S \<phi>C \<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<Phi> \<Psi>"
     proof
       fix x
       assume "C.ide x"
       thus "\<phi>\<psi>.\<epsilon> x = \<psi> x (G x)"
         using \<phi>\<psi>.\<epsilon>_map_simp \<phi>\<psi>.\<epsilon>_def by simp
       next
       fix y
       assume "D.ide y"
       thus "\<phi>\<psi>.\<eta> y = \<phi> y (F y)"
         using \<phi>\<psi>.\<eta>_map_simp \<phi>\<psi>.\<eta>_def by simp
       fix x y f
       assume y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       show "\<phi> y f = G f \<cdot>\<^sub>D \<phi>\<psi>.\<eta> y"
         using y f \<phi>\<psi>.\<phi>_in_terms_of_\<eta> \<phi>\<psi>.\<eta>_def by simp
       show "\<phi> y f = (\<psi>D (y, G x) \<circ> \<Phi>.FUN (y, x) \<circ> \<phi>C (F y, x)) f"
         using y f \<phi>_def by auto
       next
       fix x y g
       assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       show "\<psi> x g = \<phi>\<psi>.\<epsilon> x \<cdot>\<^sub>C F g"
         using x g \<phi>\<psi>.\<psi>_in_terms_of_\<epsilon> \<phi>\<psi>.\<epsilon>_def by simp
       show "\<psi> x g = (\<psi>C (F y, x) \<circ> \<Psi>.FUN (y, x) \<circ> \<phi>D (y, G x)) g"
         using x g \<psi>_def by fast
       next
       fix x y
       assume x: "C.ide x" and y: "D.ide y"
       show "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
         using x y \<Phi>_simp by simp
       show "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                 (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
         using x y \<Psi>_simp by simp
     qed
 
   end
 
   context left_adjoint_functor
   begin
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using induces_meta_adjunction by auto
 
     theorem induces_adjunction:
     shows "adjunction C D replete_setcat.comp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
       using \<phi>\<psi>.induces_adjunction by auto
 
   end
 
   context right_adjoint_functor
   begin
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using induces_meta_adjunction by auto
 
     theorem induces_adjunction:
     shows "adjunction C D replete_setcat.comp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
       using \<phi>\<psi>.induces_adjunction by auto
 
   end
 
   definition adjoint_functors
   where "adjoint_functors C D F G = (\<exists>\<phi> \<psi>. meta_adjunction C D F G \<phi> \<psi>)"
 
   lemma adjoint_functors_respects_naturally_isomorphic:
   assumes "adjoint_functors C D F G"
   and "naturally_isomorphic D C F' F" and "naturally_isomorphic C D G G'"
   shows "adjoint_functors C D F' G'"
   proof -
     obtain \<phi> \<psi> where \<phi>\<psi>: "meta_adjunction C D F G \<phi> \<psi>"
       using assms(1) adjoint_functors_def by blast
     interpret \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using \<phi>\<psi> by simp
     obtain \<tau> where \<tau>: "natural_isomorphism D C F' F \<tau>"
       using assms(2) naturally_isomorphic_def by blast
     obtain \<mu> where \<mu>: "natural_isomorphism C D G G' \<mu>"
       using assms(3) naturally_isomorphic_def by blast
     show ?thesis
       using adjoint_functors_def \<tau> \<mu> \<phi>\<psi>.respects_natural_isomorphism by blast
   qed
 
   lemma left_adjoint_functor_respects_naturally_isomorphic:
   assumes "left_adjoint_functor D C F"
   and "naturally_isomorphic D C F F'"
   shows "left_adjoint_functor D C F'"
   proof -
     interpret F: left_adjoint_functor D C F
       using assms(1) by simp
     have 1: "meta_adjunction C D F F.G F.\<phi> F.\<psi>"
       using F.induces_meta_adjunction by simp
     interpret \<phi>\<psi>: meta_adjunction C D F F.G F.\<phi> F.\<psi>
       using 1 by simp
     have "adjoint_functors C D F F.G"
       using 1 adjoint_functors_def by blast
     hence 2: "adjoint_functors C D F' F.G"
       using assms(2) adjoint_functors_respects_naturally_isomorphic [of C D F F.G F' F.G]
             naturally_isomorphic_reflexive naturally_isomorphic_symmetric
             \<phi>\<psi>.G.functor_axioms
       by blast
     obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D F' F.G \<phi>' \<psi>'"
       using 2 adjoint_functors_def by blast
     interpret \<phi>'\<psi>': meta_adjunction C D F' F.G \<phi>' \<psi>'
       using \<phi>'\<psi>' by simp
     show ?thesis
       using \<phi>'\<psi>'.has_left_adjoint_functor by simp
   qed
 
   lemma right_adjoint_functor_respects_naturally_isomorphic:
   assumes "right_adjoint_functor C D G"
   and "naturally_isomorphic C D G G'"
   shows "right_adjoint_functor C D G'"
   proof -
     interpret G: right_adjoint_functor C D G
       using assms(1) by simp
     have 1: "meta_adjunction C D G.F G G.\<phi> G.\<psi>"
       using G.induces_meta_adjunction by simp
     interpret \<phi>\<psi>: meta_adjunction C D G.F G G.\<phi> G.\<psi>
       using 1 by simp
     have "adjoint_functors C D G.F G"
       using 1 adjoint_functors_def by blast
     hence 2: "adjoint_functors C D G.F G'"
       using assms(2) adjoint_functors_respects_naturally_isomorphic
             naturally_isomorphic_reflexive naturally_isomorphic_symmetric
             \<phi>\<psi>.F.functor_axioms
       by blast
     obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D G.F G' \<phi>' \<psi>'"
       using 2 adjoint_functors_def by blast
     interpret \<phi>'\<psi>': meta_adjunction C D G.F G' \<phi>' \<psi>'
       using \<phi>'\<psi>' by simp
     show ?thesis
       using \<phi>'\<psi>'.has_right_adjoint_functor by simp
   qed
 
   section "Inverse Functors are Adjoints"
 
   (* TODO: This really should show that inverse functors induce an adjoint equivalence. *)
 
   lemma inverse_functors_induce_meta_adjunction:
   assumes "inverse_functors C D F G"
   shows "meta_adjunction C D F G (\<lambda>x. G) (\<lambda>y. F)"
   proof -
     interpret inverse_functors C D F G using assms by auto
     interpret meta_adjunction C D F G \<open>\<lambda>x. G\<close> \<open>\<lambda>y. F\<close>
     proof -
       have 1: "\<And>y. B.arr y \<Longrightarrow> G (F y) = y"
         by (metis B.map_simp comp_apply inv)
       have 2: "\<And>x. A.arr x \<Longrightarrow> F (G x) = x"
         by (metis A.map_simp comp_apply inv')
       show "meta_adjunction C D F G (\<lambda>x. G) (\<lambda>y. F)"
       proof
         fix y f x
         assume y: "B.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "\<guillemotleft>G f : y \<rightarrow>\<^sub>B G x\<guillemotright>"
           using y f 1 G.preserves_hom by (elim A.in_homE, auto)
         show "F (G f) = f"
           using f 2 by auto
         next
         fix x g y
         assume x: "A.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>B G x\<guillemotright>"
         show "\<guillemotleft>F g : F y \<rightarrow>\<^sub>A x\<guillemotright>"
           using x g 2 F.preserves_hom by (elim B.in_homE, auto)
         show "G (F g) = g" using g 1 A.map_def by blast
         next
         fix f x x' g y' y h
         assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>A x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>B y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "G (C f (C h (F g))) = D (G f) (D (G h) g)"
           using f g h 1 2 inv inv' A.map_def B.map_def by (elim A.in_homE B.in_homE, auto)
       qed
     qed
     show ?thesis ..
   qed
 
   lemma inverse_functors_are_adjoints:
   assumes "inverse_functors A B F G"
   shows "adjoint_functors A B F G"
     using assms inverse_functors_induce_meta_adjunction adjoint_functors_def by fast
 
   context inverse_functors
   begin
 
     lemma \<eta>_char:
     shows "meta_adjunction.\<eta> B F (\<lambda>x. G) = identity_functor.map B"
     proof (intro eqI)
       interpret meta_adjunction A B F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close>
         using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
       interpret adjunction A B replete_setcat.comp \<phi>C \<phi>D F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close> \<eta> \<epsilon> \<Phi> \<Psi>
         using induces_adjunction by force
       show "natural_transformation B B B.map GF.map \<eta>"
         using \<eta>.natural_transformation_axioms by auto
       show "natural_transformation B B B.map GF.map B.map"
         by (simp add: B.as_nat_trans.natural_transformation_axioms inv)
       show "\<And>b. B.ide b \<Longrightarrow> \<eta> b = B.map b"
         using \<eta>_in_terms_of_\<phi> \<eta>o_def \<eta>o_in_hom by fastforce
     qed
 
     lemma \<epsilon>_char:
     shows "meta_adjunction.\<epsilon> A F G (\<lambda>y. F) = identity_functor.map A"
     proof (intro eqI)
       interpret meta_adjunction A B F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close>
         using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
       interpret adjunction A B replete_setcat.comp \<phi>C \<phi>D F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close> \<eta> \<epsilon> \<Phi> \<Psi>
         using induces_adjunction by force
       show "natural_transformation A A FG.map A.map \<epsilon>"
         using \<epsilon>.natural_transformation_axioms by auto
       show "natural_transformation A A FG.map A.map A.map"
         by (simp add: A.as_nat_trans.natural_transformation_axioms inv')
       show "\<And>a. A.ide a \<Longrightarrow> \<epsilon> a = A.map a"
         using \<epsilon>_in_terms_of_\<psi> \<epsilon>o_def \<epsilon>o_in_hom by fastforce
     qed
 
   end
 
   section "Composition of Adjunctions"
 
   locale composite_adjunction =
     A: category A +
     B: category B +
     C: category C +
     F: "functor" B A F +
     G: "functor" A B G +
     F': "functor" C B F' +
     G': "functor" B C G' +
     FG: meta_adjunction A B F G \<phi> \<psi> +
     F'G': meta_adjunction B C F' G' \<phi>' \<psi>'
   for A :: "'a comp"     (infixr "\<cdot>\<^sub>A" 55)
   and B :: "'b comp"     (infixr "\<cdot>\<^sub>B" 55)
   and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and F :: "'b \<Rightarrow> 'a"
   and G :: "'a \<Rightarrow> 'b"
   and F' :: "'c \<Rightarrow> 'b"
   and G' :: "'b \<Rightarrow> 'c"
   and \<phi> :: "'b \<Rightarrow> 'a \<Rightarrow> 'b"
   and \<psi> :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
   and \<phi>' :: "'c \<Rightarrow> 'b \<Rightarrow> 'c"
   and \<psi>' :: "'b \<Rightarrow> 'c \<Rightarrow> 'b"
   begin
 
     interpretation FG: adjunction A B replete_setcat.comp
                            FG.\<phi>C FG.\<phi>D F G \<phi> \<psi> FG.\<eta> FG.\<epsilon> FG.\<Phi> FG.\<Psi>
       using FG.induces_adjunction by simp
     interpretation F'G': adjunction B C replete_setcat.comp F'G'.\<phi>C F'G'.\<phi>D F' G' \<phi>' \<psi>'
                            F'G'.\<eta> F'G'.\<epsilon> F'G'.\<Phi> F'G'.\<Psi>
       using F'G'.induces_adjunction by simp
 
     (* Notation for C.in_hom is inherited here somehow, but I don't know from where. *)
 
     lemma is_meta_adjunction:
     shows "meta_adjunction A C (F o F') (G' o G) (\<lambda>z. \<phi>' z o \<phi> (F' z)) (\<lambda>x. \<psi> x o \<psi>' (G x))"
     proof -
       interpret G'oG: composite_functor A B C G G' ..
       interpret FoF': composite_functor C B A F' F ..
       show ?thesis
       proof
         fix y f x
         assume y: "C.ide y" and f: "\<guillemotleft>f : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "\<guillemotleft>(\<phi>' y \<circ> \<phi> (F' y)) f : y \<rightarrow>\<^sub>C G'oG.map x\<guillemotright>"
           using y f FG.\<phi>_in_hom F'G'.\<phi>_in_hom by simp
         show "(\<psi> x \<circ> \<psi>' (G x)) ((\<phi>' y \<circ> \<phi> (F' y)) f) = f"
           using y f FG.\<phi>_in_hom F'G'.\<phi>_in_hom FG.\<psi>_\<phi> F'G'.\<psi>_\<phi> by simp
         next
         fix x g y
         assume x: "A.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>C G'oG.map x\<guillemotright>"
         show "\<guillemotleft>(\<psi> x \<circ> \<psi>' (G x)) g : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
           using x g FG.\<psi>_in_hom F'G'.\<psi>_in_hom by auto
         show "(\<phi>' y \<circ> \<phi> (F' y)) ((\<psi> x \<circ> \<psi>' (G x)) g) = g"
           using x g FG.\<psi>_in_hom F'G'.\<psi>_in_hom FG.\<phi>_\<psi> F'G'.\<phi>_\<psi> by simp
         next
         fix f x x' g y' y h
         assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>A x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>C y\<guillemotright>" and h: "\<guillemotleft>h : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "(\<phi>' y' \<circ> \<phi> (F' y')) (f \<cdot>\<^sub>A h \<cdot>\<^sub>A FoF'.map g) =
               G'oG.map f \<cdot>\<^sub>C (\<phi>' y \<circ> \<phi> (F' y)) h \<cdot>\<^sub>C g"
           using f g h FG.\<phi>_naturality [of f x x' "F' g" "F' y'" "F' y" h]
                 F'G'.\<phi>_naturality [of "G f" "G x" "G x'" g y' y "\<phi> (F' y) h"]
                 FG.\<phi>_in_hom
           by fastforce
       qed
     qed
 
     interpretation K\<eta>H: natural_transformation C C \<open>G' o F'\<close> \<open>G' o G o F o F'\<close>
                           \<open>G' o FG.\<eta> o F'\<close>
     proof -
       interpret \<eta>F': natural_transformation C B F' \<open>(G o F) o F'\<close> \<open>FG.\<eta> o F'\<close>
         using FG.\<eta>_is_natural_transformation F'.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret G'\<eta>F': natural_transformation C C \<open>G' o F'\<close> \<open>G' o (G o F o F')\<close>
                          \<open>G' o (FG.\<eta> o F')\<close>
         using \<eta>F'.natural_transformation_axioms G'.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by blast
       show "natural_transformation C C (G' o F') (G' o G o F o F') (G' o FG.\<eta> o F')"
         using G'\<eta>F'.natural_transformation_axioms o_assoc by metis
     qed
     interpretation G'\<eta>F'o\<eta>': vertical_composite C C C.map \<open>G' o F'\<close> \<open>G' o G o F o F'\<close>
                              F'G'.\<eta> \<open>G' o FG.\<eta> o F'\<close> ..
 
     interpretation F\<epsilon>G: natural_transformation A A \<open>F o F' o G' o G\<close> \<open>F o G\<close>
                           \<open>F o F'G'.\<epsilon> o G\<close>
     proof -
       interpret F\<epsilon>': natural_transformation B A \<open>F o (F' o G')\<close> F \<open>F o F'G'.\<epsilon>\<close>
         using F'G'.\<epsilon>.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret F\<epsilon>'G: natural_transformation A A \<open>F o (F' o G') o G\<close> \<open>F o G\<close> \<open>F o F'G'.\<epsilon> o G\<close>
         using F\<epsilon>'.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by blast
       show "natural_transformation A A (F o F' o G' o G) (F o G) (F o F'G'.\<epsilon> o G)"
         using F\<epsilon>'G.natural_transformation_axioms o_assoc by metis
     qed
     interpretation \<epsilon>oF\<epsilon>'G: vertical_composite A A \<open>F \<circ> F' \<circ> G' \<circ> G\<close> \<open>F o G\<close> A.map
                              \<open>F o F'G'.\<epsilon> o G\<close> FG.\<epsilon> ..
 
     interpretation meta_adjunction A C \<open>F o F'\<close> \<open>G' o G\<close>
                                    \<open>\<lambda>z. \<phi>' z o \<phi> (F' z)\<close> \<open>\<lambda>x. \<psi> x o \<psi>' (G x)\<close>
       using is_meta_adjunction by auto
     interpretation adjunction A C replete_setcat.comp \<phi>C \<phi>D \<open>F \<circ> F'\<close> \<open>G' \<circ> G\<close>
                      \<open>\<lambda>z. \<phi>' z \<circ> \<phi> (F' z)\<close> \<open>\<lambda>x. \<psi> x \<circ> \<psi>' (G x)\<close> \<eta> \<epsilon> \<Phi> \<Psi>
       using induces_adjunction by simp
 
     lemma \<eta>_char:
     shows "\<eta> = G'\<eta>F'o\<eta>'.map"
     proof (intro NaturalTransformation.eqI)
       show "natural_transformation C C C.map (G' o G o F o F') G'\<eta>F'o\<eta>'.map" ..
       show "natural_transformation C C C.map (G' o G o F o F') \<eta>"
         by (metis (no_types, lifting) \<eta>_is_natural_transformation o_assoc)
       fix a
       assume a: "C.ide a"
       show "\<eta> a = G'\<eta>F'o\<eta>'.map a"
         unfolding \<eta>_def
         using a G'\<eta>F'o\<eta>'.map_def FG.\<eta>.preserves_hom [of "F' a" "F' a" "F' a"]
               F'G'.\<phi>_in_terms_of_\<eta> FG.\<eta>_map_simp \<eta>_map_simp [of a] C.ide_in_hom
               F'G'.\<eta>_def FG.\<eta>_def
         by auto
     qed
 
     lemma \<epsilon>_char:
     shows "\<epsilon> = \<epsilon>oF\<epsilon>'G.map"
     proof (intro NaturalTransformation.eqI)
       show "natural_transformation A A (F o F' o G' o G) A.map \<epsilon>"
         by (metis (no_types, lifting) \<epsilon>_is_natural_transformation o_assoc)
       show "natural_transformation A A (F \<circ> F' \<circ> G' \<circ> G) A.map \<epsilon>oF\<epsilon>'G.map" ..
       fix a
       assume a: "A.ide a"
       show "\<epsilon> a = \<epsilon>oF\<epsilon>'G.map a"
       proof -
         have "\<epsilon> a = \<psi> a (\<psi>' (G a) (G' (G a)))"
           using a \<epsilon>_in_terms_of_\<psi> by simp
         also have "... = FG.\<epsilon> a \<cdot>\<^sub>A F (F'G'.\<epsilon> (G a) \<cdot>\<^sub>B F' (G' (G a)))"
-          unfolding \<epsilon>_def
-          using a F'G'.\<psi>_in_terms_of_\<epsilon> [of "G a" "G' (G a)" "G' (G a)"]
-                F'G'.\<epsilon>.preserves_hom [of "G a" "G a" "G a"]
-                FG.\<psi>_in_terms_of_\<epsilon> [of a "F'G'.\<epsilon> (G a) \<cdot>\<^sub>B F' (G' (G a))" "(F'G'.FG.map (G a))"]
-                F'G'.\<epsilon>_def FG.\<epsilon>_def
-          by fastforce
+          by (metis F'G'.\<epsilon>_in_terms_of_\<psi> F'G'.\<epsilon>o_def F'G'.\<epsilon>o_in_hom F'G'.\<eta>\<epsilon>.\<epsilon>_in_terms_of_\<psi>
+              F'G'.\<eta>\<epsilon>.\<psi>_def FG.G\<epsilon>.natural_transformation_axioms FG.\<psi>_in_terms_of_\<epsilon> a
+              functor.preserves_ide natural_transformation_def)
         also have "... = \<epsilon>oF\<epsilon>'G.map a"
           using a B.comp_arr_dom \<epsilon>oF\<epsilon>'G.map_def by simp
         finally show ?thesis by blast
       qed
     qed
 
   end
 
   section "Right Adjoints are Unique up to Natural Isomorphism"
 
   text\<open>
     As an example of the use of the of the foregoing development, we show that two right adjoints
     to the same functor are naturally isomorphic.
 \<close>
 
   theorem two_right_adjoints_naturally_isomorphic:
   assumes "adjoint_functors C D F G" and "adjoint_functors C D F G'"
   shows "naturally_isomorphic C D G G'"
   proof -
     text\<open>
       For any object @{term x} of @{term C}, we have that \<open>\<epsilon> x \<in> C.hom (F (G x)) x\<close>
       is a terminal arrow from @{term F} to @{term x}, and similarly for \<open>\<epsilon>' x\<close>.
       We may therefore obtain the unique coextension \<open>\<tau> x \<in> D.hom (G x) (G' x)\<close>
       of \<open>\<epsilon> x\<close> along \<open>\<epsilon>' x\<close>.
       An explicit formula for \<open>\<tau> x\<close> is \<open>D (G' (\<epsilon> x)) (\<eta>' (G x))\<close>.
       Similarly, we obtain \<open>\<tau>' x = D (G (\<epsilon>' x)) (\<eta> (G' x)) \<in> D.hom (G' x) (G x)\<close>.
       We show these are the components of inverse natural transformations between
       @{term G} and @{term G'}.
 \<close>
     obtain \<phi> \<psi> where \<phi>\<psi>: "meta_adjunction C D F G \<phi> \<psi>"
       using assms adjoint_functors_def by blast
     obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D F G' \<phi>' \<psi>'"
       using assms adjoint_functors_def by blast
     interpret Adj: meta_adjunction C D F G \<phi> \<psi> using \<phi>\<psi> by auto
     interpret Adj: adjunction C D replete_setcat.comp Adj.\<phi>C Adj.\<phi>D
                               F G \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
       using Adj.induces_adjunction by auto
     interpret Adj': meta_adjunction C D F G' \<phi>' \<psi>' using \<phi>'\<psi>' by auto
     interpret Adj': adjunction C D replete_setcat.comp Adj'.\<phi>C Adj'.\<phi>D
                                F G' \<phi>' \<psi>' Adj'.\<eta> Adj'.\<epsilon> Adj'.\<Phi> Adj'.\<Psi>
       using Adj'.induces_adjunction by auto
     write C (infixr "\<cdot>\<^sub>C" 55)
     write D (infixr "\<cdot>\<^sub>D" 55)
     write Adj.C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     write Adj.D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
     let ?\<tau>o = "\<lambda>a. G' (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G a)"
     interpret \<tau>: transformation_by_components C D G G' ?\<tau>o
     proof
       show "\<And>a. Adj.C.ide a \<Longrightarrow> \<guillemotleft>G' (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G a) : G a \<rightarrow>\<^sub>D G' a\<guillemotright>"
         by fastforce
       show "\<And>f. Adj.C.arr f \<Longrightarrow>
                    (G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
                    G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
       proof -
         fix f
         assume f: "Adj.C.arr f"
         let ?x = "Adj.C.dom f"
         let ?x' = "Adj.C.cod f"
         have "(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
               G' (Adj.\<epsilon> (Adj.C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           using f Adj'.\<eta>.naturality [of "G f"] Adj.D.comp_assoc by simp
         also have "... = G' (f \<cdot>\<^sub>C Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           using f Adj.\<epsilon>.naturality by simp
         also have "... = G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           using f Adj.D.comp_assoc by simp
         finally show "(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
                       G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           by auto
       qed
     qed
     interpret natural_isomorphism C D G G' \<tau>.map
     proof
       fix a
       assume a: "Adj.C.ide a"
       show "Adj.D.iso (\<tau>.map a)"
       proof
         show "Adj.D.inverse_arrows (\<tau>.map a) (\<phi> (G' a) (Adj'.\<epsilon> a))"
         proof
           text\<open>
             The proof that the two composites are identities is a modest diagram chase.
             This is a good example of the inference rules for the \<open>category\<close>,
             \<open>functor\<close>, and \<open>natural_transformation\<close> locales in action.
             Isabelle is able to use the single hypothesis that \<open>a\<close> is an identity to
             implicitly fill in all the details that the various quantities are in fact arrows
             and that the indicated composites are all well-defined, as well as to apply
             associativity of composition.  In most cases, this is done by auto or simp without
             even mentioning any of the rules that are used.
 $$\xymatrix{
         {G' a} \ar[dd]_{\eta'(G'a)} \ar[rr]^{\tau' a} \ar[dr]_{\eta(G'a)}
            && {G a} \ar[rr]^{\tau a} \ar[dr]_{\eta'(Ga)} && {G' a}                     \\
         & {GFG'a} \rrtwocell\omit{\omit(2)} \ar[ur]_{G(\epsilon' a)} \ar[dr]_{\eta'(GFG'a)}
            && {G'FGa} \drtwocell\omit{\omit(3)} \ar[ur]_{G'(\epsilon a)} &            \\
         {G'FG'a} \urtwocell\omit{\omit(1)} \ar[rr]_{G'F\eta(G'a)} \ar@/_8ex/[rrrr]_{G'FG'a}
            && {G'FGFG'a} \dtwocell\omit{\omit(4)} \ar[ru]_{G'FG(\epsilon' a)} \ar[rr]_{G'(\epsilon(FG'a))}
            && {G'FG'a} \ar[uu]_{G'(\epsilon' a)}                                       \\
            &&&&
 }$$
 \<close>
           show "Adj.D.ide (\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a))"
           proof -
             have "\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a) = G' a"
             proof -
               have "\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a) =
                     G' (Adj.\<epsilon> a) \<cdot>\<^sub>D (Adj'.\<eta> (G a) \<cdot>\<^sub>D G (Adj'.\<epsilon> a)) \<cdot>\<^sub>D Adj.\<eta> (G' a)"
                 using a \<tau>.map_simp_ide Adj.\<phi>_in_terms_of_\<eta> Adj'.\<phi>_in_terms_of_\<eta>
                       Adj'.\<epsilon>.preserves_hom [of a a a] Adj.C.ide_in_hom Adj.D.comp_assoc
                       Adj.\<epsilon>_def Adj.\<eta>_def
                 by simp
               also have "... = G' (Adj.\<epsilon> a) \<cdot>\<^sub>D (G' (F (G (Adj'.\<epsilon> a))) \<cdot>\<^sub>D Adj'.\<eta> (G (F (G' a)))) \<cdot>\<^sub>D
                                Adj.\<eta> (G' a)"
                 using a Adj'.\<eta>.naturality [of "G (Adj'.\<epsilon> a)"] by auto
               also have "... = (G' (Adj.\<epsilon> a) \<cdot>\<^sub>D G' (F (G (Adj'.\<epsilon> a)))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) \<cdot>\<^sub>D
                                Adj'.\<eta> (G' a)"
                 using a Adj'.\<eta>.naturality [of "Adj.\<eta> (G' a)"] Adj.D.comp_assoc by auto
               also have
                   "... = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D (G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a)))) \<cdot>\<^sub>D
                          Adj'.\<eta> (G' a)"
               proof -
                 have
                    "G' (Adj.\<epsilon> a) \<cdot>\<^sub>D G' (F (G (Adj'.\<epsilon> a))) = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D G' (Adj.\<epsilon> (F (G' a)))"
                 proof -
                   have "G' (Adj.\<epsilon> a \<cdot>\<^sub>C F (G (Adj'.\<epsilon> a))) = G' (Adj'.\<epsilon> a \<cdot>\<^sub>C Adj.\<epsilon> (F (G' a)))"
                     using a Adj.\<epsilon>.naturality [of "Adj'.\<epsilon> a"] by auto
                   thus ?thesis using a by force
                 qed
                 thus ?thesis using Adj.D.comp_assoc by auto
               qed
               also have "... = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G' a)"
               proof -
                 have "G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) = G' (F (G' a))"
                 proof -
                   have
                       "G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) = G' (Adj.\<epsilon>FoF\<eta>.map (G' a))"
                     using a Adj.\<epsilon>FoF\<eta>.map_simp_1 by auto
                   moreover have "Adj.\<epsilon>FoF\<eta>.map (G' a) = F (G' a)"
                     using a by (simp add: Adj.\<eta>\<epsilon>.triangle_F)
                   ultimately show ?thesis by auto
                 qed
                 thus ?thesis
                   using a Adj.D.comp_cod_arr [of "Adj'.\<eta> (G' a)"] by auto
               qed
               also have "... = G' a"
                 using a Adj'.\<eta>\<epsilon>.triangle_G Adj'.G\<epsilon>o\<eta>G.map_simp_1 [of a] by auto
               finally show ?thesis by auto
             qed
             thus ?thesis using a by simp
           qed
           show "Adj.D.ide (\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a)"
           proof -
             have "\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a = G a"
             proof -
               have "\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a =
                     G (Adj'.\<epsilon> a) \<cdot>\<^sub>D (Adj.\<eta> (G' a) \<cdot>\<^sub>D G' (Adj.\<epsilon> a)) \<cdot>\<^sub>D Adj'.\<eta> (G a)"
                 using a \<tau>.map_simp_ide Adj.\<phi>_in_terms_of_\<eta> Adj'.\<epsilon>.preserves_hom [of a a a]
                       Adj.C.ide_in_hom Adj.D.comp_assoc Adj.\<eta>_def
                 by auto
               also have
                 "... = G (Adj'.\<epsilon> a) \<cdot>\<^sub>D (G (F (G' (Adj.\<epsilon> a))) \<cdot>\<^sub>D Adj.\<eta> (G' (F (G a)))) \<cdot>\<^sub>D
                        Adj'.\<eta> (G a)"
                 using a Adj.\<eta>.naturality [of "G' (Adj.\<epsilon> a)"] by auto
               also have
                 "... = (G (Adj'.\<epsilon> a) \<cdot>\<^sub>D G (F (G' (Adj.\<epsilon> a)))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) \<cdot>\<^sub>D
                        Adj.\<eta> (G a)"
                 using a Adj.\<eta>.naturality [of "Adj'.\<eta> (G a)"] Adj.D.comp_assoc by auto
               also have
                 "... = G (Adj.\<epsilon> a) \<cdot>\<^sub>D (G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a)))) \<cdot>\<^sub>D
                        Adj.\<eta> (G a)"
               proof -
                 have "G (Adj'.\<epsilon> a) \<cdot>\<^sub>D G (F (G' (Adj.\<epsilon> a))) = G (Adj.\<epsilon> a) \<cdot>\<^sub>D G (Adj'.\<epsilon> (F (G a)))"
                 proof -
                   have "G (Adj'.\<epsilon> a \<cdot>\<^sub>C F (G' (Adj.\<epsilon> a))) = G (Adj.\<epsilon> a \<cdot>\<^sub>C Adj'.\<epsilon> (F (G a)))"
                     using a Adj'.\<epsilon>.naturality [of "Adj.\<epsilon> a"] by auto
                   thus ?thesis using a by force
                 qed
                 thus ?thesis using Adj.D.comp_assoc by auto
               qed
               also have "... = G (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj.\<eta> (G a)"
               proof -
                 have "G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) = G (F (G a))"
                 proof -
                   have
                     "G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) = G (Adj'.\<epsilon>FoF\<eta>.map (G a))"
                     using a Adj'.\<epsilon>FoF\<eta>.map_simp_1 [of "G a"] by auto
                   moreover have "Adj'.\<epsilon>FoF\<eta>.map (G a) = F (G a)"
                     using a by (simp add: Adj'.\<eta>\<epsilon>.triangle_F)
                   ultimately show ?thesis by auto
                 qed
                 thus ?thesis
                   using a Adj.D.comp_cod_arr by auto
               qed
               also have "... = G a"
                 using a Adj.\<eta>\<epsilon>.triangle_G Adj.G\<epsilon>o\<eta>G.map_simp_1 [of a] by auto
               finally show ?thesis by auto
             qed
             thus ?thesis using a by auto
           qed
         qed
       qed
     qed
     have "natural_isomorphism C D G G' \<tau>.map" ..
     thus "naturally_isomorphic C D G G'"
       using naturally_isomorphic_def by blast
   qed
 
 end